X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingSchedule.hs;h=1cbcbc1bfd2e1fa70fd2eedc58eab178ddf970eb;hb=52b420301965efe58a60672832c93b5046695cd0;hp=62202ddf88dcf0279423ce70fd52fd55351a4aa1;hpb=65b8e7251134ef5515c17abae8964c890de0602c;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/AutoRacingSchedule.hs b/src/TSN/XML/AutoRacingSchedule.hs index 62202dd..1cbcbc1 100644 --- a/src/TSN/XML/AutoRacingSchedule.hs +++ b/src/TSN/XML/AutoRacingSchedule.hs @@ -1,9 +1,10 @@ + {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +14,7 @@ -- containing \s. -- module TSN.XML.AutoRacingSchedule ( + dtd, pickle_message, -- * Tests auto_racing_schedule_tests, @@ -28,7 +30,7 @@ import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( countAll, - executeRaw, + deleteAll, migrate, runMigration, silentMigrationLogger ) @@ -38,6 +40,7 @@ import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -53,12 +56,14 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. +import Generics ( Generic(..), prepend, to_tuple ) import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp ) +import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( + Child(..), FromXml(..), FromXmlFk(..), ToDb(..), @@ -67,6 +72,11 @@ import Xml ( unsafe_unpickle ) +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "Auto_Racing_Schedule_XML.dtd" + -- -- DB/XML data types -- @@ -99,12 +109,26 @@ data Message = xml_complete_through :: String, xml_listings :: [AutoRacingScheduleListingXml], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic Message + instance ToDb Message where + -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'. + -- type Db Message = AutoRacingSchedule + +-- | The 'FromXml' instance for 'Message' is required for the +-- 'XmlImport' instance. +-- instance FromXml Message where + -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop + -- the 'xml_listings'. + -- from_xml Message{..} = AutoRacingSchedule { db_xml_file_id = xml_xml_file_id, @@ -115,15 +139,20 @@ instance FromXml Message where db_complete_through = xml_complete_through, db_time_stamp = xml_time_stamp } + +-- | This allows us to insert the XML representation 'Message' +-- directly. +-- instance XmlImport Message -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml -- | Database representation of a \ contained within a --- \. We combine the race date/time into a single +-- \. We combine the race date/time into a single -- race_time, drop the race results list, and add a foreign key to -- our parent. +-- data AutoRacingScheduleListing = AutoRacingScheduleListing { db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule, @@ -137,6 +166,7 @@ data AutoRacingScheduleListing = db_track_length :: String -- ^ Sometimes the word "miles" shows up. } + -- | XML representation of a \ contained within a -- \. -- @@ -150,23 +180,45 @@ data AutoRacingScheduleListingXml = xml_location :: String, xml_tv_listing :: Maybe String, xml_laps :: Int, - xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up. + xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up, + -- so we can't do the right thing and use + -- a 'Double'. xml_race_results :: [AutoRacingScheduleListingRaceResult] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic AutoRacingScheduleListingXml + -- | Pseudo-accessor to get the race result listings out of a --- 'AutoRacingScheduleListingXml'. +-- 'AutoRacingScheduleListingXml'. A poor man's lens. +-- result_listings :: AutoRacingScheduleListingXml -> [AutoRacingScheduleListingRaceResultRaceResultListingXml] result_listings = (concatMap xml_race_result_listing) . xml_race_results instance ToDb AutoRacingScheduleListingXml where + -- | The database analogue of an 'AutoRacingScheduleListingXml' is + -- an 'AutoRacingScheduleListing'. + -- type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing -instance FromXmlFk AutoRacingScheduleListingXml where + +instance Child AutoRacingScheduleListingXml where + -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a + -- foreign key to) a 'AutoRacingSchedule'. + -- type Parent AutoRacingScheduleListingXml = AutoRacingSchedule + +instance FromXmlFk AutoRacingScheduleListingXml where + -- | To convert an 'AutoRacingScheduleListingXml' to an + -- 'AutoRacingScheduleListing', we add the foreign key and drop + -- the 'xml_race_results'. We also mash the date/time together + -- into one field. + -- from_xml_fk fk AutoRacingScheduleListingXml{..} = AutoRacingScheduleListing { db_auto_racing_schedules_id = fk, @@ -179,12 +231,21 @@ instance FromXmlFk AutoRacingScheduleListingXml where db_laps = xml_laps, db_track_length = xml_track_length } where - -- Take the day part from one, the time from the other. + -- | Make the database \"race time\" from the XML + -- date/time. Simply take the day part from one and the time + -- from the other. + -- make_race_time d Nothing = d make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t) + +-- | This allows us to insert the XML representation +-- 'AutoRacingScheduleListingXml' directly. +-- instance XmlImportFk AutoRacingScheduleListingXml + + -- * AutoRacingScheduleListingRaceResult -- | The XML representation of \ -> \ -> @@ -198,53 +259,91 @@ newtype AutoRacingScheduleListingRaceResult = [AutoRacingScheduleListingRaceResultRaceResultListingXml] } deriving (Eq, Show) --- * AutoRacingScheduleListingRaceResultRaceResultListing / --- AutoRacingScheduleListingRaceResultRaceResultListingXml +-- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml +-- +-- Sorry about the names yo. +-- + +-- | Database representation of \ within +-- \ within \ within... \! +-- The leading underscores prevent unused field warnings. +-- data AutoRacingScheduleListingRaceResultRaceResultListing = AutoRacingScheduleListingRaceResultRaceResultListing { - db_auto_racing_schedules_listings_id :: + _db_auto_racing_schedules_listings_id :: DefaultKey AutoRacingScheduleListing, - db_finish_position :: Int, - db_driver_id :: Int, - db_name :: String, - db_leading_laps :: Int, - db_listing_laps :: Int, -- Avoid clash with race's "laps" field. - db_earnings :: String, -- Should be an int, but they use commas. - db_status :: String } + _db_finish_position :: Int, + _db_driver_id :: Int, + _db_name :: String, + _db_leading_laps :: Int, + _db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field. + _db_earnings :: String, -- ^ This should be an Int, but can have commas. + _db_status :: Maybe String -- ^ They can be empty + } + deriving ( GHC.Generic ) + +-- | For 'Generics.prepend'. +-- +instance Generic AutoRacingScheduleListingRaceResultRaceResultListing + +-- | XML Representation of an +-- 'AutoRacingScheduleListingRaceResultRaceResultListing'. +-- The leading underscores prevent unused field warnings. +-- data AutoRacingScheduleListingRaceResultRaceResultListingXml = AutoRacingScheduleListingRaceResultRaceResultListingXml { - xml_finish_position :: Int, - xml_driver_id :: Int, - xml_name :: String, - xml_leading_laps :: Int, - xml_listing_laps :: Int, -- Avoid clash with race's "laps" field. - xml_earnings :: String, -- Should be an int, but they use commas. - xml_status :: String } - deriving (Eq, Show) + _xml_finish_position :: Int, + _xml_driver_id :: Int, + _xml_name :: String, + _xml_leading_laps :: Int, + _xml_listing_laps :: Int, -- ^ Avoids clash with race's \"laps\" field. + _xml_earnings :: String, -- ^ Should be an 'Int', but can have commas. + _xml_status :: Maybe String -- ^ They can be empty + } + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic AutoRacingScheduleListingRaceResultRaceResultListingXml + instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where + -- | The database representation of an + -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an + -- 'AutoRacingScheduleListingRaceResultRaceResultListing'. + -- type Db AutoRacingScheduleListingRaceResultRaceResultListingXml = AutoRacingScheduleListingRaceResultRaceResultListing -instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where + +instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where + -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml' + -- is contained in (i.e. has a foreign key to) an + -- 'AutoRacingScheduleListing'. We skip the intermediate + -- \. + -- type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml = AutoRacingScheduleListing - from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} = - AutoRacingScheduleListingRaceResultRaceResultListing { - db_auto_racing_schedules_listings_id = fk, - db_finish_position = xml_finish_position, - db_driver_id = xml_driver_id, - db_name = xml_name, - db_leading_laps = xml_leading_laps, - db_listing_laps = xml_listing_laps, - db_earnings = xml_earnings, - db_status = xml_earnings } +instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where + -- | To convert an + -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an + -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just + -- add the foreign key to the parent 'AutoRacingScheduleListing'. + -- + from_xml_fk = prepend + + +-- | This allows us to insert the XML representation +-- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' +-- directly. +-- instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml + --- --- Database stuff. --- @@ -257,6 +356,10 @@ instance DbImport Message where migrate (undefined :: AutoRacingScheduleListingRaceResultRaceResultListing) + + -- | We insert the message, then use its ID to insert the listings, + -- using their IDs to insert the race result listings. + -- dbimport m = do msg_id <- insert_xml m @@ -274,7 +377,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: AutoRacingSchedule uniques: - - name: unique_auto_racing_schedule + - name: unique_auto_racing_schedules type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] @@ -293,7 +396,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: AutoRacingScheduleListingRaceResultRaceResultListing fields: - - name: db_auto_racing_schedules_listings_id + - name: _db_auto_racing_schedules_listings_id reference: onDelete: cascade |] @@ -320,22 +423,16 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_category m, - xml_sport m, - xml_title m, - xml_complete_through m, - xml_listings m, - xml_time_stamp m) +-- | Convert an 'AutoRacingScheduleListingXml' to/from XML. +-- pickle_listing :: PU AutoRacingScheduleListingXml pickle_listing = xpElem "Listing" $ xpWrap (from_tuple, to_tuple) $ xp10Tuple (xpElem "RaceID" xpInt) - (xpElem "Race_Date" xp_date) + (xpElem "Race_Date" xp_date_padded) (xpElem "Race_Time" xp_tba_time) (xpElem "RaceName" xpText) (xpElem "TrackName" xpText) @@ -346,17 +443,11 @@ pickle_listing = (xpList pickle_race_results) where from_tuple = uncurryN AutoRacingScheduleListingXml - to_tuple m = (xml_race_id m, - xml_race_date m, - xml_race_time m, - xml_race_name m, - xml_track_name m, - xml_location m, - xml_tv_listing m, - xml_laps m, - xml_track_length m, - xml_race_results m) + + +-- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML. +-- pickle_race_results :: PU AutoRacingScheduleListingRaceResult pickle_race_results = xpElem "RaceResults" $ @@ -366,6 +457,11 @@ pickle_race_results = to_result = AutoRacingScheduleListingRaceResult from_result = xml_race_result_listing + +-- | Convert an +-- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from +-- XML. +-- pickle_race_results_listing :: PU AutoRacingScheduleListingRaceResultRaceResultListingXml pickle_race_results_listing = @@ -377,19 +473,11 @@ pickle_race_results_listing = (xpElem "LeadingLaps" xpInt) (xpElem "Laps" xpInt) (xpElem "Earnings" xpText) - (xpElem "Status" xpText) + (xpElem "Status" (xpOption xpText)) where from_tuple = uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml - to_tuple m = (xml_finish_position m, - xml_driver_id m, - xml_name m, - xml_leading_laps m, - xml_listing_laps m, - xml_earnings m, - xml_status m) - -- -- Tasty Tests @@ -462,8 +550,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" migrate b migrate c _ <- dbimport sched - -- No idea how 'delete' works, so do this instead. - executeRaw False "DELETE FROM auto_racing_schedules;" [] + deleteAll a count_a <- countAll a count_b <- countAll b count_c <- countAll c