X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FEarlyLine.hs;h=fe11b980f5503a9a0bf5373fe04ec2638b3721a9;hb=fdd85d5ed7944e6a6373c99c2e341f370cd931f8;hp=b0d118d046f0905134ad9c91324188b3d55d3103;hpb=fcc8c66fa433134d374f9347329ffa122ad0e4be;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs index b0d118d..fe11b98 100644 --- a/src/TSN/XML/EarlyLine.hs +++ b/src/TSN/XML/EarlyLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -36,19 +37,19 @@ where import Control.Monad ( join ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, insert_, - 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 ( @@ -66,10 +67,12 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. +import Misc ( double_just ) import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_ambiguous_time, + xp_attr_option, xp_early_line_date, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..) ) @@ -120,7 +123,11 @@ data Message = xml_title :: String, xml_dates :: [EarlyLineDate], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'H.convert'. +-- +instance H.HVector Message instance ToDb Message where @@ -171,10 +178,21 @@ instance XmlImport Message -- with. But it allows us to pickle and unpickle correctly at least. -- data EarlyLineGameWithNote = - EarlyLineGameWithNote { - date_note :: Maybe String, - date_game :: EarlyLineGameXml } - deriving (Eq, Show) + EarlyLineGameWithNote + (Maybe String) -- date_note, unused + EarlyLineGameXml -- date_game + deriving (Eq, GHC.Generic, Show) + +-- | Accessor for the game within a 'EarlyLineGameWithNote'. We define +-- this ourselves to avoid an unused field warning for date_note. +-- +date_game :: EarlyLineGameWithNote -> EarlyLineGameXml +date_game (EarlyLineGameWithNote _ g) = g + +-- | For 'H.convert'. +-- +instance H.HVector EarlyLineGameWithNote + -- | XML representation of a \. It has a \"value\" attribute @@ -186,7 +204,11 @@ data EarlyLineDate = EarlyLineDate { date_value :: UTCTime, date_games_with_notes :: [EarlyLineGameWithNote] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'H.convert'. +-- +instance H.HVector EarlyLineDate @@ -232,8 +254,12 @@ data EarlyLineGameXml = xml_away_team :: EarlyLineGameTeamXml, xml_home_team :: EarlyLineGameTeamXml, xml_over_under :: Maybe String } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'H.convert'. +-- +instance H.HVector EarlyLineGameXml -- * EarlyLineGameTeam / EarlyLineGameTeamXml @@ -250,7 +276,7 @@ data EarlyLineGameXml = -- data EarlyLineGameTeam = EarlyLineGameTeam { - db_rotation_number :: Int, + db_rotation_number :: Maybe Int, -- ^ Usually there but sometimes empty. db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\". db_team_name :: Maybe String, -- ^ NOT optional, see the data type docs. db_pitcher :: Maybe String -- ^ Optional in MLB_earlylineXML.dtd, @@ -281,7 +307,7 @@ data EarlyLineGameTeam = -- data EarlyLineGameTeamXml = EarlyLineGameTeamXml { - xml_rotation_number :: Int, + xml_rotation_number :: Maybe Int, xml_line_attr :: Maybe String, xml_team_name_attr :: Maybe String, xml_team_name_text :: Maybe String, @@ -351,21 +377,21 @@ date_to_games fk date = -- with the day portion of the supplied @date@. If not, then we -- just use @date as-is. -- - combine_date_time :: EarlyLineGameXml -> UTCTime - combine_date_time (EarlyLineGameXml (Just t) _ _ _) = + combine_date_time :: Maybe UTCTime -> UTCTime + combine_date_time (Just t) = UTCTime (utctDay $ date_value date) (utctDayTime t) - combine_date_time (EarlyLineGameXml Nothing _ _ _ ) = date_value date + combine_date_time Nothing = date_value date -- | Convert an XML game to a database one. -- convert_game :: EarlyLineGameXml -> EarlyLineGame - convert_game gx = + convert_game EarlyLineGameXml{..} = EarlyLineGame { db_early_lines_id = fk, - db_game_time = combine_date_time gx, - db_away_team = from_xml (xml_away_team gx), - db_home_team = from_xml (xml_home_team gx), - db_over_under = xml_over_under gx } + db_game_time = combine_date_time xml_game_time, + db_away_team = from_xml xml_away_team, + db_home_team = from_xml xml_home_team, + db_over_under = xml_over_under } -- @@ -454,7 +480,7 @@ mkPersist tsn_codegen_config [groundhog| pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp7Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) @@ -464,13 +490,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_dates m, - xml_time_stamp m) @@ -479,12 +498,11 @@ pickle_message = -- pickle_game_with_note :: PU EarlyLineGameWithNote pickle_game_with_note = - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpOption $ xpElem "note" xpText) pickle_game where from_tuple = uncurry EarlyLineGameWithNote - to_tuple m = (date_note m, date_game m) -- | Pickler for the \ elements within each \. @@ -492,12 +510,11 @@ pickle_game_with_note = pickle_date :: PU EarlyLineDate pickle_date = xpElem "date" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "value" xp_early_line_date) (xpList pickle_game_with_note) where from_tuple = uncurry EarlyLineDate - to_tuple m = (date_value m, date_games_with_notes m) @@ -506,17 +523,13 @@ pickle_date = pickle_game :: PU EarlyLineGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp4Tuple (xpElem "time" (xpOption xp_ambiguous_time)) pickle_away_team pickle_home_team (xpElem "over_under" (xpOption xpText)) where from_tuple = uncurryN EarlyLineGameXml - to_tuple m = (xml_game_time m, - xml_away_team m, - xml_home_team m, - xml_over_under m) @@ -547,8 +560,8 @@ pickle_home_team = xpElem "teamH" pickle_team -- pickle_team :: PU EarlyLineGameTeamXml pickle_team = - xpWrap (from_tuple, to_tuple) $ - xp6Tuple (xpAttr "rotation" xpInt) + xpWrap (from_tuple, to_tuple') $ + xp6Tuple (xpAttr "rotation" xp_attr_option) (xpOption $ xpAttr "line" (xpOption xpText)) (xpOption $ xpAttr "name" xpText) (xpOption xpText) @@ -558,12 +571,8 @@ pickle_team = from_tuple (u,v,w,x,y,z) = EarlyLineGameTeamXml u (join v) w x (join y) (join z) - to_tuple (EarlyLineGameTeamXml u v w x y z) = + to_tuple' (EarlyLineGameTeamXml u v w x y z) = (u, double_just v, w, x, double_just y, double_just z) - where - double_just val = case val of - Nothing -> Nothing - just_something -> Just just_something @@ -587,7 +596,7 @@ early_line_tests = -- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree -test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $ +test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" "test/xml/earlylineXML.xml", @@ -603,7 +612,7 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" $ -- | Make sure we can actually unpickle these things. -- test_unpickle_succeeds :: TestTree -test_unpickle_succeeds = testGroup "unpickle tests" $ +test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" "test/xml/earlylineXML.xml", @@ -621,7 +630,7 @@ test_unpickle_succeeds = testGroup "unpickle tests" $ -- record. -- test_on_delete_cascade :: TestTree -test_on_delete_cascade = testGroup "cascading delete tests" $ +test_on_delete_cascade = testGroup "cascading delete tests" [ check "deleting early_lines deletes its children" "test/xml/earlylineXML.xml", @@ -634,7 +643,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" $ let b = undefined :: EarlyLineGame actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b _ <- dbimport results