+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
--- | Two different XML types have a notion of teams: "TSN.XML.Odds"
--- and "TSN.XML.JFile". And in fact those two types agree on the
--- team id, abbreviation, and name -- at least for the database
--- representation.
+-- | (At least) two different XML types have a notion of teams:
+-- "TSN.XML.Odds" and "TSN.XML.JFile". And in fact those two types
+-- agree on the team id, abbreviation, and name -- at least for the
+-- database representation.
--
-- This module contains a data type for the common database
-- representation.
--
module TSN.Team (
+ HTeam(..),
+ FromXmlFkTeams(..),
Team(..),
+ VTeam(..),
-- * WARNING: these are private but exported to silence warnings
TeamConstructor(..) )
where
-- System imports
import Database.Groundhog () -- Required for some String instance
+import Database.Groundhog.Core ( PersistEntity(..) )
import Database.Groundhog.TH (
defaultCodegenConfig,
groundhog,
mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
+
+-- Local imports
+import Generics ( Generic(..) )
+import Xml ( Child(..), Db(..) )
+-- * Team
+
-- | The database representation of a team. The 'team_id' is a
-- 'String' field because some teams do in fact have ids like
--- \"B52\".
+-- \"B52\". The pointless \"team_\" prefix is left on the 'team_id'
+-- field because otherwise the auto-generated column name would
+-- conflict with the default \"id\" primary key.
--
data Team =
Team {
team_id :: String, -- ^ Some of them contain characters
- team_abbreviation :: String,
- team_name :: String }
- deriving (Eq, Show)
+ abbreviation :: Maybe String, -- ^ Some teams don't have abbreviations,
+ -- or at least, some sample jfilexml
+ -- don't have them for some teams.
+ name :: Maybe String -- ^ Some teams don't even have names!
+ }
+ deriving (Eq, GHC.Generic, Show)
+
+-- | Needed for 'Generics.to_tuple'.
+--
+instance Generic Team
+
+-- * VTeam / HTeam
+
+-- | A wrapper around 'Team' that lets us distinguish between home and
+-- away teams. See also 'HTeam'. \"V\" (visiting) was chosen instead
+-- of \"A\" (away) simply because \"vteam\" looks better than
+-- \"ateam\". This is purely for type-safety.
+--
+newtype VTeam = VTeam { vteam :: Team } deriving (Eq, Show)
+-- | A wrapper around 'Team' that lets us distinguish between home and
+-- away teams. See also 'VTeam'. This is purely for type-safety.
+--
+newtype HTeam = HTeam { hteam :: Team } deriving (Eq, Show)
+
+
+-- * Database stuff
+
-- Generate the Groundhog code for 'Team'.
mkPersist defaultCodegenConfig [groundhog|
- entity: Team
constructors:
- name: Team
uniques:
- - name: unique_odds_games_team
+ - name: unique_team
type: constraint
fields: [team_id]
|]
+
+
+
+-- | A further refinement of 'FromXmlFk'. These types need not only a
+-- foreign key to a parent in order to make the XML -> DB
+-- conversion, but also two foreign keys to away/home teams (as
+-- represented in "TSN.Team").
+--
+class (Child a, ToDb a) => FromXmlFkTeams a where
+ -- | The function that produces a @Db a@ out of a parent foreign
+ -- key, two team foreign keys, and an @a@. The parameter order makes
+ -- it easier to map this function over a bunch of things.
+ from_xml_fk_teams :: DefaultKey (Parent a)
+ -> DefaultKey Team -- ^ The away team FK
+ -> DefaultKey Team -- ^ The home team FK
+ -> a
+ -> Db a