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 Weather_WeatherForecastConstructor(..),
18 WeatherConstructor(..),
19 WeatherForecast_WeatherForecastListingConstructor(..),
20 WeatherForecastConstructor(..),
21 WeatherForecastListingConstructor(..) )
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime )
27 import Data.Tuple.Curry ( uncurryN )
28 import Database.Groundhog (
31 import Database.Groundhog.Core ( DefaultKey )
32 import Database.Groundhog.TH (
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
53 import TSN.Picklers ( xp_gamedate )
54 import TSN.XmlImport ( XmlImport(..) )
55 import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
59 -- | Database/XML representation of a weather forecast listing.
61 data WeatherForecastListing =
62 WeatherForecastListing {
64 db_weather :: String }
67 -- | The database analogue of a 'WeatherForecastListing' is itself.
68 instance ToDb WeatherForecastListing where
69 type Db WeatherForecastListing = WeatherForecastListing
71 -- | This is needed to define the XmlImport instance for
72 -- 'WeatherForecastListing'.
74 instance FromXml WeatherForecastListing where
77 -- | Allows us to call 'insert_xml' on the XML representation of
78 -- WeatherForecastListing.
80 instance XmlImport WeatherForecastListing
83 -- | XML representation of a league, as they appear in the weather
84 -- documents. There is no associated database representation because
85 -- the league element really adds no information besides its own
86 -- (usually empty) name. Since there's exactly one league per
87 -- forecast, we just store the league_name in the database
88 -- representation of a forecast.
92 league_name :: Maybe String,
93 listings :: [WeatherForecastListing] }
97 -- | Database representation of a weather forecast.
99 data WeatherForecast =
101 db_game_date :: UTCTime,
102 db_league_name :: Maybe String }
104 -- | XML representation of a weather forecast. It would have been
105 -- cleaner to omit the 'WeatherLeague' middleman, but having it
106 -- simplifies parsing.
108 data WeatherForecastXml =
110 xml_game_date :: UTCTime,
111 xml_league :: WeatherLeague }
115 instance ToDb WeatherForecastXml where
116 -- | The database representation of a 'WeatherForecastXml' is a
117 -- 'WeatherForecast'.
119 type Db WeatherForecastXml = WeatherForecast
121 instance FromXml WeatherForecastXml where
122 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
123 -- replace the 'WeatherLeague' with its name.
125 from_xml WeatherForecastXml{..} =
126 WeatherForecast { db_game_date = xml_game_date,
127 db_league_name = (league_name xml_league) }
129 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
130 -- without first converting it to the database representation.
132 instance XmlImport WeatherForecastXml
135 -- | The database representation of a weather message.
143 -- | The XML representation of a weather message.
147 xml_xml_file_id :: Int,
148 xml_heading :: String,
149 xml_category :: String,
152 xml_forecasts :: [WeatherForecastXml],
153 xml_time_stamp :: String }
157 instance ToDb Message where
158 -- | The database representation of 'Message' is 'Weather'.
160 type Db Message = Weather
162 instance FromXml Message where
163 -- | To get a 'Weather' from a 'Message', we drop a bunch of
166 from_xml Message{..} =
168 db_sport = xml_sport,
169 db_title = xml_title }
171 -- | This allows us to call 'insert_xml' on a 'Message' without first
172 -- converting it to the database representation.
174 instance XmlImport Message
177 -- | A mapping between 'Weather' objects and their children
178 -- 'WeatherForecast's.
180 data Weather_WeatherForecast =
181 Weather_WeatherForecast
183 (DefaultKey WeatherForecast)
185 -- | A mapping between 'WeatherForecast' objects and their children
186 -- 'WeatherForecastListing's.
188 data WeatherForecast_WeatherForecastListing =
189 WeatherForecast_WeatherForecastListing
190 (DefaultKey WeatherForecast)
191 (DefaultKey WeatherForecastListing)
193 mkPersist tsn_codegen_config [groundhog|
196 - entity: WeatherForecast
197 dbName: weather_forecasts
199 - entity: WeatherForecastListing
200 dbName: weather_forecast_listings
202 - entity: Weather_WeatherForecast
203 dbName: weather__weather_forecasts
205 - name: Weather_WeatherForecast
207 - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
209 - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
210 dbName: weather_forecasts_id
212 - entity: WeatherForecast_WeatherForecastListing
213 dbName: weather_forecasts__weather_forecast_listings
215 - name: WeatherForecast_WeatherForecastListing
217 # Default by mkNormalFieldName
218 - name: weatherForecast_WeatherForecastListing0
219 dbName: weather_forecasts_id
221 # Default by mkNormalFieldName
222 - name: weatherForecast_WeatherForecastListing1
223 dbName: weather_forecast_listings_id
227 instance DbImport Message where
230 migrate (undefined :: Weather)
231 migrate (undefined :: WeatherForecast)
232 migrate (undefined :: WeatherForecastListing)
233 migrate (undefined :: Weather_WeatherForecast)
234 migrate (undefined :: WeatherForecast_WeatherForecastListing)
237 -- The weather database schema has a nice linear structure. First
238 -- we insert the top-level weather record.
239 weather_id <- insert_xml m
241 -- Next insert all of the forecasts, one at a time.
242 forM_ (xml_forecasts m) $ \forecast -> do
243 forecast_id <- insert_xml forecast
245 -- Map this forecast to its parent weather record.
246 insert_ (Weather_WeatherForecast weather_id forecast_id)
248 -- Insert all of this forecast's listings.
249 forM_ (listings $ xml_league forecast) $ \listing -> do
250 listing_id <- insert_xml listing
252 -- Map this listing to its parent forecast.
253 insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
255 return ImportSucceeded
259 -- | Pickler to convert a 'WeatherForecastListing' to/from XML.
261 pickle_listing :: PU WeatherForecastListing
264 xpWrap (from_pair, to_pair) $
266 (xpElem "teams" xpText)
267 (xpElem "weather" xpText)
269 from_pair = uncurry WeatherForecastListing
270 to_pair WeatherForecastListing{..} = (db_teams, db_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" xpText)
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