X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingSchedule.hs;h=d4a726b4fc5eece3dadad3dd2b7246b740fabbbf;hb=7d4e1e7142bc3d80efab03d983cb2915d9a893db;hp=27b73ef44fc49a9630719844bba17e8e783aace0;hpb=d2f5d93b2b68f581d4cb4eabecc556c01762d370;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/AutoRacingSchedule.hs b/src/TSN/XML/AutoRacingSchedule.hs index 27b73ef..d4a726b 100644 --- a/src/TSN/XML/AutoRacingSchedule.hs +++ b/src/TSN/XML/AutoRacingSchedule.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +13,7 @@ -- containing \s. -- module TSN.XML.AutoRacingSchedule ( + dtd, pickle_message, -- * Tests auto_racing_schedule_tests, @@ -28,7 +29,7 @@ import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( countAll, - executeRaw, + deleteAll, migrate, runMigration, silentMigrationLogger ) @@ -38,6 +39,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 +55,14 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. +import Generics ( Generic(..), 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 +71,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,7 +108,11 @@ 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 @@ -135,7 +148,7 @@ 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. -- @@ -170,7 +183,11 @@ data AutoRacingScheduleListingXml = -- 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 @@ -187,12 +204,15 @@ instance ToDb AutoRacingScheduleListingXml where -- 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 @@ -239,8 +259,7 @@ newtype AutoRacingScheduleListingRaceResult = deriving (Eq, Show) --- * AutoRacingScheduleListingRaceResultRaceResultListing / --- AutoRacingScheduleListingRaceResultRaceResultListingXml +-- * AutoRacingScheduleListingRaceResultRaceResultListing / AutoRacingScheduleListingRaceResultRaceResultListingXml -- -- Sorry about the names yo. -- @@ -258,7 +277,8 @@ data AutoRacingScheduleListingRaceResultRaceResultListing = 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 :: String } + db_status :: Maybe String -- ^ They can be empty + } -- | XML Representation of an @@ -272,8 +292,13 @@ data AutoRacingScheduleListingRaceResultRaceResultListingXml = xml_leading_laps :: Int, xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field. xml_earnings :: String, -- ^ Should be an 'Int', but can have commas. - xml_status :: String } - deriving (Eq, Show) + xml_status :: Maybe String -- ^ They can be empty + } + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic AutoRacingScheduleListingRaceResultRaceResultListingXml instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where @@ -285,7 +310,7 @@ instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where 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 @@ -294,6 +319,8 @@ instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml = AutoRacingScheduleListing + +instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where -- | To convert an -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just @@ -308,7 +335,7 @@ instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where db_leading_laps = xml_leading_laps, db_listing_laps = xml_listing_laps, db_earnings = xml_earnings, - db_status = xml_earnings } + db_status = xml_status } -- | This allows us to insert the XML representation @@ -351,7 +378,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] @@ -397,14 +424,6 @@ 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. @@ -414,7 +433,7 @@ 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) @@ -425,16 +444,7 @@ 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. @@ -464,19 +474,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 @@ -549,8 +551,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