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 -- | XML representation of a weather forecast listing.
65 data WeatherForecastListingXml =
66 WeatherForecastListingXml {
68 xml_weather :: String }
71 -- | Database representation of a weather forecast listing.
73 data WeatherForecastListing =
74 WeatherForecastListing {
75 db_weather_forecasts_id :: DefaultKey WeatherForecast,
77 db_weather :: String }
80 -- | The database analogue of a 'WeatherForecastListingXml' is
81 -- 'WeatherForecastListing'.
83 instance ToDb WeatherForecastListingXml where
84 type Db WeatherForecastListingXml = WeatherForecastListing
86 -- | This is needed to define the XmlImport instance for
87 -- 'WeatherForecastListing'.
89 instance FromXmlFk WeatherForecastListingXml where
90 type Parent WeatherForecastListingXml = WeatherForecast
92 from_xml_fk fk WeatherForecastListingXml{..} =
93 WeatherForecastListing {
94 db_weather_forecasts_id = fk,
96 db_weather = xml_weather }
98 -- | Allows us to call 'insert_xml' on the XML representation of
99 -- WeatherForecastListing.
101 instance XmlImportFk WeatherForecastListingXml
104 -- | XML representation of a league, as they appear in the weather
105 -- documents. There is no associated database representation because
106 -- the league element really adds no information besides its own
107 -- (usually empty) name. Since there's exactly one league per
108 -- forecast, we just store the league_name in the database
109 -- representation of a forecast.
113 league_name :: Maybe String,
114 listings :: [WeatherForecastListingXml] }
117 -- | Database representation of a weather forecast.
119 data WeatherForecast =
121 db_weather_id :: DefaultKey Weather,
122 db_game_date :: UTCTime,
123 db_league_name :: Maybe String }
125 -- | XML representation of a weather forecast. It would have been
126 -- cleaner to omit the 'WeatherLeague' middleman, but having it
127 -- simplifies parsing.
129 data WeatherForecastXml =
131 xml_game_date :: UTCTime,
132 xml_league :: WeatherLeague }
135 instance ToDb WeatherForecastXml where
136 -- | The database representation of a 'WeatherForecastXml' is a
137 -- 'WeatherForecast'.
139 type Db WeatherForecastXml = WeatherForecast
141 instance FromXmlFk WeatherForecastXml where
142 type Parent WeatherForecastXml = Weather
144 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
145 -- replace the 'WeatherLeague' with its name.
147 from_xml_fk fk WeatherForecastXml{..} =
150 db_game_date = xml_game_date,
151 db_league_name = (league_name xml_league) }
154 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
155 -- without first converting it to the database representation.
157 instance XmlImportFk WeatherForecastXml
160 -- | The database representation of a weather message.
164 db_xml_file_id :: Int,
167 db_time_stamp :: UTCTime }
170 -- | The XML representation of a weather message.
174 xml_xml_file_id :: Int,
175 xml_heading :: String,
176 xml_category :: String,
179 xml_forecasts :: [WeatherForecastXml],
180 xml_time_stamp :: UTCTime }
183 instance ToDb Message where
184 -- | The database representation of 'Message' is 'Weather'.
186 type Db Message = Weather
188 instance FromXml Message where
189 -- | To get a 'Weather' from a 'Message', we drop a bunch of
192 from_xml Message{..} =
194 db_xml_file_id = xml_xml_file_id,
195 db_sport = xml_sport,
196 db_title = xml_title,
197 db_time_stamp = xml_time_stamp }
199 -- | This allows us to call 'insert_xml' on a 'Message' without first
200 -- converting it to the database representation.
202 instance XmlImport Message
205 mkPersist tsn_codegen_config [groundhog|
210 - name: unique_weather
212 # Prevent multiple imports of the same message.
213 fields: [db_xml_file_id]
215 - entity: WeatherForecast
216 dbName: weather_forecasts
218 - name: WeatherForecast
220 - name: db_weather_id
224 - entity: WeatherForecastListing
225 dbName: weather_forecast_listings
227 - name: WeatherForecastListing
229 - name: db_weather_forecasts_id
236 instance DbImport Message where
239 migrate (undefined :: Weather)
240 migrate (undefined :: WeatherForecast)
241 migrate (undefined :: WeatherForecastListing)
244 -- The weather database schema has a nice linear structure. First
245 -- we insert the top-level weather record.
246 weather_id <- insert_xml m
248 -- Next insert all of the forecasts, one at a time.
249 forM_ (xml_forecasts m) $ \forecast -> do
250 forecast_id <- insert_xml_fk weather_id forecast
252 -- Insert all of this forecast's listings.
253 mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
255 return ImportSucceeded
259 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
261 pickle_listing :: PU WeatherForecastListingXml
264 xpWrap (from_pair, to_pair) $
266 (xpElem "teams" xpText)
267 (xpElem "weather" xpText)
269 from_pair = uncurry WeatherForecastListingXml
270 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
273 -- | Pickler to convert a 'WeatherLeague' to/from XML.
275 pickle_league :: PU WeatherLeague
278 xpWrap (from_pair, to_pair) $
280 (xpAttr "name" $ xpOption xpText)
281 (xpList pickle_listing)
283 from_pair = uncurry WeatherLeague
284 to_pair WeatherLeague{..} = (league_name, listings)
287 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
289 pickle_forecast :: PU WeatherForecastXml
292 xpWrap (from_pair, to_pair) $
294 (xpAttr "gamedate" xp_gamedate)
297 from_pair = uncurry WeatherForecastXml
298 to_pair WeatherForecastXml{..} = (xml_game_date,
303 -- | Pickler to convert a 'Message' to/from XML.
305 pickle_message :: PU Message
308 xpWrap (from_tuple, to_tuple) $
310 (xpElem "XML_File_ID" xpInt)
311 (xpElem "heading" xpText)
312 (xpElem "category" xpText)
313 (xpElem "sport" xpText)
314 (xpElem "title" xpText)
315 (xpList pickle_forecast)
316 (xpElem "time_stamp" xp_time_stamp)
318 from_tuple = uncurryN Message
319 to_tuple Message{..} = (xml_xml_file_id,
331 weather_tests :: TestTree
335 [ test_pickle_of_unpickle_is_identity,
336 test_unpickle_succeeds ]
339 -- | If we unpickle something and then pickle it, we should wind up
340 -- with the same thing we started with. WARNING: success of this
341 -- test does not mean that unpickling succeeded.
343 test_pickle_of_unpickle_is_identity :: TestTree
344 test_pickle_of_unpickle_is_identity =
345 testCase "pickle composed with unpickle is the identity" $ do
346 let path = "test/xml/weatherxml.xml"
347 (expected, actual) <- pickle_unpickle pickle_message path
351 -- | Make sure we can actually unpickle these things.
353 test_unpickle_succeeds :: TestTree
354 test_unpickle_succeeds =
355 testCase "unpickling succeeds" $ do
356 let path = "test/xml/weatherxml.xml"
357 actual <- unpickleable path pickle_message