Minimal undocumented implementation of TSN.XML.Weather.

Add weatherxml.dtd support to Main.

diff --git a/src/Main.hs b/src/Main.hs
index 10b1acecd0382cba9660198c2d07368ad353eef1..663c51ce0ea206b649ad1565659eeca180b521c2 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -172,6 +172,11 @@ import_file cfg path = do
                 let errmsg = "Could not unpickle Odds_XML."
                 maybe (return $ ImportFailed errmsg) migrate_and_import m
 
+            | dtd == "weatherxml.dtd" = do
+                let m = unpickleDoc Weather.pickle_message xml
+                let errmsg = "Could not unpickle weatherxml."
+                maybe (return $ ImportFailed errmsg) migrate_and_import m
+
             | otherwise = do
               let infomsg =
                     "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 4cbfb479002ffde908ac22f67f7728e642245f13..092cc7e54aff76c278a5313d43928381b5f37063 100644 (file)
--- 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,42 +49,39 @@ 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 )
 
 
-data WeatherListing =
-  WeatherListing {
+data WeatherForecastListing =
+  WeatherForecastListing {
     db_teams :: String,
     db_weather :: String }
   deriving (Eq, Show)
 
-instance FromXml WeatherListing where
-  type Db WeatherListing = WeatherListing
+instance FromXml WeatherForecastListing where
+  type Db WeatherForecastListing = WeatherForecastListing
   from_xml = id
 
-instance XmlImport WeatherListing
+instance XmlImport WeatherForecastListing
 
 
 data WeatherLeague =
   WeatherLeague {
     league_name     :: Maybe String,
-    listings :: [WeatherListing] }
+    listings :: [WeatherForecastListing] }
   deriving (Eq, Show)
 
 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 }
 
 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)
 
@@ -120,24 +121,73 @@ instance FromXml Message where
 instance XmlImport Message
 
 
+data Weather_WeatherForecast =
+  Weather_WeatherForecast
+    (DefaultKey Weather)
+    (DefaultKey WeatherForecast)
+
+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
+    weather_id <- insert_xml m
+
+    forM_ (xml_forecasts m) $ \forecast -> do
+      forecast_id <- insert_xml forecast
+      insert_ (Weather_WeatherForecast weather_id forecast_id)
+      forM_ (listings $ xml_league forecast) $ \listing -> do
+        listing_id <- insert_xml listing
+        insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
+
+    return ImportSucceeded
 
 
-pickle_listing :: PU WeatherListing
+pickle_listing :: PU WeatherForecastListing
 pickle_listing =
   xpElem "listing" $
     xpWrap (from_pair, to_pair) $
@@ -145,8 +195,8 @@ 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)
 
 pickle_league :: PU WeatherLeague
 pickle_league =
@@ -164,7 +214,7 @@ pickle_forecast =
   xpElem "forecast" $
     xpWrap (from_pair, to_pair) $
       xpPair
-        (xpAttr "gamedate" xpText)
+        (xpAttr "gamedate" xp_gamedate)
         pickle_league
   where
     from_pair = uncurry WeatherForecastXml