1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 -- | Parse TSN XML for the DTD "weatherxml.dtd". Each document
9 -- contains a bunch of forecasts, which each contain one league, and
10 -- that league contains a bunch of listings.
12 module TSN.XML.Weather (
16 -- * WARNING: these are private but exported to silence warnings
17 WeatherConstructor(..),
18 WeatherForecastConstructor(..),
19 WeatherListingConstructor(..) )
23 import Data.Tuple.Curry ( uncurryN )
24 --import Database.Groundhog (
27 --import Database.Groundhog.Core ( DefaultKey )
28 import Database.Groundhog.TH (
31 import Test.Tasty ( TestTree, testGroup )
32 import Test.Tasty.HUnit ( (@?=), testCase )
33 import Text.XML.HXT.Core (
48 import TSN.DbImport ( DbImport(..) )
49 import TSN.XmlImport ( XmlImport(..) )
50 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
56 db_weather :: String }
59 instance FromXml WeatherListing where
60 type Db WeatherListing = WeatherListing
63 instance XmlImport WeatherListing
68 league_name :: Maybe String,
69 listings :: [WeatherListing] }
72 data WeatherForecast =
74 db_game_date :: String, -- ^ This is a 'String' instead of 'UTCTime'
75 -- because they don't use a standard
76 -- time format for the day of the month.
77 db_league_name :: Maybe String }
79 data WeatherForecastXml =
81 xml_game_date :: String, -- ^ This is a 'String' instead of 'UTCTime'
82 -- because they don't use a standard
83 -- time format for the day of the month.
84 xml_league :: WeatherLeague }
88 instance FromXml WeatherForecastXml where
89 type Db WeatherForecastXml = WeatherForecast
90 from_xml WeatherForecastXml{..} =
91 WeatherForecast { db_game_date = xml_game_date,
92 db_league_name = (league_name xml_league) }
94 instance XmlImport WeatherForecastXml
104 xml_xml_file_id :: Int,
105 xml_heading :: String,
106 xml_category :: String,
109 xml_forecasts :: [WeatherForecastXml],
110 xml_time_stamp :: String }
113 instance FromXml Message where
114 type Db Message = Weather
115 from_xml Message{..} =
117 db_sport = xml_sport,
118 db_title = xml_title }
120 instance XmlImport Message
123 mkPersist tsn_codegen_config [groundhog|
126 - entity: WeatherListing
127 dbName: weather_listings
129 - entity: WeatherForecast
130 dbName: weather_forecasts
135 instance DbImport Message where
136 dbmigrate = undefined
140 pickle_listing :: PU WeatherListing
143 xpWrap (from_pair, to_pair) $
145 (xpElem "teams" xpText)
146 (xpElem "weather" xpText)
148 from_pair = uncurry WeatherListing
149 to_pair WeatherListing{..} = (db_teams, db_weather)
151 pickle_league :: PU WeatherLeague
154 xpWrap (from_pair, to_pair) $
156 (xpAttr "name" $ xpOption xpText)
157 (xpList pickle_listing)
159 from_pair = uncurry WeatherLeague
160 to_pair WeatherLeague{..} = (league_name, listings)
162 pickle_forecast :: PU WeatherForecastXml
165 xpWrap (from_pair, to_pair) $
167 (xpAttr "gamedate" xpText)
170 from_pair = uncurry WeatherForecastXml
171 to_pair WeatherForecastXml{..} = (xml_game_date,
174 pickle_message :: PU Message
177 xpWrap (from_tuple, to_tuple) $
179 (xpElem "XML_File_ID" xpInt)
180 (xpElem "heading" xpText)
181 (xpElem "category" xpText)
182 (xpElem "sport" xpText)
183 (xpElem "title" xpText)
184 (xpList pickle_forecast)
185 (xpElem "time_stamp" xpText)
187 from_tuple = uncurryN Message
188 to_tuple Message{..} = (xml_xml_file_id,
200 weather_tests :: TestTree
204 [ test_pickle_of_unpickle_is_identity,
205 test_unpickle_succeeds ]
208 -- | If we unpickle something and then pickle it, we should wind up
209 -- with the same thing we started with. WARNING: success of this
210 -- test does not mean that unpickling succeeded.
212 test_pickle_of_unpickle_is_identity :: TestTree
213 test_pickle_of_unpickle_is_identity =
214 testCase "pickle composed with unpickle is the identity" $ do
215 let path = "test/xml/weatherxml.xml"
216 (expected, actual) <- pickle_unpickle pickle_message path
220 -- | Make sure we can actually unpickle these things.
222 test_unpickle_succeeds :: TestTree
223 test_unpickle_succeeds =
224 testCase "unpickling succeeds" $ do
225 let path = "test/xml/weatherxml.xml"
226 actual <- unpickleable path pickle_message