X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=blobdiff_plain;f=src%2FTSN%2FXML%2FScheduleChanges.hs;h=f1cb90725b85c2234901c43371b0a5b6136ea0c9;hp=c447f35158a467be32f64c52b46e67f92662a3a9;hb=ee416db7c942b78e0336202b7567cd0fda7ccda5;hpb=36079b940ebe9a85ac2086fe640e39a0d51e756e diff --git a/src/TSN/XML/ScheduleChanges.hs b/src/TSN/XML/ScheduleChanges.hs index c447f35..f1cb907 100644 --- a/src/TSN/XML/ScheduleChanges.hs +++ b/src/TSN/XML/ScheduleChanges.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -25,6 +26,7 @@ where import Control.Monad ( forM_ ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, @@ -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 ( @@ -104,7 +107,12 @@ data ScheduleChangeXml = ScheduleChangeXml { xml_sc_sport :: String, xml_sc_listings :: [ScheduleChangesListingXml] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector ScheduleChangeXml -- | XML representation of a 'ScheduleChanges'. It has the same @@ -118,8 +126,12 @@ data Message = xml_sport :: String, xml_schedule_changes :: [ScheduleChangeXml], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'H.convert'. +-- +instance H.HVector Message instance ToDb Message where @@ -157,11 +169,18 @@ instance XmlImport Message -- like, \FINAL\ within the XML, -- but they're in one-to-one correspondence with the listings. -- +-- The leading underscores prevent unused field warnings. +-- data ScheduleChangesListingStatus = ScheduleChangesListingStatus { - db_status_numeral :: Int, - db_status :: Maybe String } -- Yes, they can be empty. - deriving (Eq, Show) + _db_status_numeral :: Int, + _db_status :: Maybe String } -- Yes, they can be empty. + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector ScheduleChangesListingStatus -- | Database representation of a \ contained within a @@ -206,7 +225,12 @@ data ScheduleChangesListingXml = xml_hscore :: Int, xml_listing_status :: ScheduleChangesListingStatus, xml_notes :: Maybe String } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector ScheduleChangesListingXml instance ToDb ScheduleChangesListingXml where @@ -303,7 +327,7 @@ mkPersist tsn_codegen_config [groundhog| # Prevent multiple imports of the same message. fields: [db_xml_file_id] -# Note: we drop the "sc" prefix from the db_sc_sport field. + # Note: we drop the "sc" prefix from the db_sc_sport field. - entity: ScheduleChangesListing dbName: schedule_changes_listings constructors: @@ -327,9 +351,9 @@ mkPersist tsn_codegen_config [groundhog| - embedded: ScheduleChangesListingStatus fields: - - name: db_status_numeral + - name: _db_status_numeral dbName: status_numeral - - name: db_status + - name: _db_status dbName: status |] @@ -345,12 +369,12 @@ mkPersist tsn_codegen_config [groundhog| pickle_away_team :: PU VTeam pickle_away_team = xpElem "Away_Team" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "AT_ID" xpText) (xpOption xpText) where from_tuple (x,y) = VTeam (Team x Nothing y) - to_tuple (VTeam t) = (team_id t, name t) + to_tuple' (VTeam t) = (team_id t, name t) -- | An (un)pickler for the \ elements. @@ -358,12 +382,12 @@ pickle_away_team = pickle_home_team :: PU HTeam pickle_home_team = xpElem "Home_Team" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "HT_ID" xpText) (xpOption xpText) where from_tuple (x,y) = HTeam (Team x Nothing y) - to_tuple (HTeam t) = (team_id t, name t) + to_tuple' (HTeam t) = (team_id t, name t) -- | An (un)pickler for the \ elements. @@ -371,13 +395,11 @@ pickle_home_team = pickle_status :: PU ScheduleChangesListingStatus pickle_status = xpElem "status" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "numeral" xpInt) (xpOption xpText) where from_tuple = uncurry ScheduleChangesListingStatus - to_tuple s = (db_status_numeral s, - db_status s) -- | An (un)pickler for the \ elements. @@ -385,7 +407,7 @@ pickle_status = pickle_listing :: PU ScheduleChangesListingXml pickle_listing = xpElem "SC_Listing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp11Tuple (xpAttr "type" xpText) (xpElem "Schedule_ID" xpInt) (xpElem "Game_Date" xp_date_padded) @@ -399,17 +421,6 @@ pickle_listing = (xpElem "notes" (xpOption xpText)) where from_tuple = uncurryN ScheduleChangesListingXml - to_tuple l = (xml_type l, - xml_schedule_id l, - xml_game_date l, - xml_game_time l, - xml_location l, - xml_away_team l, - xml_home_team l, - xml_vscore l, - xml_hscore l, - xml_listing_status l, - xml_notes l) -- | An (un)pickler for the \ elements. @@ -417,13 +428,11 @@ pickle_listing = pickle_schedule_change :: PU ScheduleChangeXml pickle_schedule_change = xpElem "Schedule_Change" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "Sport" xpText) (xpList pickle_listing) where from_tuple = uncurry ScheduleChangeXml - to_tuple sc = (xml_sc_sport sc, - xml_sc_listings sc) -- | Pickler for the top-level 'Message'. @@ -431,7 +440,7 @@ pickle_schedule_change = pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) @@ -440,12 +449,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_schedule_changes m, - xml_time_stamp m)