X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=f3b60af69c7fb52e013bdab5d5b11d2d6d21b24d;hb=0ddc996d5622f138953ad027cc425713a276b46a;hp=4cbfb479002ffde908ac22f67f7728e642245f13;hpb=72d597df08493474acd291dcc8b43409c686b3c4;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 4cbfb47..f3b60af 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -14,17 +14,21 @@ module TSN.XML.Weather (
   -- * Tests
   weather_tests,
   -- * WARNING: these are private but exported to silence warnings
+  Weather_WeatherForecastConstructor(..),
   WeatherConstructor(..),
+  WeatherForecast_WeatherForecastListingConstructor(..),
   WeatherForecastConstructor(..),
-  WeatherListingConstructor(..) )
+  WeatherForecastListingConstructor(..) )
 where
 
 -- System imports.
+import Control.Monad ( forM_ )
+import Data.Time ( UTCTime )
 import Data.Tuple.Curry ( uncurryN )
---import Database.Groundhog (
---  insert_,
---  migrate )
---import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog (
+  insert_,
+  migrate )
+import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
@@ -45,60 +49,99 @@ import Text.XML.HXT.Core (
 -- Local imports.
 import TSN.Codegen (
   tsn_codegen_config )
-import TSN.DbImport ( DbImport(..) )
+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 )
 
 
-data WeatherListing =
-  WeatherListing {
+
+-- | Database/XML representation of a weather forecast listing.
+--
+data WeatherForecastListing =
+  WeatherForecastListing {
     db_teams :: String,
     db_weather :: String }
   deriving (Eq, Show)
 
-instance FromXml WeatherListing where
-  type Db WeatherListing = WeatherListing
+-- | 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'.
+--
+instance FromXml WeatherForecastListing where
   from_xml = id
 
-instance XmlImport WeatherListing
+-- | Allows us to call 'insert_xml' on the XML representation of
+--   WeatherForecastListing.
+--
+instance XmlImport WeatherForecastListing
 
 
+-- | XML representation of a league, as they appear in the weather
+--   documents. There is no associated database representation because
+--   the league element really adds no information besides its own
+--   (usually empty) name. Since there's exactly one league per
+--   forecast, we just store the league_name in the database
+--   representation of a forecast.
+--
 data WeatherLeague =
   WeatherLeague {
     league_name     :: Maybe String,
-    listings :: [WeatherListing] }
+    listings :: [WeatherForecastListing] }
   deriving (Eq, Show)
 
+
+-- | Database representation of a weather forecast.
+--
 data WeatherForecast =
   WeatherForecast {
-    db_game_date :: String, -- ^ This is a 'String' instead of 'UTCTime'
-                            --   because they don't use a standard
-                            --   time format for the day of the month.
+    db_game_date :: UTCTime,
     db_league_name :: Maybe String }
 
+-- | XML representation of a weather forecast. It would have been
+--   cleaner to omit the 'WeatherLeague' middleman, but having it
+--   simplifies parsing.
+--
 data WeatherForecastXml =
   WeatherForecastXml {
-    xml_game_date :: String,  -- ^ This is a 'String' instead of 'UTCTime'
-                              --   because they don't use a standard
-                              --   time format for the day of the month.
+    xml_game_date :: UTCTime,
     xml_league :: WeatherLeague }
   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.
+  --
   from_xml WeatherForecastXml{..} =
     WeatherForecast { 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
 
 
+-- | The database representation of a weather message.
+--
 data Weather =
   Weather {
     db_sport :: String,
     db_title :: String }
 
+
+-- | The XML representation of a weather message.
+--
 data Message =
   Message {
     xml_xml_file_id :: Int,
@@ -110,34 +153,112 @@ data Message =
     xml_time_stamp :: String }
   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.
+  --
   from_xml Message{..} =
     Weather {
       db_sport = xml_sport,
       db_title = xml_title }
 
+-- | This allows us to call 'insert_xml' on a 'Message' without first
+--   converting it to the database representation.
+--
 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
 
-- entity: WeatherListing
-  dbName: weather_listings
-
 - entity: WeatherForecast
   dbName: weather_forecasts
 
+- entity: WeatherForecastListing
+  dbName: weather_forecast_listings
+
+- entity: Weather_WeatherForecast
+  dbName: weather__weather_forecasts
+  constructors:
+    - name: Weather_WeatherForecast
+      fields:
+        - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
+          dbName: weather_id
+        - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
+          dbName: weather_forecasts_id
+
+- entity: WeatherForecast_WeatherForecastListing
+  dbName: weather_forecasts__weather_forecast_listings
+  constructors:
+    - name: WeatherForecast_WeatherForecastListing
+      fields:
+        # Default by mkNormalFieldName
+        - name: weatherForecast_WeatherForecastListing0
+          dbName: weather_forecasts_id
+
+         # Default by mkNormalFieldName
+        - name: weatherForecast_WeatherForecastListing1
+          dbName: weather_forecast_listings_id
 |]
 
 
 instance DbImport Message where
-  dbmigrate = undefined
-  dbimport  = undefined
+  dbmigrate _ =
+    run_dbmigrate $ do
+      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
+    -- we insert the top-level weather record.
+    weather_id <- insert_xml m
+
+    -- 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)
+
+      -- 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
 
+    return ImportSucceeded
 
-pickle_listing :: PU WeatherListing
+
+
+-- | Pickler to convert a 'WeatherForecastListing' to/from XML.
+--
+pickle_listing :: PU WeatherForecastListing
 pickle_listing =
   xpElem "listing" $
     xpWrap (from_pair, to_pair) $
@@ -145,9 +266,12 @@ pickle_listing =
         (xpElem "teams" xpText)
         (xpElem "weather" xpText)
   where
-    from_pair = uncurry WeatherListing
-    to_pair WeatherListing{..} = (db_teams, db_weather)
+    from_pair = uncurry WeatherForecastListing
+    to_pair WeatherForecastListing{..} = (db_teams, db_weather)
 
+
+-- | Pickler to convert a 'WeatherLeague' to/from XML.
+--
 pickle_league :: PU WeatherLeague
 pickle_league =
   xpElem "league" $
@@ -159,18 +283,25 @@ pickle_league =
     from_pair = uncurry WeatherLeague
     to_pair WeatherLeague{..} = (league_name, listings)
 
+
+-- | Pickler to convert a 'WeatherForecastXml' to/from XML.
+--
 pickle_forecast :: PU WeatherForecastXml
 pickle_forecast =
   xpElem "forecast" $
     xpWrap (from_pair, to_pair) $
       xpPair
-        (xpAttr "gamedate" xpText)
+        (xpAttr "gamedate" xp_gamedate)
         pickle_league
   where
     from_pair = uncurry WeatherForecastXml
     to_pair WeatherForecastXml{..} = (xml_game_date,
                                       xml_league)
 
+
+
+-- | Pickler to convert a 'Message' to/from XML.
+--
 pickle_message :: PU Message
 pickle_message =
   xpElem "message" $