+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
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 Generics ( Generic(..), to_tuple )
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.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 'Generics.to_tuple'.
+--
+instance Generic 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 'Generics.to_tuple'.
+--
+instance Generic ScoreGameXml
instance ToDb ScoreGameXml where
db_home_team_id = fk_home,
db_away_team_score = xml_away_team_score,
db_home_team_score = xml_home_team_score,
- db_away_team_pitcher = (xml_vpitcher $ xml_vteam),
- db_home_team_pitcher = (xml_hpitcher $ xml_hteam),
+ db_away_team_pitcher = xml_vpitcher xml_vteam,
+ db_home_team_pitcher = xml_hpitcher xml_hteam,
db_time_r = xml_time_r,
db_status = xml_status,
db_notes = xml_notes }
(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" $ xpOption xpInt)
+ (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, s, db_status_text)
+ where
+ s = case db_status_type of
+ Nothing -> Nothing
+ Just _ -> Just db_status_type
-- | Convert a 'ScoreGameXml' to/from \<game\>.
(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) Nothing) = (team_id t, Nothing, name t)
+ to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, 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
projects / dead / htsn-import.git / blobdiff