X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FTeam.hs;h=070873947cf9f6e70824f9ec5fba5d41a565ccb5;hb=26ca22c40d96e7fae3fe54a97c98e096d0cbfc7f;hp=7ca326d80203b613467a57aec5a8c311cddb56c3;hpb=a5674b8ca8d643925fd1988fe3e7edf8b82e03fb;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/Team.hs b/src/TSN/Team.hs
index 7ca326d..0708739 100644
--- a/src/TSN/Team.hs
+++ b/src/TSN/Team.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -14,6 +15,7 @@
 --
 module TSN.Team (
   HTeam(..),
+  FromXmlFkTeams(..),
   Team(..),
   VTeam(..),
   -- * WARNING: these are private but exported to silence warnings
@@ -21,11 +23,17 @@ module TSN.Team (
 where
 
 -- System imports
+import Data.Vector.HFixed ( HVector )
 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 Xml ( Child(..), Db(..) )
 
 
 -- * Team
@@ -44,14 +52,17 @@ data Team =
                                   --   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 'H.convert'.
+--
+instance HVector 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
+--   of \"A\" (away) simply because \"vteam\" looks better than
 --   \"ateam\". This is purely for type-safety.
 --
 newtype VTeam = VTeam { vteam :: Team } deriving (Eq, Show)
@@ -76,3 +87,20 @@ mkPersist defaultCodegenConfig [groundhog|
           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