1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD
11 -- \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
12 -- \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
13 -- containing \<RaceResultsListing\>s.
15 module TSN.XML.AutoRacingSchedule (
19 auto_racing_schedule_tests,
20 -- * WARNING: these are private but exported to silence warnings
21 AutoRacingScheduleConstructor(..),
22 AutoRacingScheduleListingConstructor(..),
23 AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
27 import Control.Monad ( forM_ )
28 import Data.Time ( UTCTime(..) )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
35 silentMigrationLogger )
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import qualified GHC.Generics as GHC ( Generic )
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
58 import Generics ( Generic(..), to_tuple )
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
63 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
74 -- | The DTD to which this module corresponds. Used to invoke dbimport.
77 dtd = "Auto_Racing_Schedule_XML.dtd"
83 -- * AutoRacingSchedule/Message
85 -- | Database representation of a 'Message'.
87 data AutoRacingSchedule =
89 db_xml_file_id :: Int,
91 db_category :: String,
94 db_complete_through :: String,
95 db_time_stamp :: UTCTime }
99 -- | XML Representation of an 'AutoRacingSchedule'.
103 xml_xml_file_id :: Int,
104 xml_heading :: String,
105 xml_category :: String,
108 xml_complete_through :: String,
109 xml_listings :: [AutoRacingScheduleListingXml],
110 xml_time_stamp :: UTCTime }
111 deriving (Eq, GHC.Generic, Show)
113 -- | For 'Generics.to_tuple'.
115 instance Generic Message
118 instance ToDb Message where
119 -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
121 type Db Message = AutoRacingSchedule
124 -- | The 'FromXml' instance for 'Message' is required for the
125 -- 'XmlImport' instance.
127 instance FromXml Message where
128 -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
129 -- the 'xml_listings'.
131 from_xml Message{..} =
133 db_xml_file_id = xml_xml_file_id,
134 db_heading = xml_heading,
135 db_category = xml_category,
136 db_sport = xml_sport,
137 db_title = xml_title,
138 db_complete_through = xml_complete_through,
139 db_time_stamp = xml_time_stamp }
142 -- | This allows us to insert the XML representation 'Message'
145 instance XmlImport Message
148 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
150 -- | Database representation of a \<Listing\> contained within a
151 -- \<message\>. We combine the race date/time into a single
152 -- race_time, drop the race results list, and add a foreign key to
155 data AutoRacingScheduleListing =
156 AutoRacingScheduleListing {
157 db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
159 db_race_time :: UTCTime,
160 db_race_name :: String,
161 db_track_name :: String,
162 db_location :: String,
163 db_tv_listing :: Maybe String,
165 db_track_length :: String -- ^ Sometimes the word "miles" shows up.
169 -- | XML representation of a \<Listing\> contained within a
172 data AutoRacingScheduleListingXml =
173 AutoRacingScheduleListingXml {
175 xml_race_date :: UTCTime,
176 xml_race_time :: Maybe UTCTime,
177 xml_race_name :: String,
178 xml_track_name :: String,
179 xml_location :: String,
180 xml_tv_listing :: Maybe String,
182 xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
183 -- so we can't do the right thing and use
185 xml_race_results :: [AutoRacingScheduleListingRaceResult] }
186 deriving (Eq, GHC.Generic, Show)
188 -- | For 'Generics.to_tuple'.
190 instance Generic AutoRacingScheduleListingXml
193 -- | Pseudo-accessor to get the race result listings out of a
194 -- 'AutoRacingScheduleListingXml'. A poor man's lens.
196 result_listings :: AutoRacingScheduleListingXml
197 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
198 result_listings = (concatMap xml_race_result_listing) . xml_race_results
201 instance ToDb AutoRacingScheduleListingXml where
202 -- | The database analogue of an 'AutoRacingScheduleListingXml' is
203 -- an 'AutoRacingScheduleListing'.
205 type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
208 instance Child AutoRacingScheduleListingXml where
209 -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
210 -- foreign key to) a 'AutoRacingSchedule'.
212 type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
215 instance FromXmlFk AutoRacingScheduleListingXml where
216 -- | To convert an 'AutoRacingScheduleListingXml' to an
217 -- 'AutoRacingScheduleListing', we add the foreign key and drop
218 -- the 'xml_race_results'. We also mash the date/time together
221 from_xml_fk fk AutoRacingScheduleListingXml{..} =
222 AutoRacingScheduleListing {
223 db_auto_racing_schedules_id = fk,
224 db_race_id = xml_race_id,
225 db_race_time = make_race_time xml_race_date xml_race_time,
226 db_race_name = xml_race_name,
227 db_track_name = xml_track_name,
228 db_location = xml_location,
229 db_tv_listing = xml_tv_listing,
231 db_track_length = xml_track_length }
233 -- | Make the database \"race time\" from the XML
234 -- date/time. Simply take the day part from one and the time
237 make_race_time d Nothing = d
238 make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
241 -- | This allows us to insert the XML representation
242 -- 'AutoRacingScheduleListingXml' directly.
244 instance XmlImportFk AutoRacingScheduleListingXml
248 -- * AutoRacingScheduleListingRaceResult
250 -- | The XML representation of \<message\> -> \<Listing\> ->
251 -- \<RaceResults\>. This element serves only to contain
252 -- \<RaceResultsListing\>s, so we don't store the intermediate table
255 newtype AutoRacingScheduleListingRaceResult =
256 AutoRacingScheduleListingRaceResult {
257 xml_race_result_listing ::
258 [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
262 -- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml
264 -- Sorry about the names yo.
267 -- | Database representation of \<RaceResultListing\> within
268 -- \<RaceResults\> within \<Listing\> within... \<message\>!
270 data AutoRacingScheduleListingRaceResultRaceResultListing =
271 AutoRacingScheduleListingRaceResultRaceResultListing {
272 db_auto_racing_schedules_listings_id ::
273 DefaultKey AutoRacingScheduleListing,
274 db_finish_position :: Int,
277 db_leading_laps :: Int,
278 db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
279 db_earnings :: String, -- ^ This should be an Int, but can have commas.
280 db_status :: Maybe String -- ^ They can be empty
284 -- | XML Representation of an
285 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
287 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
288 AutoRacingScheduleListingRaceResultRaceResultListingXml {
289 xml_finish_position :: Int,
290 xml_driver_id :: Int,
292 xml_leading_laps :: Int,
293 xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
294 xml_earnings :: String, -- ^ Should be an 'Int', but can have commas.
295 xml_status :: Maybe String -- ^ They can be empty
297 deriving (Eq, GHC.Generic, Show)
299 -- | For 'Generics.to_tuple'.
301 instance Generic AutoRacingScheduleListingRaceResultRaceResultListingXml
304 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
305 -- | The database representation of an
306 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
307 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
309 type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
310 AutoRacingScheduleListingRaceResultRaceResultListing
313 instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where
314 -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
315 -- is contained in (i.e. has a foreign key to) an
316 -- 'AutoRacingScheduleListing'. We skip the intermediate
319 type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
320 AutoRacingScheduleListing
323 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
325 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
326 -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just
327 -- add the foreign key to the parent 'AutoRacingScheduleListing'.
329 from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
330 AutoRacingScheduleListingRaceResultRaceResultListing {
331 db_auto_racing_schedules_listings_id = fk,
332 db_finish_position = xml_finish_position,
333 db_driver_id = xml_driver_id,
335 db_leading_laps = xml_leading_laps,
336 db_listing_laps = xml_listing_laps,
337 db_earnings = xml_earnings,
338 db_status = xml_status }
341 -- | This allows us to insert the XML representation
342 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
345 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
352 instance DbImport Message where
355 migrate (undefined :: AutoRacingSchedule)
356 migrate (undefined :: AutoRacingScheduleListing)
358 :: AutoRacingScheduleListingRaceResultRaceResultListing)
361 -- | We insert the message, then use its ID to insert the listings,
362 -- using their IDs to insert the race result listings.
365 msg_id <- insert_xml m
367 forM_ (xml_listings m) $ \listing -> do
368 listing_id <- insert_xml_fk msg_id listing
370 mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
372 return ImportSucceeded
375 mkPersist tsn_codegen_config [groundhog|
376 - entity: AutoRacingSchedule
377 dbName: auto_racing_schedules
379 - name: AutoRacingSchedule
381 - name: unique_auto_racing_schedules
383 # Prevent multiple imports of the same message.
384 fields: [db_xml_file_id]
386 - entity: AutoRacingScheduleListing
387 dbName: auto_racing_schedules_listings
389 - name: AutoRacingScheduleListing
391 - name: db_auto_racing_schedules_id
395 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
396 dbName: auto_racing_schedules_listings_race_result_listings
398 - name: AutoRacingScheduleListingRaceResultRaceResultListing
400 - name: db_auto_racing_schedules_listings_id
411 -- | Pickler for the top-level 'Message'.
413 pickle_message :: PU Message
416 xpWrap (from_tuple, to_tuple) $
417 xp8Tuple (xpElem "XML_File_ID" xpInt)
418 (xpElem "heading" xpText)
419 (xpElem "category" xpText)
420 (xpElem "sport" xpText)
421 (xpElem "Title" xpText)
422 (xpElem "Complete_Through" xpText)
423 (xpList pickle_listing)
424 (xpElem "time_stamp" xp_time_stamp)
426 from_tuple = uncurryN Message
429 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
431 pickle_listing :: PU AutoRacingScheduleListingXml
434 xpWrap (from_tuple, to_tuple) $
435 xp10Tuple (xpElem "RaceID" xpInt)
436 (xpElem "Race_Date" xp_date_padded)
437 (xpElem "Race_Time" xp_tba_time)
438 (xpElem "RaceName" xpText)
439 (xpElem "TrackName" xpText)
440 (xpElem "Location" xpText)
441 (xpElem "TV_Listing" $ xpOption xpText)
442 (xpElem "Laps" xpInt)
443 (xpElem "TrackLength" xpText)
444 (xpList pickle_race_results)
446 from_tuple = uncurryN AutoRacingScheduleListingXml
450 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
452 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
453 pickle_race_results =
454 xpElem "RaceResults" $
455 xpWrap (to_result, from_result) $
456 xpList pickle_race_results_listing
458 to_result = AutoRacingScheduleListingRaceResult
459 from_result = xml_race_result_listing
463 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
466 pickle_race_results_listing ::
467 PU AutoRacingScheduleListingRaceResultRaceResultListingXml
468 pickle_race_results_listing =
469 xpElem "RaceResultsListing" $
470 xpWrap (from_tuple, to_tuple) $
471 xp7Tuple (xpElem "FinishPosition" xpInt)
472 (xpElem "DriverID" xpInt)
473 (xpElem "Name" xpText)
474 (xpElem "LeadingLaps" xpInt)
475 (xpElem "Laps" xpInt)
476 (xpElem "Earnings" xpText)
477 (xpElem "Status" (xpOption xpText))
480 uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
487 -- | A list of all tests for this module.
489 auto_racing_schedule_tests :: TestTree
490 auto_racing_schedule_tests =
492 "AutoRacingSchedule tests"
493 [ test_on_delete_cascade,
494 test_pickle_of_unpickle_is_identity,
495 test_unpickle_succeeds ]
497 -- | If we unpickle something and then pickle it, we should wind up
498 -- with the same thing we started with. WARNING: success of this
499 -- test does not mean that unpickling succeeded.
501 test_pickle_of_unpickle_is_identity :: TestTree
502 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
503 [ check "pickle composed with unpickle is the identity"
504 "test/xml/Auto_Racing_Schedule_XML.xml",
506 check "pickle composed with unpickle is the identity (miles track length)"
507 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
509 check desc path = testCase desc $ do
510 (expected, actual) <- pickle_unpickle pickle_message path
514 -- | Make sure we can actually unpickle these things.
516 test_unpickle_succeeds :: TestTree
517 test_unpickle_succeeds = testGroup "unpickle tests"
518 [ check "unpickling succeeds"
519 "test/xml/Auto_Racing_Schedule_XML.xml",
521 check "unpickling succeeds (non-int team_id)"
522 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
524 check desc path = testCase desc $ do
525 actual <- unpickleable path pickle_message
530 -- | Make sure everything gets deleted when we delete the top-level
533 test_on_delete_cascade :: TestTree
534 test_on_delete_cascade = testGroup "cascading delete tests"
535 [ check "deleting auto_racing_schedules deletes its children"
536 "test/xml/Auto_Racing_Schedule_XML.xml" ,
538 check ("deleting auto_racing_schedules deletes its children " ++
539 "(miles track length)")
540 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
542 check desc path = testCase desc $ do
543 sched <- unsafe_unpickle path pickle_message
544 let a = undefined :: AutoRacingSchedule
545 let b = undefined :: AutoRacingScheduleListing
546 let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
548 actual <- withSqliteConn ":memory:" $ runDbConn $ do
549 runMigration silentMigrationLogger $ do
555 count_a <- countAll a
556 count_b <- countAll b
557 count_c <- countAll c
558 return $ sum [count_a, count_b, count_c]