From: Michael Orlitzky <michael@orlitzky.com>
Date: Tue, 21 Jan 2014 18:29:41 +0000 (-0500)
Subject: Update TSN.XML.Weather for the new typeclass hierarchy.
X-Git-Tag: 0.0.1~12
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=7edcf71e0947bfa02f9d898ccdf74b96458ae852;p=dead%2Fhtsn-import.git

Update TSN.XML.Weather for the new typeclass hierarchy.
Update the weatherxml schema diagram.
---

diff --git a/doc/dbschema/weatherxml.png b/doc/dbschema/weatherxml.png
index b39aceb..757cd4c 100644
Binary files a/doc/dbschema/weatherxml.png and b/doc/dbschema/weatherxml.png differ
diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 4951951..3279ec8 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -14,9 +14,7 @@ module TSN.XML.Weather (
   -- * Tests
   weather_tests,
   -- * WARNING: these are private but exported to silence warnings
-  Weather_WeatherForecastConstructor(..),
   WeatherConstructor(..),
-  WeatherForecast_WeatherForecastListingConstructor(..),
   WeatherForecastConstructor(..),
   WeatherForecastListingConstructor(..) )
 where
@@ -25,9 +23,7 @@ where
 import Control.Monad ( forM_ )
 import Data.Time ( UTCTime )
 import Data.Tuple.Curry ( uncurryN )
-import Database.Groundhog (
-  insert_,
-  migrate )
+import Database.Groundhog ( migrate )
 import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.TH (
   groundhog,
@@ -51,36 +47,58 @@ import TSN.Codegen (
   tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
-import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+  FromXml(..),
+  FromXmlFk(..),
+  ToDb(..),
+  pickle_unpickle,
+  unpickleable )
 
 
 --
 -- DB/XML Data types
 --
 
--- | Database/XML representation of a weather forecast listing.
+-- | XML representation of a weather forecast listing.
+--
+data WeatherForecastListingXml =
+  WeatherForecastListingXml {
+    xml_teams :: String,
+    xml_weather :: String }
+  deriving (Eq, Show)
+
+-- | Database representation of a weather forecast listing.
 --
 data WeatherForecastListing =
   WeatherForecastListing {
+    db_weather_forecasts_id :: DefaultKey WeatherForecast,
     db_teams :: String,
     db_weather :: String }
-  deriving (Eq, Show)
 
--- | The database analogue of a 'WeatherForecastListing' is itself.
-instance ToDb WeatherForecastListing where
-  type Db WeatherForecastListing = WeatherForecastListing
+
+-- | The database analogue of a 'WeatherForecastListingXml' is
+--   'WeatherForecastListing'.
+--
+instance ToDb WeatherForecastListingXml where
+  type Db WeatherForecastListingXml = WeatherForecastListing
 
 -- | This is needed to define the XmlImport instance for
 -- 'WeatherForecastListing'.
 --
-instance FromXml WeatherForecastListing where
-  from_xml = id
+instance FromXmlFk WeatherForecastListingXml where
+  type Parent WeatherForecastListingXml = WeatherForecast
+
+  from_xml_fk fk WeatherForecastListingXml{..} =
+    WeatherForecastListing {
+      db_weather_forecasts_id = fk,
+      db_teams = xml_teams,
+      db_weather = xml_weather }
 
 -- | Allows us to call 'insert_xml' on the XML representation of
 --   WeatherForecastListing.
 --
-instance XmlImport WeatherForecastListing
+instance XmlImportFk WeatherForecastListingXml
 
 
 -- | XML representation of a league, as they appear in the weather
@@ -93,14 +111,14 @@ instance XmlImport WeatherForecastListing
 data WeatherLeague =
   WeatherLeague {
     league_name     :: Maybe String,
-    listings :: [WeatherForecastListing] }
+    listings :: [WeatherForecastListingXml] }
   deriving (Eq, Show)
 
-
 -- | Database representation of a weather forecast.
 --
 data WeatherForecast =
   WeatherForecast {
+    db_weather_id :: DefaultKey Weather,
     db_game_date :: UTCTime,
     db_league_name :: Maybe String }
 
@@ -114,25 +132,29 @@ data WeatherForecastXml =
     xml_league :: WeatherLeague }
   deriving (Eq, Show)
 
-
 instance ToDb WeatherForecastXml where
   -- | The database representation of a 'WeatherForecastXml' is a
   --   'WeatherForecast'.
   --
   type Db WeatherForecastXml = WeatherForecast
 
-instance FromXml WeatherForecastXml where
+instance FromXmlFk WeatherForecastXml where
+  type Parent WeatherForecastXml = Weather
+
   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
   --   replace the 'WeatherLeague' with its name.
   --
-  from_xml WeatherForecastXml{..} =
-    WeatherForecast { db_game_date   = xml_game_date,
-                      db_league_name = (league_name xml_league) }
+  from_xml_fk fk WeatherForecastXml{..} =
+    WeatherForecast {
+      db_weather_id  = fk,
+      db_game_date   = xml_game_date,
+      db_league_name = (league_name xml_league) }
+
 
 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 --   without first converting it to the database representation.
 --
-instance XmlImport WeatherForecastXml
+instance XmlImportFk WeatherForecastXml
 
 
 -- | The database representation of a weather message.
@@ -158,7 +180,6 @@ data Message =
     xml_time_stamp :: UTCTime }
   deriving (Eq, Show)
 
-
 instance ToDb Message where
   -- | The database representation of 'Message' is 'Weather'.
   --
@@ -181,22 +202,6 @@ instance FromXml Message where
 instance XmlImport Message
 
 
--- | A mapping between 'Weather' objects and their children
---   'WeatherForecast's.
---
-data Weather_WeatherForecast =
-  Weather_WeatherForecast
-    (DefaultKey Weather)
-    (DefaultKey WeatherForecast)
-
--- | A mapping between 'WeatherForecast' objects and their children
---   'WeatherForecastListing's.
---
-data WeatherForecast_WeatherForecastListing =
-  WeatherForecast_WeatherForecastListing
-    (DefaultKey WeatherForecast)
-    (DefaultKey WeatherForecastListing)
-
 mkPersist tsn_codegen_config [groundhog|
 - entity: Weather
   constructors:
@@ -209,32 +214,22 @@ mkPersist tsn_codegen_config [groundhog|
 
 - entity: WeatherForecast
   dbName: weather_forecasts
-
-- entity: WeatherForecastListing
-  dbName: weather_forecast_listings
-
-- entity: Weather_WeatherForecast
-  dbName: weather__weather_forecasts
   constructors:
-    - name: Weather_WeatherForecast
+    - name: WeatherForecast
       fields:
-        - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
-          dbName: weather_id
-        - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
-          dbName: weather_forecasts_id
+        - name: db_weather_id
+          reference:
+            onDelete: cascade
 
-- entity: WeatherForecast_WeatherForecastListing
-  dbName: weather_forecasts__weather_forecast_listings
+- entity: WeatherForecastListing
+  dbName: weather_forecast_listings
   constructors:
-    - name: WeatherForecast_WeatherForecastListing
+    - name: WeatherForecastListing
       fields:
-        # Default by mkNormalFieldName
-        - name: weatherForecast_WeatherForecastListing0
-          dbName: weather_forecasts_id
+        - name: db_weather_forecasts_id
+          reference:
+            onDelete: cascade
 
-         # Default by mkNormalFieldName
-        - name: weatherForecast_WeatherForecastListing1
-          dbName: weather_forecast_listings_id
 |]
 
 
@@ -244,8 +239,6 @@ instance DbImport Message where
       migrate (undefined :: Weather)
       migrate (undefined :: WeatherForecast)
       migrate (undefined :: WeatherForecastListing)
-      migrate (undefined :: Weather_WeatherForecast)
-      migrate (undefined :: WeatherForecast_WeatherForecastListing)
 
   dbimport m = do
     -- The weather database schema has a nice linear structure. First
@@ -254,25 +247,18 @@ instance DbImport Message where
 
     -- Next insert all of the forecasts, one at a time.
     forM_ (xml_forecasts m) $ \forecast -> do
-      forecast_id <- insert_xml forecast
-
-      -- Map this forecast to its parent weather record.
-      insert_ (Weather_WeatherForecast weather_id forecast_id)
+      forecast_id <- insert_xml_fk weather_id forecast
 
       -- Insert all of this forecast's listings.
-      forM_ (listings $ xml_league forecast) $ \listing -> do
-        listing_id <- insert_xml listing
-
-        -- Map this listing to its parent forecast.
-        insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
+      mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
 
     return ImportSucceeded
 
 
 
--- | Pickler to convert a 'WeatherForecastListing' to/from XML.
+-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 --
-pickle_listing :: PU WeatherForecastListing
+pickle_listing :: PU WeatherForecastListingXml
 pickle_listing =
   xpElem "listing" $
     xpWrap (from_pair, to_pair) $
@@ -280,8 +266,8 @@ pickle_listing =
         (xpElem "teams" xpText)
         (xpElem "weather" xpText)
   where
-    from_pair = uncurry WeatherForecastListing
-    to_pair WeatherForecastListing{..} = (db_teams, db_weather)
+    from_pair = uncurry WeatherForecastListingXml
+    to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 
 
 -- | Pickler to convert a 'WeatherLeague' to/from XML.