Add Generic instance for TSN.Team.

[dead/htsn-import.git] / src / TSN / Team.hs

diff --git a/src/TSN/Team.hs b/src/TSN/Team.hs
index 910c67120da44aa0b621f1bf3db87315c94694a2..1fef0a3447a2afaa4bfb579d3434bee10421dc7d 100644 (file)
--- a/src/TSN/Team.hs
+++ b/src/TSN/Team.hs
@@ -1,46 +1,81 @@
+{-# 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 :: Maybe String, -- ^ Some teams don't have abbreviations,
-                                       --   or at least, some sample jfilexml
-                                       --   don't have them for some teams.
-    team_name :: Maybe String -- ^ Some teams don't even have names!
+    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, Show)
+  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
@@ -48,7 +83,24 @@ mkPersist defaultCodegenConfig [groundhog|
   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