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 WeatherForecastListingConstructor(..) )
23 import Control.Monad ( forM_ )
24 import Data.Time ( UTCTime )
25 import Data.Tuple.Curry ( uncurryN )
26 import Database.Groundhog ( migrate )
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(..), ImportResult(..), run_dbmigrate )
49 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
50 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
63 -- * WeatherForecastListing/WeatherForecastListingXml
65 -- | XML representation of a weather forecast listing.
67 data WeatherForecastListingXml =
68 WeatherForecastListingXml {
70 xml_weather :: String }
73 -- | Database representation of a weather forecast listing.
75 data WeatherForecastListing =
76 WeatherForecastListing {
77 db_weather_forecasts_id :: DefaultKey WeatherForecast,
79 db_weather :: String }
82 -- | The database analogue of a 'WeatherForecastListingXml' is
83 -- 'WeatherForecastListing'.
85 instance ToDb WeatherForecastListingXml where
86 type Db WeatherForecastListingXml = WeatherForecastListing
88 -- | This is needed to define the 'XmlImportFk' instance for
89 -- 'WeatherForecastListing'.
91 instance FromXmlFk WeatherForecastListingXml where
92 -- | Each 'WeatherForecastListingXml' is contained in a
95 type Parent WeatherForecastListingXml = WeatherForecast
97 from_xml_fk fk WeatherForecastListingXml{..} =
98 WeatherForecastListing {
99 db_weather_forecasts_id = fk,
100 db_teams = xml_teams,
101 db_weather = xml_weather }
103 -- | This allows us to insert the XML representation
104 -- 'WeatherForecastListingXml' directly.
106 instance XmlImportFk WeatherForecastListingXml
111 -- | XML representation of a league, as they appear in the weather
112 -- documents. There is no associated database representation because
113 -- the league element really adds no information besides its own
114 -- (usually empty) name. Since there's exactly one league per
115 -- forecast, we just store the league_name in the database
116 -- representation of a forecast.
120 league_name :: Maybe String,
121 listings :: [WeatherForecastListingXml] }
125 -- * WeatherForecast/WeatherForecastXml
127 -- | Database representation of a weather forecast.
129 data WeatherForecast =
131 db_weather_id :: DefaultKey Weather,
132 db_game_date :: UTCTime,
133 db_league_name :: Maybe String }
135 -- | XML representation of a weather forecast. It would have been
136 -- cleaner to omit the 'WeatherLeague' middleman, but having it
137 -- simplifies parsing.
139 data WeatherForecastXml =
141 xml_game_date :: UTCTime,
142 xml_league :: WeatherLeague }
145 instance ToDb WeatherForecastXml where
146 -- | The database representation of a 'WeatherForecastXml' is a
147 -- 'WeatherForecast'.
149 type Db WeatherForecastXml = WeatherForecast
151 instance FromXmlFk WeatherForecastXml where
152 type Parent WeatherForecastXml = Weather
154 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
155 -- replace the 'WeatherLeague' with its name.
157 from_xml_fk fk WeatherForecastXml{..} =
160 db_game_date = xml_game_date,
161 db_league_name = (league_name xml_league) }
164 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
165 -- without first converting it to the database representation.
167 instance XmlImportFk WeatherForecastXml
172 -- | The database representation of a weather message.
176 db_xml_file_id :: Int,
179 db_time_stamp :: UTCTime }
182 -- | The XML representation of a weather message.
186 xml_xml_file_id :: Int,
187 xml_heading :: String,
188 xml_category :: String,
191 xml_forecasts :: [WeatherForecastXml],
192 xml_time_stamp :: UTCTime }
195 instance ToDb Message where
196 -- | The database representation of 'Message' is 'Weather'.
198 type Db Message = Weather
200 instance FromXml Message where
201 -- | To get a 'Weather' from a 'Message', we drop a bunch of
204 from_xml Message{..} =
206 db_xml_file_id = xml_xml_file_id,
207 db_sport = xml_sport,
208 db_title = xml_title,
209 db_time_stamp = xml_time_stamp }
211 -- | This allows us to insert the XML representation 'Message'
214 instance XmlImport Message
221 mkPersist tsn_codegen_config [groundhog|
226 - name: unique_weather
228 # Prevent multiple imports of the same message.
229 fields: [db_xml_file_id]
231 - entity: WeatherForecast
232 dbName: weather_forecasts
234 - name: WeatherForecast
236 - name: db_weather_id
240 - entity: WeatherForecastListing
241 dbName: weather_forecast_listings
243 - name: WeatherForecastListing
245 - name: db_weather_forecasts_id
252 instance DbImport Message where
255 migrate (undefined :: Weather)
256 migrate (undefined :: WeatherForecast)
257 migrate (undefined :: WeatherForecastListing)
260 -- The weather database schema has a nice linear structure. First
261 -- we insert the top-level weather record.
262 weather_id <- insert_xml m
264 -- Next insert all of the forecasts, one at a time.
265 forM_ (xml_forecasts m) $ \forecast -> do
266 forecast_id <- insert_xml_fk weather_id forecast
268 -- Insert all of this forecast's listings.
269 mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
271 return ImportSucceeded
278 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
280 pickle_listing :: PU WeatherForecastListingXml
283 xpWrap (from_pair, to_pair) $
285 (xpElem "teams" xpText)
286 (xpElem "weather" xpText)
288 from_pair = uncurry WeatherForecastListingXml
289 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
292 -- | Pickler to convert a 'WeatherLeague' to/from XML.
294 pickle_league :: PU WeatherLeague
297 xpWrap (from_pair, to_pair) $
299 (xpAttr "name" $ xpOption xpText)
300 (xpList pickle_listing)
302 from_pair = uncurry WeatherLeague
303 to_pair WeatherLeague{..} = (league_name, listings)
306 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
308 pickle_forecast :: PU WeatherForecastXml
311 xpWrap (from_pair, to_pair) $
313 (xpAttr "gamedate" xp_gamedate)
316 from_pair = uncurry WeatherForecastXml
317 to_pair WeatherForecastXml{..} = (xml_game_date,
322 -- | Pickler to convert a 'Message' to/from XML.
324 pickle_message :: PU Message
327 xpWrap (from_tuple, to_tuple) $
329 (xpElem "XML_File_ID" xpInt)
330 (xpElem "heading" xpText)
331 (xpElem "category" xpText)
332 (xpElem "sport" xpText)
333 (xpElem "title" xpText)
334 (xpList pickle_forecast)
335 (xpElem "time_stamp" xp_time_stamp)
337 from_tuple = uncurryN Message
338 to_tuple Message{..} = (xml_xml_file_id,
350 weather_tests :: TestTree
354 [ test_pickle_of_unpickle_is_identity,
355 test_unpickle_succeeds ]
358 -- | If we unpickle something and then pickle it, we should wind up
359 -- with the same thing we started with. WARNING: success of this
360 -- test does not mean that unpickling succeeded.
362 test_pickle_of_unpickle_is_identity :: TestTree
363 test_pickle_of_unpickle_is_identity =
364 testCase "pickle composed with unpickle is the identity" $ do
365 let path = "test/xml/weatherxml.xml"
366 (expected, actual) <- pickle_unpickle pickle_message path
370 -- | Make sure we can actually unpickle these things.
372 test_unpickle_succeeds :: TestTree
373 test_unpickle_succeeds =
374 testCase "unpickling succeeds" $ do
375 let path = "test/xml/weatherxml.xml"
376 actual <- unpickleable path pickle_message