2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE QuasiQuotes #-}
7 {-# LANGUAGE RecordWildCards #-}
8 {-# LANGUAGE TemplateHaskell #-}
9 {-# LANGUAGE TypeFamilies #-}
11 -- | Parse TSN XML for the DTD
12 -- \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
13 -- \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
14 -- containing \<RaceResultsListing\>s.
16 module TSN.XML.AutoRacingSchedule (
20 auto_racing_schedule_tests,
21 -- * WARNING: these are private but exported to silence warnings
22 AutoRacingScheduleConstructor(..),
23 AutoRacingScheduleListingConstructor(..),
24 AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
28 import Control.Monad ( forM_ )
29 import Data.Time ( UTCTime(..) )
30 import Data.Tuple.Curry ( uncurryN )
31 import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
32 import Database.Groundhog (
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
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 (
60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
61 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
62 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
73 -- | The DTD to which this module corresponds. Used to invoke dbimport.
76 dtd = "Auto_Racing_Schedule_XML.dtd"
82 -- * AutoRacingSchedule/Message
84 -- | Database representation of a 'Message'.
86 data AutoRacingSchedule =
88 db_xml_file_id :: Int,
90 db_category :: String,
93 db_complete_through :: String,
94 db_time_stamp :: UTCTime }
98 -- | XML Representation of an 'AutoRacingSchedule'.
102 xml_xml_file_id :: Int,
103 xml_heading :: String,
104 xml_category :: String,
107 xml_complete_through :: String,
108 xml_listings :: [AutoRacingScheduleListingXml],
109 xml_time_stamp :: UTCTime }
110 deriving (Eq, GHC.Generic, Show)
112 -- | For 'H.convert'.
114 instance H.HVector Message
117 instance ToDb Message where
118 -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
120 type Db Message = AutoRacingSchedule
123 -- | The 'FromXml' instance for 'Message' is required for the
124 -- 'XmlImport' instance.
126 instance FromXml Message where
127 -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
128 -- the 'xml_listings'.
130 from_xml Message{..} =
132 db_xml_file_id = xml_xml_file_id,
133 db_heading = xml_heading,
134 db_category = xml_category,
135 db_sport = xml_sport,
136 db_title = xml_title,
137 db_complete_through = xml_complete_through,
138 db_time_stamp = xml_time_stamp }
141 -- | This allows us to insert the XML representation 'Message'
144 instance XmlImport Message
147 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
149 -- | Database representation of a \<Listing\> contained within a
150 -- \<message\>. We combine the race date/time into a single
151 -- race_time, drop the race results list, and add a foreign key to
154 data AutoRacingScheduleListing =
155 AutoRacingScheduleListing {
156 db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
158 db_race_time :: UTCTime,
159 db_race_name :: String,
160 db_track_name :: String,
161 db_location :: String,
162 db_tv_listing :: Maybe String,
164 db_track_length :: String -- ^ Sometimes the word "miles" shows up.
168 -- | XML representation of a \<Listing\> contained within a
171 data AutoRacingScheduleListingXml =
172 AutoRacingScheduleListingXml {
174 xml_race_date :: UTCTime,
175 xml_race_time :: Maybe UTCTime,
176 xml_race_name :: String,
177 xml_track_name :: String,
178 xml_location :: String,
179 xml_tv_listing :: Maybe String,
181 xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
182 -- so we can't do the right thing and use
184 xml_race_results :: [AutoRacingScheduleListingRaceResult] }
185 deriving (Eq, GHC.Generic, Show)
187 -- | For 'H.convert'.
189 instance H.HVector AutoRacingScheduleListingXml
192 -- | Pseudo-accessor to get the race result listings out of a
193 -- 'AutoRacingScheduleListingXml'. A poor man's lens.
195 result_listings :: AutoRacingScheduleListingXml
196 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
197 result_listings = (concatMap xml_race_result_listing) . xml_race_results
200 instance ToDb AutoRacingScheduleListingXml where
201 -- | The database analogue of an 'AutoRacingScheduleListingXml' is
202 -- an 'AutoRacingScheduleListing'.
204 type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
207 instance Child AutoRacingScheduleListingXml where
208 -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
209 -- foreign key to) a 'AutoRacingSchedule'.
211 type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
214 instance FromXmlFk AutoRacingScheduleListingXml where
215 -- | To convert an 'AutoRacingScheduleListingXml' to an
216 -- 'AutoRacingScheduleListing', we add the foreign key and drop
217 -- the 'xml_race_results'. We also mash the date/time together
220 from_xml_fk fk AutoRacingScheduleListingXml{..} =
221 AutoRacingScheduleListing {
222 db_auto_racing_schedules_id = fk,
223 db_race_id = xml_race_id,
224 db_race_time = make_race_time xml_race_date xml_race_time,
225 db_race_name = xml_race_name,
226 db_track_name = xml_track_name,
227 db_location = xml_location,
228 db_tv_listing = xml_tv_listing,
230 db_track_length = xml_track_length }
232 -- | Make the database \"race time\" from the XML
233 -- date/time. Simply take the day part from one and the time
236 make_race_time d Nothing = d
237 make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
240 -- | This allows us to insert the XML representation
241 -- 'AutoRacingScheduleListingXml' directly.
243 instance XmlImportFk AutoRacingScheduleListingXml
247 -- * AutoRacingScheduleListingRaceResult
249 -- | The XML representation of \<message\> -> \<Listing\> ->
250 -- \<RaceResults\>. This element serves only to contain
251 -- \<RaceResultsListing\>s, so we don't store the intermediate table
254 newtype AutoRacingScheduleListingRaceResult =
255 AutoRacingScheduleListingRaceResult {
256 xml_race_result_listing ::
257 [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
261 -- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml
263 -- Sorry about the names yo.
266 -- | Database representation of \<RaceResultListing\> within
267 -- \<RaceResults\> within \<Listing\> within... \<message\>!
268 -- The leading underscores prevent unused field warnings.
270 data AutoRacingScheduleListingRaceResultRaceResultListing =
271 AutoRacingScheduleListingRaceResultRaceResultListing {
272 _db_auto_racing_schedules_listings_id ::
273 DefaultKey AutoRacingScheduleListing,
274 _db_finish_position :: Int,
275 _db_driver_id :: 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
282 deriving ( GHC.Generic )
286 instance H.HVector AutoRacingScheduleListingRaceResultRaceResultListing
289 -- | XML Representation of an
290 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
291 -- The leading underscores prevent unused field warnings.
293 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
294 AutoRacingScheduleListingRaceResultRaceResultListingXml {
295 _xml_finish_position :: Int,
296 _xml_driver_id :: Int,
298 _xml_leading_laps :: Int,
299 _xml_listing_laps :: Int, -- ^ Avoids clash with race's \"laps\" field.
300 _xml_earnings :: String, -- ^ Should be an 'Int', but can have commas.
301 _xml_status :: Maybe String -- ^ They can be empty
303 deriving (Eq, GHC.Generic, Show)
305 -- | For 'H.convert'.
307 instance H.HVector AutoRacingScheduleListingRaceResultRaceResultListingXml
310 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
311 -- | The database representation of an
312 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
313 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
315 type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
316 AutoRacingScheduleListingRaceResultRaceResultListing
319 instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where
320 -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
321 -- is contained in (i.e. has a foreign key to) an
322 -- 'AutoRacingScheduleListing'. We skip the intermediate
325 type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
326 AutoRacingScheduleListing
329 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
331 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
332 -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just
333 -- add the foreign key to the parent 'AutoRacingScheduleListing'.
338 -- | This allows us to insert the XML representation
339 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
342 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
349 instance DbImport Message where
352 migrate (undefined :: AutoRacingSchedule)
353 migrate (undefined :: AutoRacingScheduleListing)
355 :: AutoRacingScheduleListingRaceResultRaceResultListing)
358 -- | We insert the message, then use its ID to insert the listings,
359 -- using their IDs to insert the race result listings.
362 msg_id <- insert_xml m
364 forM_ (xml_listings m) $ \listing -> do
365 listing_id <- insert_xml_fk msg_id listing
367 mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
369 return ImportSucceeded
372 mkPersist tsn_codegen_config [groundhog|
373 - entity: AutoRacingSchedule
374 dbName: auto_racing_schedules
376 - name: AutoRacingSchedule
378 - name: unique_auto_racing_schedules
380 # Prevent multiple imports of the same message.
381 fields: [db_xml_file_id]
383 - entity: AutoRacingScheduleListing
384 dbName: auto_racing_schedules_listings
386 - name: AutoRacingScheduleListing
388 - name: db_auto_racing_schedules_id
392 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
393 dbName: auto_racing_schedules_listings_race_result_listings
395 - name: AutoRacingScheduleListingRaceResultRaceResultListing
397 - name: _db_auto_racing_schedules_listings_id
408 -- | Pickler for the top-level 'Message'.
410 pickle_message :: PU Message
413 xpWrap (from_tuple, H.convert) $
414 xp8Tuple (xpElem "XML_File_ID" xpInt)
415 (xpElem "heading" xpText)
416 (xpElem "category" xpText)
417 (xpElem "sport" xpText)
418 (xpElem "Title" xpText)
419 (xpElem "Complete_Through" xpText)
420 (xpList pickle_listing)
421 (xpElem "time_stamp" xp_time_stamp)
423 from_tuple = uncurryN Message
426 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
428 pickle_listing :: PU AutoRacingScheduleListingXml
431 xpWrap (from_tuple, H.convert) $
432 xp10Tuple (xpElem "RaceID" xpInt)
433 (xpElem "Race_Date" xp_date_padded)
434 (xpElem "Race_Time" xp_tba_time)
435 (xpElem "RaceName" xpText)
436 (xpElem "TrackName" xpText)
437 (xpElem "Location" xpText)
438 (xpElem "TV_Listing" $ xpOption xpText)
439 (xpElem "Laps" xpInt)
440 (xpElem "TrackLength" xpText)
441 (xpList pickle_race_results)
443 from_tuple = uncurryN AutoRacingScheduleListingXml
447 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
449 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
450 pickle_race_results =
451 xpElem "RaceResults" $
452 xpWrap (to_result, from_result) $
453 xpList pickle_race_results_listing
455 to_result = AutoRacingScheduleListingRaceResult
456 from_result = xml_race_result_listing
460 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
463 pickle_race_results_listing ::
464 PU AutoRacingScheduleListingRaceResultRaceResultListingXml
465 pickle_race_results_listing =
466 xpElem "RaceResultsListing" $
467 xpWrap (from_tuple, H.convert) $
468 xp7Tuple (xpElem "FinishPosition" xpInt)
469 (xpElem "DriverID" xpInt)
470 (xpElem "Name" xpText)
471 (xpElem "LeadingLaps" xpInt)
472 (xpElem "Laps" xpInt)
473 (xpElem "Earnings" xpText)
474 (xpElem "Status" (xpOption xpText))
477 uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
484 -- | A list of all tests for this module.
486 auto_racing_schedule_tests :: TestTree
487 auto_racing_schedule_tests =
489 "AutoRacingSchedule tests"
490 [ test_on_delete_cascade,
491 test_pickle_of_unpickle_is_identity,
492 test_unpickle_succeeds ]
494 -- | If we unpickle something and then pickle it, we should wind up
495 -- with the same thing we started with. WARNING: success of this
496 -- test does not mean that unpickling succeeded.
498 test_pickle_of_unpickle_is_identity :: TestTree
499 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
500 [ check "pickle composed with unpickle is the identity"
501 "test/xml/Auto_Racing_Schedule_XML.xml",
503 check "pickle composed with unpickle is the identity (miles track length)"
504 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
506 check desc path = testCase desc $ do
507 (expected, actual) <- pickle_unpickle pickle_message path
511 -- | Make sure we can actually unpickle these things.
513 test_unpickle_succeeds :: TestTree
514 test_unpickle_succeeds = testGroup "unpickle tests"
515 [ check "unpickling succeeds"
516 "test/xml/Auto_Racing_Schedule_XML.xml",
518 check "unpickling succeeds (non-int team_id)"
519 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
521 check desc path = testCase desc $ do
522 actual <- unpickleable path pickle_message
527 -- | Make sure everything gets deleted when we delete the top-level
530 test_on_delete_cascade :: TestTree
531 test_on_delete_cascade = testGroup "cascading delete tests"
532 [ check "deleting auto_racing_schedules deletes its children"
533 "test/xml/Auto_Racing_Schedule_XML.xml" ,
535 check ("deleting auto_racing_schedules deletes its children " ++
536 "(miles track length)")
537 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
539 check desc path = testCase desc $ do
540 sched <- unsafe_unpickle path pickle_message
541 let a = undefined :: AutoRacingSchedule
542 let b = undefined :: AutoRacingScheduleListing
543 let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
545 actual <- withSqliteConn ":memory:" $ runDbConn $ do
546 runMigrationSilent $ do
552 count_a <- countAll a
553 count_b <- countAll b
554 count_c <- countAll c
555 return $ sum [count_a, count_b, count_c]