+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
-- * Tests
scores_tests,
-- * WARNING: these are private but exported to silence warnings
- Score_ScoreLocationConstructor(..),
+ Score_LocationConstructor(..),
ScoreConstructor(..),
- ScoreGameConstructor(..),
- ScoreGameTeamConstructor(..),
- ScoreLocationConstructor(..),
- ScoreGame_ScoreGameTeamConstructor(..) )
+ ScoreGameConstructor(..) )
where
-- System imports.
+import Control.Monad ( join )
import Data.Data ( Data )
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,
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 (
- defaultCodegenConfig,
groundhog,
mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
xpInt,
xpList,
xpOption,
- xpPair,
xpPrim,
xpText,
xpTriple,
xpWrap )
-- Local imports.
-import TSN.Codegen (
- tsn_codegen_config )
+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.Picklers ( xp_time_stamp )
-import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import TSN.Location ( Location(..), pickle_location )
+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(..),
- FromXmlFk(..),
ToDb(..),
pickle_unpickle,
unpickleable,
dtd = "scoresxml.dtd"
----
---- DB/XML Data types
----
+--
+-- * DB/XML Data types
+--
-- * Score / Message
Score {
db_xml_file_id :: Int,
db_heading :: String,
- db_game_id :: Int,
- db_schedule_id :: Int,
+ db_game_id :: Maybe Int, -- ^ We've seen an empty one
+ db_schedule_id :: Maybe Int, -- ^ We've seen an empty one
db_tsnupdate :: Maybe Bool,
db_category :: String,
db_sport :: String,
- db_season_type :: String,
+ db_season_type :: Maybe String, -- ^ We've seen an empty one
db_time_stamp :: UTCTime }
Message {
xml_xml_file_id :: Int,
xml_heading :: String,
- xml_game_id :: Int,
- xml_schedule_id :: Int,
+ xml_game_id :: Maybe Int, -- ^ We've seen an empty one
+ xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one
xml_tsnupdate :: Maybe Bool,
xml_category :: String,
xml_sport :: String,
- xml_locations :: [ScoreLocation],
- xml_season_type :: String,
+ xml_locations :: [Location],
+ 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'.
type Db Message = Score
instance FromXml Message where
+ -- | When converting from the XML representation to the database
+ -- one, we drop the list of locations which will be foreign-keyed to
+ -- us instead.
from_xml Message{..} =
Score {
db_xml_file_id = xml_xml_file_id,
--
data ScoreGameStatus =
ScoreGameStatus {
- db_status_numeral :: Int,
- db_status_type :: String, -- ^ These are probably only one-character long,
- -- but they all take the same amount of space
- -- in Postgres.
+ 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.
db_status_text :: String }
deriving (Data, Eq, Show, Typeable)
data ScoreGame =
ScoreGame {
db_scores_id :: DefaultKey Score,
- db_vscore :: Int,
- db_hscore :: Int,
+ db_away_team_id :: DefaultKey Team,
+ db_home_team_id :: DefaultKey Team,
+ db_away_team_score :: Int,
+ db_home_team_score :: Int,
+ db_away_team_pitcher :: Maybe String, -- ^ Found in the child \<vteam\>
+ db_home_team_pitcher :: Maybe String, -- ^ Found in the child \<hteam\>
db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
db_status :: ScoreGameStatus,
db_notes :: Maybe String }
--
data ScoreGameXml =
ScoreGameXml {
- xml_vteam :: ScoreGameVTeam,
- xml_hteam :: ScoreGameHTeam,
- xml_vscore :: Int,
- xml_hscore :: Int,
+ xml_vteam :: VTeamXml,
+ xml_hteam :: HTeamXml,
+ xml_away_team_score :: Int,
+ xml_home_team_score :: Int,
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)
--- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
-vteam :: ScoreGameXml -> ScoreGameTeam
-vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
--- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
-hteam :: ScoreGameXml -> ScoreGameTeam
-hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
+-- | For 'H.convert'.
+--
+instance H.HVector ScoreGameXml
+
instance ToDb ScoreGameXml where
-- | The database representation of a 'ScoreGameXml' is a
--
type Db ScoreGameXml = ScoreGame
-instance FromXmlFk ScoreGameXml where
+
+instance Child ScoreGameXml where
-- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
-- a 'Score'.
--
type Parent ScoreGameXml = Score
- from_xml_fk fk ScoreGameXml{..} =
+
+instance FromXmlFkTeams 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,
- db_vscore = xml_vscore,
- db_hscore = xml_hscore,
+ db_away_team_id = fk_away,
+ 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_time_r = xml_time_r,
db_status = xml_status,
db_notes = xml_notes }
-- | This lets us import the database representation 'ScoreGameXml'
-- directly.
--
-instance XmlImportFk ScoreGameXml
+instance XmlImportFkTeams ScoreGameXml
--- * ScoreGameTeam
--- | A team that appears in a 'ScoreGame'. This is meant to represent
--- both home and away teams.
---
-data ScoreGameTeam =
- ScoreGameTeam {
- team_id :: String,
- team_name :: String }
- deriving (Eq, Show)
+-- * Score_Location
--- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
--- home and away teams. See also 'ScoreGameHTeam'.
+-- | Join each 'Score' with its 'Location's. Database-only. We use a
+-- join table because the locations are kept unique but there are
+-- multiple locations per 'Score'.
--
-newtype ScoreGameVTeam =
- ScoreGameVTeam ScoreGameTeam
- deriving (Eq, Show)
+data Score_Location =
+ Score_Location
+ (DefaultKey Score)
+ (DefaultKey Location)
+
+-- * HTeamXml / VTeamXml
--- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
--- home and away teams. See also 'ScoreGameVTeam'.
+-- | XML Representation of a home team. This document type is unusual
+-- in that the \<hteam\> elements can have a pitcher attribute
+-- attached to them. We still want to maintain the underlying 'Team'
+-- representation, so we say that a home team is a 'Team' and
+-- (maybe) a pitcher.
--
-newtype ScoreGameHTeam =
- ScoreGameHTeam ScoreGameTeam
+data HTeamXml =
+ HTeamXml {
+ xml_ht :: HTeam,
+ xml_hpitcher :: Maybe String }
deriving (Eq, Show)
+instance ToDb HTeamXml where
+ -- | The database analogue of a 'HTeamXml' is its 'Team'.
+ type Db HTeamXml = Team
--- * ScoreGame_ScoreGameTeam
+instance FromXml HTeamXml where
+ -- | The conversion from XML to database is simply the 'Team' accessor.
+ --
+ from_xml = hteam . xml_ht
--- | Join a 'ScoreGame' with its home/away teams. Database-only. We
--- use a join table because the teams are kept unique.
+-- | Allow import of the XML representation directly, without
+-- requiring a manual conversion to the database type first.
--
-data ScoreGame_ScoreGameTeam =
- ScoreGame_ScoreGameTeam
- (DefaultKey ScoreGame) -- ^ game id
- (DefaultKey ScoreGameTeam) -- ^ vteam id
- (DefaultKey ScoreGameTeam) -- ^ hteam id
+instance XmlImport HTeamXml
--- * ScoreLocation
--- | Database and XML representation of a \<location\>. This is almost
--- identical to 'TSN.XML.NewsLocation', but the city/state have not
--- appeared optional here so far.
+-- | XML Representation of an away team. This document type is unusual
+-- in that the \<hteam\> elements can have a pitcher attribute
+-- attached to them. We still want to maintain the underlying 'Team'
+-- representation, so we say that an away team is a 'Team' and
+-- (maybe) a pitcher.
--
-data ScoreLocation =
- ScoreLocation {
- city :: String,
- state :: String,
- country :: String }
+data VTeamXml =
+ VTeamXml {
+ xml_vt :: VTeam,
+ xml_vpitcher :: Maybe String }
deriving (Eq, Show)
+instance ToDb VTeamXml where
+ -- | The database analogue of a 'VTeamXml' is its 'Team'.
+ type Db VTeamXml = Team
--- * Score_ScoreLocation
+instance FromXml VTeamXml where
+ -- | The conversion from XML to database is simply the 'Team' accessor.
+ --
+ from_xml = vteam . xml_vt
--- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
--- use a join table because the locations are kept unique.
+-- | Allow import of the XML representation directly, without
+-- requiring a manual conversion to the database type first.
--
-data Score_ScoreLocation =
- Score_ScoreLocation
- (DefaultKey Score)
- (DefaultKey ScoreLocation)
+instance XmlImport VTeamXml
instance DbImport Message where
dbmigrate _ =
run_dbmigrate $ do
+ migrate (undefined :: Location)
+ migrate (undefined :: Team)
migrate (undefined :: Score)
migrate (undefined :: ScoreGame)
- migrate (undefined :: ScoreGameTeam)
- migrate (undefined :: ScoreGame_ScoreGameTeam)
- migrate (undefined :: ScoreLocation)
- migrate (undefined :: Score_ScoreLocation)
+ migrate (undefined :: Score_Location)
dbimport m = do
-- Insert the message and get its ID.
msg_id <- insert_xml m
-- Insert all of the locations contained within this message and
- -- collect their IDs in a list.
- location_ids <- mapM insert (xml_locations m)
+ -- collect their IDs in a list. We use insert_or_select because
+ -- most of the locations will already exist, and we just want to
+ -- get the ID of the existing location when there's a collision.
+ location_ids <- mapM insert_or_select (xml_locations m)
-- Now use that list to construct 'Score_ScoreLocation' objects,
-- and insert them.
- mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
+ mapM_ (insert_ . Score_Location msg_id) location_ids
- -- Insert the game and its hteam/vteam, noting the IDs.
- game_id <- insert_xml_fk msg_id (xml_game m)
- vteam_id <- insert (vteam $ xml_game m)
- hteam_id <- insert (hteam $ xml_game m)
+ -- Insert the hteam/vteams, noting the IDs.
+ vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m)
+ hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m)
- -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
- -- aforementioned game to its hteam/vteam.
- insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
+ -- Now use those along with the msg_id to construct the game.
+ insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m)
return ImportSucceeded
--- These types don't have special XML representations or field name
--- collisions so we use the defaultCodegenConfig and give their
--- fields nice simple names.
-mkPersist defaultCodegenConfig [groundhog|
-- entity: ScoreGameTeam
- dbName: scores_games_teams
- constructors:
- - name: ScoreGameTeam
- uniques:
- - name: unique_scores_games_team
- type: constraint
- fields: [team_id]
-
-- entity: ScoreLocation
- dbName: scores_locations
- constructors:
- - name: ScoreLocation
- uniques:
- - name: unique_scores_location
- type: constraint
- fields: [city, state, country]
-
-|]
-
-
-- These types have fields with e.g. db_ and xml_ prefixes, so we
-- use our own codegen to peel those off before naming the columns.
- name: db_status_text
dbName: status_text
+
- entity: ScoreGame
dbName: scores_games
constructors:
- { name: status_type, dbName: status_type }
- { name: status_text, dbName: status_text }
-- entity: ScoreGame_ScoreGameTeam
- dbName: scores_games__scores_games_teams
- constructors:
- - name: ScoreGame_ScoreGameTeam
- fields:
- - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
- dbName: scores_games_id
- reference:
- onDelete: cascade
- - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
- dbName: scores_games_teams_vteam_id
- reference:
- onDelete: cascade
- - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
- dbName: scores_games_teams_hteam_id
- reference:
- onDelete: cascade
-- entity: Score_ScoreLocation
- dbName: scores__scores_locations
+- entity: Score_Location
+ dbName: scores__locations
constructors:
- - name: Score_ScoreLocation
+ - name: Score_Location
fields:
- - name: score_ScoreLocation0 # Default created by mkNormalFieldName
+ - name: score_Location0 # Default created by mkNormalFieldName
dbName: scores_id
reference:
onDelete: cascade
- - name: score_ScoreLocation1 # Default created by mkNormalFieldName
- dbName: scores_locations_id
+ - name: score_Location1 # Default created by mkNormalFieldName
+ dbName: locations_id
reference:
onDelete: cascade
|]
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" xpInt)
- (xpElem "schedule_id" xpInt)
+ (xpElem "game_id" (xpOption xpInt))
+ (xpElem "schedule_id" (xpOption xpInt))
(xpOption $ xpElem "tsnupdate" xpPrim)
(xpElem "category" xpText)
(xpElem "sport" xpText)
(xpList pickle_location)
- (xpElem "seasontype" xpText)
+ (xpElem "seasontype" (xpOption xpText))
pickle_game
(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 'ScoreLocation' to/from \<location\>.
---
-pickle_location :: PU ScoreLocation
-pickle_location =
- xpElem "location" $
- xpWrap (from_tuple, to_tuple) $
- xpTriple (xpElem "city" xpText)
- (xpElem "state" xpText)
- (xpElem "country" xpText)
- where
- from_tuple =
- uncurryN ScoreLocation
- to_tuple l = (city l, state l, country l)
--- | 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)
- (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_vscore,
- xml_hscore,
- xml_time_r,
- xml_status,
- xml_notes)
--- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
+-- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
+-- always seem to be present here, but in the shared representation,
+-- they're optional (because they show up blank elsewhere). So, we
+-- pretend they're optional.
--
-pickle_vteam :: PU ScoreGameVTeam
+-- The \"pitcher\" attribute is a little bit funny. Usually, when
+-- there's no pitcher, the attribute itself is missing. But once in
+-- a blue moon, it will be present with no text. We want to treat
+-- both cases the same, so what we really parse is a Maybe (Maybe
+-- String), and then use the monad 'join' to collapse it into a single
+-- Maybe.
+--
+pickle_vteam :: PU VTeamXml
pickle_vteam =
xpElem "vteam" $
- xpWrap (from_tuple, to_tuple) $
- xpPair (xpAttr "id" xpText)
- xpText
+ xpWrap (from_tuple, to_tuple') $
+ xpTriple (xpAttr "id" xpText)
+ (xpOption $ xpAttr "pitcher" (xpOption xpText))
+ (xpOption xpText) -- Team name
where
- from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
- to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
+ 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)
--- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
--- 'pickle_vteam' modulo the \"h\" and \"v\".
+-- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
+-- modulo the \"h\" and \"v\". The team names always seem to be
+-- present here, but in the shared representation, they're optional
+-- (because they show up blank elsewhere). So, we pretend they're
+-- optional.
--
-pickle_hteam :: PU ScoreGameHTeam
+-- The \"pitcher\" attribute is a little bit funny. Usually, when
+-- there's no pitcher, the attribute itself is missing. But once in
+-- a blue moon, it will be present with no text. We want to treat
+-- both cases the same, so what we really parse is a Maybe (Maybe
+-- String), and then use the monad 'join' to collapse it into a single
+-- Maybe.
+--
+pickle_hteam :: PU HTeamXml
pickle_hteam =
xpElem "hteam" $
- xpWrap (from_tuple, to_tuple) $
- xpPair (xpAttr "id" xpText)
- xpText
+ xpWrap (from_tuple, to_tuple') $
+ xpTriple (xpAttr "id" xpText)
+ (xpOption $ xpAttr "pitcher" (xpOption xpText))
+ (xpOption xpText) -- Team name
where
- from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
- to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
+ from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
+ to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, double_just jhp, name t)
----
---- Tasty tests
----
+--
+-- * Tasty tests
+--
-- | A list of all tests for this module.
--
"test/xml/scoresxml.xml",
check "pickle composed with unpickle is the identity (no locations)"
- "test/xml/scoresxml-no-locations.xml" ]
+ "test/xml/scoresxml-no-locations.xml",
+
+ check "pickle composed with unpickle is the identity (pitcher, no type)"
+ "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.xml",
check "unpickling succeeds (no locations)"
- "test/xml/scoresxml-no-locations.xml" ]
+ "test/xml/scoresxml-no-locations.xml",
+
+ check "unpickling succeeds (pitcher, no type)"
+ "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 (no locations)"
"test/xml/scoresxml-no-locations.xml"
- 2 -- 2 teams, 0 locations
+ 2, -- 2 teams, 0 locations
+
+ check "unpickling succeeds (pitcher, no type)"
+ "test/xml/scoresxml-pitcher-no-type.xml"
+ 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
score <- unsafe_unpickle path pickle_message
- let a = undefined :: Score
- let b = undefined :: ScoreGame
- let c = undefined :: ScoreGameTeam
- let d = undefined :: ScoreGame_ScoreGameTeam
- let e = undefined :: ScoreLocation
- let f = undefined :: Score_ScoreLocation
+ let a = undefined :: Location
+ let b = undefined :: Team
+ let c = undefined :: Score
+ 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
migrate d
migrate e
- migrate f
_ <- dbimport score
-- No idea how 'delete' works, so do this instead.
- deleteAll a
+ deleteAll c
count_a <- countAll a
count_b <- countAll b
count_c <- countAll c
count_d <- countAll d
count_e <- countAll e
- count_f <- countAll f
return $ sum [count_a, count_b, count_c,
- count_d, count_e, count_f ]
+ count_d, count_e ]
actual @?= expected
projects / dead / htsn-import.git / blobdiff