From 72d597df08493474acd291dcc8b43409c686b3c4 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Wed, 15 Jan 2014 01:09:58 -0500 Subject: [PATCH] Add the TSN.XML.Weather module (passing pickle/unpickle tests). --- src/Main.hs | 1 + src/TSN/XML/Weather.hs | 228 +++++++++++++++++++++++++++++++++++++++++ test/TestSuite.hs | 4 +- 3 files changed, 232 insertions(+), 1 deletion(-) create mode 100644 src/TSN/XML/Weather.hs diff --git a/src/Main.hs b/src/Main.hs index 6c8223d..10b1ace 100644 --- 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 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 9298bac..d06efa3 100644 --- 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 -- 2.43.2