X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=6df3ce37615cfa48ba28cc028fb355a90dcbbb1d;hp=be591c10276d76570fa4f29a8fdc34de7cfbd714;hb=b2c39ebe5ff9c1ea3224231df5078c52d0ad8737;hpb=09fb9f7ddc30d003224da3fc45142ce2e37c4cbf

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index be591c1..6df3ce3 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -6,8 +6,8 @@
 {-# LANGUAGE TypeFamilies #-}
 
 -- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
---   contains a bunch of forecasts, which each contain one league, and
---   that league contains a bunch of listings.
+--   contains a bunch of forecasts, which each contain zero or more
+--   leagues, which in turn (each) contain a bunch of listings.
 --
 module TSN.XML.Weather (
   dtd,
@@ -27,6 +27,7 @@ import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog (
   countAll,
   deleteAll,
+  insert_,
   migrate,
   runMigration,
   silentMigrationLogger )
@@ -87,58 +88,50 @@ data WeatherForecastListingXml =
     xml_weather :: String }
   deriving (Eq, Show)
 
--- | Database representation of a weather forecast listing.
+
+-- | Database representation of a weather forecast listing. The
+--   'db_league_name' field should come from the containing \<league\>
+--   element which is not stored in the database.
 --
 data WeatherForecastListing =
   WeatherForecastListing {
     db_weather_forecasts_id :: DefaultKey WeatherForecast,
+    db_league_name :: Maybe String,
     db_teams :: String,
     db_weather :: String }
 
 
--- | The database analogue of a 'WeatherForecastListingXml' is
---   'WeatherForecastListing'.
+-- | We don't make 'WeatherForecastListingXml' an instance of
+--   'FromXmlFk' because it needs some additional information, namely
+--   the league name from its containing \<league\> element.
 --
-instance ToDb WeatherForecastListingXml where
-  type Db WeatherForecastListingXml = WeatherForecastListing
-
-
-instance Child WeatherForecastListingXml where
-  -- | Each 'WeatherForecastListingXml' is contained in a
-  --   'WeatherForecast'.
-  --
-  type Parent WeatherForecastListingXml = WeatherForecast
-
-
--- | This is needed to define the 'XmlImportFk' instance for
---   'WeatherForecastListing'.
+--   When supplied with a forecast id and a league name, this will
+--   turn an XML listing into a database one.
 --
-instance FromXmlFk WeatherForecastListingXml where
-  from_xml_fk fk WeatherForecastListingXml{..} =
+from_xml_fk_league :: DefaultKey WeatherForecast
+                   -> (Maybe String)
+                   -> WeatherForecastListingXml
+                   -> WeatherForecastListing
+from_xml_fk_league fk ln WeatherForecastListingXml{..} =
     WeatherForecastListing {
       db_weather_forecasts_id = fk,
+      db_league_name = ln,
       db_teams = xml_teams,
       db_weather = xml_weather }
 
--- | This allows us to insert the XML representation
---   'WeatherForecastListingXml' directly.
---
-instance XmlImportFk WeatherForecastListingXml
-
 
 -- * WeatherLeague
 
 -- | 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.
+--   (usually empty) name. The leagues contain listings, so we
+--   associate the league name with each listing instead.
 --
 data WeatherLeague =
   WeatherLeague {
-    league_name     :: Maybe String,
-    listings :: [WeatherForecastListingXml] }
+    league_name :: Maybe String,
+    listings    :: [WeatherForecastListingXml] }
   deriving (Eq, Show)
 
 
@@ -149,19 +142,18 @@ data WeatherLeague =
 data WeatherForecast =
   WeatherForecast {
     db_weather_id :: DefaultKey Weather,
-    db_game_date :: UTCTime,
-    db_league_name :: Maybe String }
+    db_game_date :: UTCTime }
+
 
--- | XML representation of a weather forecast. It would have been
---   cleaner to omit the 'WeatherLeague' middleman, but having it
---   simplifies parsing.
+-- | XML representation of a weather forecast.
 --
 data WeatherForecastXml =
   WeatherForecastXml {
     xml_game_date :: UTCTime,
-    xml_league :: WeatherLeague }
+    xml_leagues :: [WeatherLeague] }
   deriving (Eq, Show)
 
+
 instance ToDb WeatherForecastXml where
   -- | The database representation of a 'WeatherForecastXml' is a
   --   'WeatherForecast'.
@@ -178,13 +170,12 @@ instance Child WeatherForecastXml where
 instance FromXmlFk WeatherForecastXml where
 
   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
-  --   replace the 'WeatherLeague' with its name.
+  --   just copy everything verbatim.
   --
   from_xml_fk fk WeatherForecastXml{..} =
     WeatherForecast {
       db_weather_id  = fk,
-      db_game_date   = xml_game_date,
-      db_league_name = (league_name xml_league) }
+      db_game_date   = xml_game_date }
 
 
 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
@@ -283,16 +274,25 @@ instance DbImport Message where
       migrate (undefined :: WeatherForecastListing)
 
   dbimport m = do
-    -- The weather database schema has a nice linear structure. First
-    -- we insert the top-level weather record.
+    -- 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_fk weather_id forecast
 
-      -- Insert all of this forecast's listings.
-      mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
+      -- With the forecast id in hand, loop through this forecast's
+      -- leagues...
+      forM_ (xml_leagues forecast) $ \league -> do
+        -- Construct the function that converts an XML listing to a
+        -- database one.
+        let todb = from_xml_fk_league forecast_id (league_name league)
+
+        -- Now use it to convert all of the XML listings.
+        let db_listings = map todb (listings league)
+
+        -- And finally, insert those DB listings.
+        mapM_ insert_ db_listings
 
     return ImportSucceeded
 
@@ -337,11 +337,11 @@ pickle_forecast =
     xpWrap (from_pair, to_pair) $
       xpPair
         (xpAttr "gamedate" xp_gamedate)
-        pickle_league
+        (xpList pickle_league)
   where
     from_pair = uncurry WeatherForecastXml
     to_pair WeatherForecastXml{..} = (xml_game_date,
-                                      xml_league)
+                                      xml_leagues)