+{-# 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.Picklers ( xp_attr_option, xp_time_stamp )
import TSN.Team (
FromXmlFkTeams(..),
HTeam(..),
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'.
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)
-
pickle_status :: PU ScoreGameStatus
pickle_status =
xpElem "status" $
- xpWrap (from_tuple, to_tuple) $
- xpTriple (xpAttr "numeral" $ xpOption xpInt)
+ xpWrap (from_tuple, to_tuple') $
+ xpTriple (xpAttr "numeral" xp_attr_option)
(xpOption $ xpAttr "type" $ xpOption xpText)
xpText
where
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
+ 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)
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