+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
+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 (
xpWrap )
-- Local imports.
+import Misc ( double_just )
import TSN.Codegen ( tsn_codegen_config )
import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Location ( Location(..), pickle_location )
-import TSN.Picklers ( xp_time_stamp )
-import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
+import TSN.Picklers ( xp_attr_option, xp_time_stamp )
+import TSN.Team (
+ FromXmlFkTeams(..),
+ HTeam(..),
+ Team(..),
+ VTeam(..) )
import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
import Xml (
Child(..),
FromXml(..),
- FromXmlFkTeams(..),
ToDb(..),
pickle_unpickle,
unpickleable,
xml_season_type :: Maybe String, -- ^ We've seen an empty one
xml_game :: ScoreGameXml,
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
+
instance ToDb Message where
-- | The database representation of a 'Message' is a 'Score'.
--
data ScoreGameStatus =
ScoreGameStatus {
- db_status_numeral :: Int,
+ db_status_numeral :: Maybe Int,
db_status_type :: Maybe String, -- ^ These are probably only one-character,
-- long, but they all take the same
-- amount of space in Postgres.
xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
xml_status :: ScoreGameStatus,
xml_notes :: Maybe String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector ScoreGameXml
instance ToDb ScoreGameXml where
-- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three
-- foreign keys: the parent message, and the away/home teams.
--
+ -- During conversion, we also get the pitchers out of the teams;
+ -- unfortunately this prevents us from making the conversion
+ -- generically.
+ --
from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} =
ScoreGame {
db_scores_id = fk,
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp11Tuple (xpElem "XML_File_ID" xpInt)
(xpElem "heading" xpText)
(xpElem "game_id" (xpOption xpInt))
(xpElem "time_stamp" xp_time_stamp)
where
from_tuple = uncurryN Message
- to_tuple m = (xml_xml_file_id m,
- xml_heading m,
- xml_game_id m,
- xml_schedule_id m,
- xml_tsnupdate m,
- xml_category m,
- xml_sport m,
- xml_locations m,
- xml_season_type m,
- xml_game m,
- xml_time_stamp m)
-
--- | Convert a 'ScoreGameStatus' to/from \<status\>.
+-- | Convert a 'ScoreGameStatus' to/from \<status\>. The \"type\"
+-- attribute can be either missing or empty, so we're really parsing
+-- a double-Maybe here. We use the monad join to collapse it into
+-- one. See also: the hteam/vteam picklers.
--
pickle_status :: PU ScoreGameStatus
pickle_status =
xpElem "status" $
- xpWrap (from_tuple, to_tuple) $
- xpTriple (xpAttr "numeral" xpInt)
- (xpOption $ xpAttr "type" xpText)
+ xpWrap (from_tuple, to_tuple') $
+ xpTriple (xpAttr "numeral" xp_attr_option)
+ (xpOption $ xpAttr "type" $ xpOption xpText)
xpText
where
- from_tuple = uncurryN ScoreGameStatus
- to_tuple ScoreGameStatus{..} = (db_status_numeral,
- db_status_type,
- db_status_text)
+ from_tuple (x,y,z) = ScoreGameStatus x (join y) z
+ to_tuple' ScoreGameStatus{..} =
+ (db_status_numeral, double_just db_status_type, db_status_text)
-- | Convert a 'ScoreGameXml' to/from \<game\>.
pickle_game :: PU ScoreGameXml
pickle_game =
xpElem "game" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp7Tuple pickle_vteam
pickle_hteam
(xpElem "vscore" xpInt)
(xpOption $ xpElem "notes" xpText)
where
from_tuple = uncurryN ScoreGameXml
- to_tuple ScoreGameXml{..} = (xml_vteam,
- xml_hteam,
- xml_away_team_score,
- xml_home_team_score,
- xml_time_r,
- xml_status,
- xml_notes)
-- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
pickle_vteam :: PU VTeamXml
pickle_vteam =
xpElem "vteam" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpTriple (xpAttr "id" xpText)
(xpOption $ xpAttr "pitcher" (xpOption xpText))
(xpOption xpText) -- Team name
where
from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y)
- to_tuple (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
- to_tuple (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)
+ to_tuple' (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
+ to_tuple' (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)
-- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
pickle_hteam :: PU HTeamXml
pickle_hteam =
xpElem "hteam" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpTriple (xpAttr "id" xpText)
(xpOption $ xpAttr "pitcher" (xpOption xpText))
(xpOption xpText) -- Team name
where
from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
- to_tuple (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t)
- to_tuple (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t)
+ to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, double_just jhp, name t)
"test/xml/scoresxml-no-locations.xml",
check "pickle composed with unpickle is the identity (pitcher, no type)"
- "test/xml/scoresxml-pitcher-no-type.xml"]
+ "test/xml/scoresxml-pitcher-no-type.xml",
+
+ check "pickle composed with unpickle is the identity (empty numeral)"
+ "test/xml/scoresxml-empty-numeral.xml",
+
+ check "pickle composed with unpickle is the identity (empty type)"
+ "test/xml/scoresxml-empty-type.xml" ]
where
check desc path = testCase desc $ do
(expected, actual) <- pickle_unpickle pickle_message path
"test/xml/scoresxml-no-locations.xml",
check "unpickling succeeds (pitcher, no type)"
- "test/xml/scoresxml-pitcher-no-type.xml" ]
+ "test/xml/scoresxml-pitcher-no-type.xml",
+
+ check "unpickling succeeds (empty numeral)"
+ "test/xml/scoresxml-empty-numeral.xml",
+
+ check "unpickling succeeds (empty type)"
+ "test/xml/scoresxml-empty-type.xml" ]
where
check desc path = testCase desc $ do
actual <- unpickleable path pickle_message
check "unpickling succeeds (pitcher, no type)"
"test/xml/scoresxml-pitcher-no-type.xml"
- 3 -- 2 teams, 1 location
+ 3, -- 2 teams, 1 location
+
+ check "unpickling succeeds (empty numeral)"
+ "test/xml/scoresxml-empty-numeral.xml"
+ 3, -- 2 teams, 1 location
+
+ check "unpickling succeeds (empty type)"
+ "test/xml/scoresxml-empty-type.xml"
+ 4 -- 2 teams, 2 locations
]
where
check desc path expected = testCase desc $ do
let d = undefined :: ScoreGame
let e = undefined :: Score_Location
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
migrate c
projects / dead / htsn-import.git / blobdiff