X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FJFile.hs;h=80d13fe8354b5d353f343924e7e9bd9ab6fda90a;hb=32147474ba5c91452eeb532381f63e88c257a982;hp=84e6b66ebd642e148241a7d5acc042bb66dfa880;hpb=532d663c1aca4add29bc9e1430130d72938b58a5;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs index 84e6b66..80d13fe 100644 --- a/src/TSN/XML/JFile.hs +++ b/src/TSN/XML/JFile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -27,18 +28,18 @@ import Data.List ( intercalate ) import Data.String.Utils ( split ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, - migrate, - runMigration, - silentMigrationLogger ) + migrate ) import Database.Groundhog.Core ( DefaultKey ) -import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) 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 ( @@ -121,7 +122,12 @@ data Message = xml_sport :: String, xml_gamelist :: JFileGameListXml, xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector Message instance ToDb Message where @@ -199,6 +205,7 @@ data JFileGameStatus = deriving (Eq, Show) + -- | Database representation of a \ contained within a -- \, and, implicitly, a \. -- @@ -245,7 +252,12 @@ data JFileGameXml = xml_hscore :: Int, xml_time_remaining :: Maybe String, xml_game_status :: JFileGameStatus } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector JFileGameXml -- * JFileGameListXml @@ -421,7 +433,7 @@ mkPersist tsn_codegen_config [groundhog| 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) @@ -430,12 +442,7 @@ 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_gamelist m, - xml_time_stamp m) + pickle_gamelist :: PU JFileGameListXml pickle_gamelist = @@ -451,7 +458,7 @@ pickle_gamelist = pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info @@ -468,25 +475,12 @@ pickle_game = pickle_status where from_tuple = uncurryN JFileGameXml - to_tuple m = (xml_game_id m, - xml_schedule_id m, - xml_odds_info m, - xml_season_type m, - xml_game_date m, - xml_game_time m, - xml_vteam m, - xml_vleague m, - xml_hteam m, - xml_hleague m, - xml_vscore m, - xml_hscore m, - xml_time_remaining m, - xml_game_status m) + pickle_odds_info :: PU JFileGameOddsInfo pickle_odds_info = xpElem "Odds_Info" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xp19Tuple (xpElem "ListDate" (xpOption xp_date)) (xpElem "HomeTeamID" (xpOption xpText)) (xpElem "AwayTeamID" (xpOption xpText)) @@ -512,21 +506,21 @@ pickle_odds_info = where notes = intercalate "\n" [n1,n2,n3,n4,n5] - to_tuple o = (db_list_date o, - db_info_home_team_id o, - db_info_away_team_id o, - db_home_abbr o, - db_away_abbr o, - db_home_team_name o, - db_away_team_name o, - db_home_starter o, - db_away_starter o, - db_game_date o, - db_home_game_key o, - db_away_game_key o, - db_current_timestamp o, - db_live o, - n1,n2,n3,n4,n5) + to_tuple' o = (db_list_date o, + db_info_home_team_id o, + db_info_away_team_id o, + db_home_abbr o, + db_away_abbr o, + db_home_team_name o, + db_away_team_name o, + db_home_starter o, + db_away_starter o, + db_game_date o, + db_home_game_key o, + db_away_game_key o, + db_current_timestamp o, + db_live o, + n1,n2,n3,n4,n5) where note_lines = split "\n" (db_notes o) n1 = case note_lines of @@ -551,15 +545,13 @@ pickle_odds_info = pickle_home_team :: PU HTeam pickle_home_team = xpElem "hteam" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. (xpAttr "abbr" (xpOption xpText)) -- Some are blank (xpOption xpText) -- Yup, some are nameless where from_tuple = HTeam . (uncurryN Team) - to_tuple (HTeam t) = (team_id t, - abbreviation t, - name t) + to_tuple' (HTeam t) = H.convert t -- | (Un)pickle an away team to/from the dual XML/DB representation @@ -568,28 +560,26 @@ pickle_home_team = pickle_away_team :: PU VTeam pickle_away_team = xpElem "vteam" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. (xpAttr "abbr" (xpOption xpText)) -- Some are blank (xpOption xpText) -- Yup, some are nameless where from_tuple = VTeam . (uncurryN Team) - to_tuple (VTeam t) = (team_id t, - abbreviation t, - name t) + to_tuple' (VTeam t) = H.convert t pickle_status :: PU JFileGameStatus pickle_status = xpElem "status" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "numeral" xpInt) (xpOption xpText) where from_tuple = uncurry JFileGameStatus - to_tuple s = (db_status_numeral s, - db_status s) + -- Avoid unused field warnings. + to_tuple' JFileGameStatus{..} = (db_status_numeral, db_status) -- @@ -671,7 +661,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" let c = undefined :: JFileGame actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b migrate c