Add the TSN.XML.Weather module (passing pickle/unpickle tests).

diff --git a/src/Main.hs b/src/Main.hs
index 6c8223db5628b397405eaeeaec454e571e8ceac8..10b1acecd0382cba9660198c2d07368ad353eef1 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -50,6 +50,7 @@ import qualified TSN.XML.Injuries as Injuries ( pickle_message )
 import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( pickle_message )
 import qualified TSN.XML.News as News ( pickle_message )
 import qualified TSN.XML.Odds as Odds ( pickle_message )
+import qualified TSN.XML.Weather as Weather ( pickle_message )
 import Xml ( DtdName(..), parse_opts )
 
 

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
new file mode 100644 (file)
index 0000000..4cbfb47
--- /dev/null
+++ b/src/TSN/XML/Weather.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# 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.
+--
+module TSN.XML.Weather (
+  pickle_message,
+  -- * Tests
+  weather_tests,
+  -- * WARNING: these are private but exported to silence warnings
+  WeatherConstructor(..),
+  WeatherForecastConstructor(..),
+  WeatherListingConstructor(..) )
+where
+
+-- System imports.
+import Data.Tuple.Curry ( uncurryN )
+--import Database.Groundhog (
+--  insert_,
+--  migrate )
+--import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.TH (
+  groundhog,
+  mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+  PU,
+  xp7Tuple,
+  xpAttr,
+  xpElem,
+  xpInt,
+  xpList,
+  xpOption,
+  xpPair,
+  xpText,
+  xpWrap )
+
+-- Local imports.
+import TSN.Codegen (
+  tsn_codegen_config )
+import TSN.DbImport ( DbImport(..) )
+import TSN.XmlImport ( XmlImport(..) )
+import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+
+
+data WeatherListing =
+  WeatherListing {
+    db_teams :: String,
+    db_weather :: String }
+  deriving (Eq, Show)
+
+instance FromXml WeatherListing where
+  type Db WeatherListing = WeatherListing
+  from_xml = id
+
+instance XmlImport WeatherListing
+
+
+data WeatherLeague =
+  WeatherLeague {
+    league_name     :: Maybe String,
+    listings :: [WeatherListing] }
+  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_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_league :: WeatherLeague }
+  deriving (Eq, Show)
+
+
+instance FromXml WeatherForecastXml where
+  type Db WeatherForecastXml = WeatherForecast
+  from_xml WeatherForecastXml{..} =
+    WeatherForecast { db_game_date   = xml_game_date,
+                      db_league_name = (league_name xml_league) }
+
+instance XmlImport WeatherForecastXml
+
+
+data Weather =
+  Weather {
+    db_sport :: String,
+    db_title :: String }
+
+data Message =
+  Message {
+    xml_xml_file_id :: Int,
+    xml_heading :: String,
+    xml_category :: String,
+    xml_sport :: String,
+    xml_title :: String,
+    xml_forecasts :: [WeatherForecastXml],
+    xml_time_stamp :: String }
+  deriving (Eq, Show)
+
+instance FromXml Message where
+  type Db Message = Weather
+  from_xml Message{..} =
+    Weather {
+      db_sport = xml_sport,
+      db_title = xml_title }
+
+instance XmlImport Message
+
+
+mkPersist tsn_codegen_config [groundhog|
+- entity: Weather
+
+- entity: WeatherListing
+  dbName: weather_listings
+
+- entity: WeatherForecast
+  dbName: weather_forecasts
+
+|]
+
+
+instance DbImport Message where
+  dbmigrate = undefined
+  dbimport  = undefined
+
+
+pickle_listing :: PU WeatherListing
+pickle_listing =
+  xpElem "listing" $
+    xpWrap (from_pair, to_pair) $
+      xpPair
+        (xpElem "teams" xpText)
+        (xpElem "weather" xpText)
+  where
+    from_pair = uncurry WeatherListing
+    to_pair WeatherListing{..} = (db_teams, db_weather)
+
+pickle_league :: PU WeatherLeague
+pickle_league =
+  xpElem "league" $
+    xpWrap (from_pair, to_pair) $
+      xpPair
+        (xpAttr "name" $ xpOption xpText)
+        (xpList pickle_listing)
+  where
+    from_pair = uncurry WeatherLeague
+    to_pair WeatherLeague{..} = (league_name, listings)
+
+pickle_forecast :: PU WeatherForecastXml
+pickle_forecast =
+  xpElem "forecast" $
+    xpWrap (from_pair, to_pair) $
+      xpPair
+        (xpAttr "gamedate" xpText)
+        pickle_league
+  where
+    from_pair = uncurry WeatherForecastXml
+    to_pair WeatherForecastXml{..} = (xml_game_date,
+                                      xml_league)
+
+pickle_message :: PU Message
+pickle_message =
+  xpElem "message" $
+    xpWrap (from_tuple, to_tuple) $
+      xp7Tuple
+        (xpElem "XML_File_ID" xpInt)
+        (xpElem "heading" xpText)
+        (xpElem "category" xpText)
+        (xpElem "sport" xpText)
+        (xpElem "title" xpText)
+        (xpList pickle_forecast)
+        (xpElem "time_stamp" xpText)
+  where
+    from_tuple = uncurryN Message
+    to_tuple Message{..} = (xml_xml_file_id,
+                            xml_heading,
+                            xml_category,
+                            xml_sport,
+                            xml_title,
+                            xml_forecasts,
+                            xml_time_stamp)
+
+--
+-- Tasty tests
+--
+
+weather_tests :: TestTree
+weather_tests =
+  testGroup
+    "Weather tests"
+    [ test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
+
+
+-- | If we unpickle something and then pickle it, we should wind up
+--   with the same thing we started with. WARNING: success of this
+--   test does not mean that unpickling succeeded.
+--
+test_pickle_of_unpickle_is_identity :: TestTree
+test_pickle_of_unpickle_is_identity =
+  testCase "pickle composed with unpickle is the identity" $ do
+    let path = "test/xml/weatherxml.xml"
+    (expected, actual) <- pickle_unpickle pickle_message path
+    actual @?= expected
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+  testCase "unpickling succeeds" $ do
+  let path = "test/xml/weatherxml.xml"
+  actual <- unpickleable path pickle_message
+  let expected = True
+  actual @?= expected

diff --git a/test/TestSuite.hs b/test/TestSuite.hs
index 9298bac88f0b3772ee5aa2ef13a4553bc6cdf221..d06efa309c54aa1ffeed18b0920f54d0f428e79d 100644 (file)
--- a/test/TestSuite.hs
+++ b/test/TestSuite.hs
@@ -5,6 +5,7 @@ import TSN.XML.Injuries ( injuries_tests )
 import TSN.XML.InjuriesDetail ( injuries_detail_tests )
 import TSN.XML.News ( news_tests )
 import TSN.XML.Odds ( odds_tests )
+import TSN.XML.Weather ( weather_tests )
 
 tests :: TestTree
 tests = testGroup
@@ -13,7 +14,8 @@ tests = testGroup
             injuries_tests,
             injuries_detail_tests,
             news_tests,
-            odds_tests ]
+            odds_tests,
+            weather_tests ]
 
 main :: IO ()
 main = defaultMain tests