]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/Weather.hs
f3b60af69c7fb52e013bdab5d5b11d2d6d21b24d
[dead/htsn-import.git] / src / TSN / XML / Weather.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7
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.
11 --
12 module TSN.XML.Weather (
13 pickle_message,
14 -- * Tests
15 weather_tests,
16 -- * WARNING: these are private but exported to silence warnings
17 Weather_WeatherForecastConstructor(..),
18 WeatherConstructor(..),
19 WeatherForecast_WeatherForecastListingConstructor(..),
20 WeatherForecastConstructor(..),
21 WeatherForecastListingConstructor(..) )
22 where
23
24 -- System imports.
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime )
27 import Data.Tuple.Curry ( uncurryN )
28 import Database.Groundhog (
29 insert_,
30 migrate )
31 import Database.Groundhog.Core ( DefaultKey )
32 import Database.Groundhog.TH (
33 groundhog,
34 mkPersist )
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
38 PU,
39 xp7Tuple,
40 xpAttr,
41 xpElem,
42 xpInt,
43 xpList,
44 xpOption,
45 xpPair,
46 xpText,
47 xpWrap )
48
49 -- Local imports.
50 import TSN.Codegen (
51 tsn_codegen_config )
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 )
56
57
58
59 -- | Database/XML representation of a weather forecast listing.
60 --
61 data WeatherForecastListing =
62 WeatherForecastListing {
63 db_teams :: String,
64 db_weather :: String }
65 deriving (Eq, Show)
66
67 -- | The database analogue of a 'WeatherForecastListing' is itself.
68 instance ToDb WeatherForecastListing where
69 type Db WeatherForecastListing = WeatherForecastListing
70
71 -- | This is needed to define the XmlImport instance for
72 -- 'WeatherForecastListing'.
73 --
74 instance FromXml WeatherForecastListing where
75 from_xml = id
76
77 -- | Allows us to call 'insert_xml' on the XML representation of
78 -- WeatherForecastListing.
79 --
80 instance XmlImport WeatherForecastListing
81
82
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.
89 --
90 data WeatherLeague =
91 WeatherLeague {
92 league_name :: Maybe String,
93 listings :: [WeatherForecastListing] }
94 deriving (Eq, Show)
95
96
97 -- | Database representation of a weather forecast.
98 --
99 data WeatherForecast =
100 WeatherForecast {
101 db_game_date :: UTCTime,
102 db_league_name :: Maybe String }
103
104 -- | XML representation of a weather forecast. It would have been
105 -- cleaner to omit the 'WeatherLeague' middleman, but having it
106 -- simplifies parsing.
107 --
108 data WeatherForecastXml =
109 WeatherForecastXml {
110 xml_game_date :: UTCTime,
111 xml_league :: WeatherLeague }
112 deriving (Eq, Show)
113
114
115 instance ToDb WeatherForecastXml where
116 -- | The database representation of a 'WeatherForecastXml' is a
117 -- 'WeatherForecast'.
118 --
119 type Db WeatherForecastXml = WeatherForecast
120
121 instance FromXml WeatherForecastXml where
122 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
123 -- replace the 'WeatherLeague' with its name.
124 --
125 from_xml WeatherForecastXml{..} =
126 WeatherForecast { db_game_date = xml_game_date,
127 db_league_name = (league_name xml_league) }
128
129 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
130 -- without first converting it to the database representation.
131 --
132 instance XmlImport WeatherForecastXml
133
134
135 -- | The database representation of a weather message.
136 --
137 data Weather =
138 Weather {
139 db_sport :: String,
140 db_title :: String }
141
142
143 -- | The XML representation of a weather message.
144 --
145 data Message =
146 Message {
147 xml_xml_file_id :: Int,
148 xml_heading :: String,
149 xml_category :: String,
150 xml_sport :: String,
151 xml_title :: String,
152 xml_forecasts :: [WeatherForecastXml],
153 xml_time_stamp :: String }
154 deriving (Eq, Show)
155
156
157 instance ToDb Message where
158 -- | The database representation of 'Message' is 'Weather'.
159 --
160 type Db Message = Weather
161
162 instance FromXml Message where
163 -- | To get a 'Weather' from a 'Message', we drop a bunch of
164 -- unwanted fields.
165 --
166 from_xml Message{..} =
167 Weather {
168 db_sport = xml_sport,
169 db_title = xml_title }
170
171 -- | This allows us to call 'insert_xml' on a 'Message' without first
172 -- converting it to the database representation.
173 --
174 instance XmlImport Message
175
176
177 -- | A mapping between 'Weather' objects and their children
178 -- 'WeatherForecast's.
179 --
180 data Weather_WeatherForecast =
181 Weather_WeatherForecast
182 (DefaultKey Weather)
183 (DefaultKey WeatherForecast)
184
185 -- | A mapping between 'WeatherForecast' objects and their children
186 -- 'WeatherForecastListing's.
187 --
188 data WeatherForecast_WeatherForecastListing =
189 WeatherForecast_WeatherForecastListing
190 (DefaultKey WeatherForecast)
191 (DefaultKey WeatherForecastListing)
192
193 mkPersist tsn_codegen_config [groundhog|
194 - entity: Weather
195
196 - entity: WeatherForecast
197 dbName: weather_forecasts
198
199 - entity: WeatherForecastListing
200 dbName: weather_forecast_listings
201
202 - entity: Weather_WeatherForecast
203 dbName: weather__weather_forecasts
204 constructors:
205 - name: Weather_WeatherForecast
206 fields:
207 - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
208 dbName: weather_id
209 - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
210 dbName: weather_forecasts_id
211
212 - entity: WeatherForecast_WeatherForecastListing
213 dbName: weather_forecasts__weather_forecast_listings
214 constructors:
215 - name: WeatherForecast_WeatherForecastListing
216 fields:
217 # Default by mkNormalFieldName
218 - name: weatherForecast_WeatherForecastListing0
219 dbName: weather_forecasts_id
220
221 # Default by mkNormalFieldName
222 - name: weatherForecast_WeatherForecastListing1
223 dbName: weather_forecast_listings_id
224 |]
225
226
227 instance DbImport Message where
228 dbmigrate _ =
229 run_dbmigrate $ do
230 migrate (undefined :: Weather)
231 migrate (undefined :: WeatherForecast)
232 migrate (undefined :: WeatherForecastListing)
233 migrate (undefined :: Weather_WeatherForecast)
234 migrate (undefined :: WeatherForecast_WeatherForecastListing)
235
236 dbimport m = do
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
240
241 -- Next insert all of the forecasts, one at a time.
242 forM_ (xml_forecasts m) $ \forecast -> do
243 forecast_id <- insert_xml forecast
244
245 -- Map this forecast to its parent weather record.
246 insert_ (Weather_WeatherForecast weather_id forecast_id)
247
248 -- Insert all of this forecast's listings.
249 forM_ (listings $ xml_league forecast) $ \listing -> do
250 listing_id <- insert_xml listing
251
252 -- Map this listing to its parent forecast.
253 insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
254
255 return ImportSucceeded
256
257
258
259 -- | Pickler to convert a 'WeatherForecastListing' to/from XML.
260 --
261 pickle_listing :: PU WeatherForecastListing
262 pickle_listing =
263 xpElem "listing" $
264 xpWrap (from_pair, to_pair) $
265 xpPair
266 (xpElem "teams" xpText)
267 (xpElem "weather" xpText)
268 where
269 from_pair = uncurry WeatherForecastListing
270 to_pair WeatherForecastListing{..} = (db_teams, db_weather)
271
272
273 -- | Pickler to convert a 'WeatherLeague' to/from XML.
274 --
275 pickle_league :: PU WeatherLeague
276 pickle_league =
277 xpElem "league" $
278 xpWrap (from_pair, to_pair) $
279 xpPair
280 (xpAttr "name" $ xpOption xpText)
281 (xpList pickle_listing)
282 where
283 from_pair = uncurry WeatherLeague
284 to_pair WeatherLeague{..} = (league_name, listings)
285
286
287 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
288 --
289 pickle_forecast :: PU WeatherForecastXml
290 pickle_forecast =
291 xpElem "forecast" $
292 xpWrap (from_pair, to_pair) $
293 xpPair
294 (xpAttr "gamedate" xp_gamedate)
295 pickle_league
296 where
297 from_pair = uncurry WeatherForecastXml
298 to_pair WeatherForecastXml{..} = (xml_game_date,
299 xml_league)
300
301
302
303 -- | Pickler to convert a 'Message' to/from XML.
304 --
305 pickle_message :: PU Message
306 pickle_message =
307 xpElem "message" $
308 xpWrap (from_tuple, to_tuple) $
309 xp7Tuple
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)
317 where
318 from_tuple = uncurryN Message
319 to_tuple Message{..} = (xml_xml_file_id,
320 xml_heading,
321 xml_category,
322 xml_sport,
323 xml_title,
324 xml_forecasts,
325 xml_time_stamp)
326
327 --
328 -- Tasty tests
329 --
330
331 weather_tests :: TestTree
332 weather_tests =
333 testGroup
334 "Weather tests"
335 [ test_pickle_of_unpickle_is_identity,
336 test_unpickle_succeeds ]
337
338
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.
342 --
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
348 actual @?= expected
349
350
351 -- | Make sure we can actually unpickle these things.
352 --
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
358 let expected = True
359 actual @?= expected