From: Michael Orlitzky <michael@orlitzky.com>
Date: Tue, 21 Jan 2014 04:12:27 +0000 (-0500)
Subject: Add the FromXmlFk class, like FromXml except it requires an FK (old idea).
X-Git-Tag: 0.0.1~23
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=7815ba497d075c63c76418fc2c2b914ebe56b712;p=dead%2Fhtsn-import.git

Add the FromXmlFk class, like FromXml except it requires an FK (old idea).
Split the (Db a) associated type out into its own class, ToDb.
Update News, Odds, and Weather for the new typeclass hierarchy.
---

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 4a59859..130323c 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -58,7 +58,7 @@ import TSN.Codegen (
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers ( xp_time_stamp )
 import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
 
 
 
@@ -68,12 +68,15 @@ data NewsTeam =
   NewsTeam { team_name :: String }
   deriving (Eq, Show)
 
--- | This is needed to define the XmlImport instance for NewsTeam; it
---   basically says that the DB representation is the same as the XML
---   representation.
+
+instance ToDb NewsTeam where
+  -- | The database representaion of a 'NewsTeam' is itself.
+  type Db NewsTeam = NewsTeam
+
+-- | This is needed to define the XmlImport instance for NewsTeam.
 --
 instance FromXml NewsTeam where
-  type Db NewsTeam = NewsTeam
+  -- | How to we get a 'NewsTeam' from itself?
   from_xml = id
 
 -- | Allow us to call 'insert_xml' on the XML representation of
@@ -101,12 +104,14 @@ data NewsLocation =
     country :: String }
   deriving (Eq, Show)
 
--- | This is needed to define the XmlImport instance for NewsLocation; it
---   basically says that the DB representation is the same as the XML
---   representation.
+instance ToDb NewsLocation where
+  -- | The database representation of a 'NewsLocation' is itself.
+  type Db NewsLocation = NewsLocation
+
+-- | This is needed to define the XmlImport instance for NewsLocation.
 --
 instance FromXml NewsLocation where
-  type Db NewsLocation = NewsLocation
+  -- | How to we get a 'NewsLocation' from itself?
   from_xml = id
 
 -- | Allow us to call 'insert_xml' on the XML representation of
@@ -173,12 +178,14 @@ data News =
   deriving (Data, Eq, Show, Typeable)
 
 
+
+instance ToDb Message where
+  type Db Message = News
+
 -- | Convert the XML representation 'Message' to the database
 --   representation 'News'.
 --
 instance FromXml Message where
-  type Db Message = News
-
   -- | We use a record wildcard so GHC doesn't complain that we never
   --   used the field names.
   --
diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs
index 67ddbd4..5551bee 100644
--- a/src/TSN/XML/Odds.hs
+++ b/src/TSN/XML/Odds.hs
@@ -64,7 +64,7 @@ import TSN.Codegen (
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers ( xp_date, xp_time )
 import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
 
 
 
@@ -102,12 +102,13 @@ data OddsCasino =
   deriving (Eq, Show)
 
 
-instance FromXml OddsGameCasinoXml where
+instance ToDb OddsGameCasinoXml where
   -- | The database representation of an 'OddsGameCasinoXml' is an
   --   'OddsCasino'.
   --
   type Db OddsGameCasinoXml = OddsCasino
 
+instance FromXml OddsGameCasinoXml where
   -- | We convert from XML to the database by dropping the line field.
   from_xml OddsGameCasinoXml{..} =
     OddsCasino {
@@ -153,12 +154,13 @@ data OddsGameHomeTeamXml =
     xml_home_casinos         :: [OddsGameCasinoXml] }
   deriving (Eq, Show)
 
-instance FromXml OddsGameHomeTeamXml where
+instance ToDb OddsGameHomeTeamXml where
   -- | The database representation of an 'OddsGameHomeTeamXml' is an
   --   'OddsGameTeam'.
   --
   type Db OddsGameHomeTeamXml = OddsGameTeam
 
+instance FromXml OddsGameHomeTeamXml where
   -- | We convert from XML to the database by dropping the lines and
   --   rotation number (which are specific to the games, not the teams
   --   themselves).
@@ -192,12 +194,13 @@ data OddsGameAwayTeamXml =
     xml_away_casinos         :: [OddsGameCasinoXml] }
   deriving (Eq, Show)
 
-instance FromXml OddsGameAwayTeamXml where
+instance ToDb OddsGameAwayTeamXml where
   -- | The database representation of an 'OddsGameAwayTeamXml' is an
   --   'OddsGameTeam'.
   --
   type Db OddsGameAwayTeamXml = OddsGameTeam
 
+instance FromXml OddsGameAwayTeamXml where
   -- | We convert from XML to the database by dropping the lines and
   --   rotation number (which are specific to the games, not the teams
   --   themselves).
@@ -281,12 +284,13 @@ xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
 
 
-instance FromXml OddsGameXml where
+instance ToDb OddsGameXml where
   -- | The database representation of an 'OddsGameXml' is an
   --   'OddsGame'.
   --
   type Db OddsGameXml = OddsGame
 
+instance FromXml OddsGameXml where
   -- | To convert from the XML representation to the database one, we
   --   drop the home/away teams and the casino lines, but retain the
   --   home/away rotation numbers.
@@ -370,11 +374,12 @@ xml_games :: Message -> [OddsGameXml]
 xml_games m = map game (xml_games_with_notes m)
 
 
-instance FromXml Message where
+instance ToDb Message where
   -- | The database representation of a 'Message' is 'Odds'.
   --
   type Db Message = Odds
 
+instance FromXml Message where
   -- | To convert from the XML representation to the database one, we
   --   just drop a bunch of fields.
   --
diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 3773b31..f3b60af 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -52,7 +52,7 @@ import TSN.Codegen (
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers ( xp_gamedate )
 import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
 
 
 
@@ -64,12 +64,14 @@ data WeatherForecastListing =
     db_weather :: String }
   deriving (Eq, Show)
 
+-- | The database analogue of a 'WeatherForecastListing' is itself.
+instance ToDb WeatherForecastListing where
+  type Db WeatherForecastListing = WeatherForecastListing
+
 -- | This is needed to define the XmlImport instance for
--- 'WeatherForecastListing'; it basically says that the DB
--- representation is the same as the XML representation.
+-- 'WeatherForecastListing'.
 --
 instance FromXml WeatherForecastListing where
-  type Db WeatherForecastListing = WeatherForecastListing
   from_xml = id
 
 -- | Allows us to call 'insert_xml' on the XML representation of
@@ -110,12 +112,13 @@ data WeatherForecastXml =
   deriving (Eq, Show)
 
 
-instance FromXml WeatherForecastXml where
+instance ToDb WeatherForecastXml where
   -- | The database representation of a 'WeatherForecastXml' is a
   --   'WeatherForecast'.
   --
   type Db WeatherForecastXml = WeatherForecast
 
+instance FromXml WeatherForecastXml where
   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
   --   replace the 'WeatherLeague' with its name.
   --
@@ -151,11 +154,12 @@ data Message =
   deriving (Eq, Show)
 
 
-instance FromXml Message where
+instance ToDb Message where
   -- | The database representation of 'Message' is 'Weather'.
   --
   type Db Message = Weather
 
+instance FromXml Message where
   -- | To get a 'Weather' from a 'Message', we drop a bunch of
   --   unwanted fields.
   --
diff --git a/src/Xml.hs b/src/Xml.hs
index 2e9c18b..bbb72be 100644
--- a/src/Xml.hs
+++ b/src/Xml.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | General XML stuff.
@@ -6,6 +7,7 @@ module Xml (
   DtdName(..),
   FromXml(..),
   FromXmlFk(..),
+  ToDb(..),
   parse_opts,
   pickle_unpickle,
   unpickleable )
@@ -13,7 +15,7 @@ where
 
 -- System imports.
 import Control.Exception ( SomeException(..), catch )
-import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Core ( PersistEntity(..) )
 import Text.XML.HXT.Core (
   (>>>),
   (/>),
@@ -29,6 +31,13 @@ import Text.XML.HXT.Core (
   xunpickleVal,
   yes )
 
+-- | Common associated type shared by 'FromXml' and 'FromXmlFk'. This
+--   basically just forces the client to define the \"database
+--   version\" of his type.
+--
+class ToDb a where
+  -- | Each instance @a@ must declare its associated database type @Db a@.
+  type Db a :: *
 
 -- | A typeclass for XML types that can be converted into an
 --   associated database type. The story behind this is long, but
@@ -41,11 +50,8 @@ import Text.XML.HXT.Core (
 --   to get the database type from the XML type that we have to define
 --   for HXT.
 --
-class FromXml a where
-  -- | Each instance @a@ must declare its associated database type @Db a@.
-  type Db a :: *
-
-  -- | And provide a function for getting a @Db a@ out of an @a@.
+class (ToDb a) => FromXml a where
+  -- | A function for getting a @Db a@ out of an @a@.
   from_xml :: a -> Db a
 
 
@@ -54,17 +60,15 @@ class FromXml a where
 --   first. Members of this class can be converted from an XML
 --   representation to a database representation in this manner.
 --
-class FromXmlFk a where
-  -- | Each instance @a@ must declare its associated database type @DbFk a@.
-  type DbFk a :: *
-
+class (ToDb a) => FromXmlFk a where
   -- | The type of our parent object, i.e. to the type to whom our
   --   foreign key will point.
   type Parent a :: *
 
-  -- | The function that produces a @DbFk a@ out of an @a@ and a foreign
-  --   key.
-  from_xml_fk :: a -> DefaultKey (Parent a) -> DbFk a
+  -- | The function that produces a @Db a@ out of a foreign key and an
+  --   @a@. The parameter order makes it easier to map this function
+  --   over a bunch of things.
+  from_xml_fk :: DefaultKey (Parent a) -> a -> Db a
 
 
 -- | Represents the DTD filename (\"SYSTEM\") part of the DOCTYPE