+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
where
-- System imports
-import Control.Monad ( forM_ )
+import Control.Monad ( forM_, join )
import Data.List ( intercalate )
import Data.String.Utils ( split )
import Data.Time ( UTCTime(..) )
import Data.Tuple.Curry ( uncurryN )
+import qualified Data.Vector.HFixed as H ( HVector, convert )
import Database.Groundhog (
countAll,
deleteAll,
- 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 (
-- 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 )
xp_date,
xp_date_padded,
xp_datetime,
- xp_time,
+ xp_tba_time,
xp_time_dots,
xp_time_stamp )
import TSN.Team (
xml_sport :: String,
xml_gamelist :: JFileGameListXml,
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
instance ToDb Message where
deriving (Eq, Show)
+
-- | Database representation of a \<game\> contained within a
-- \<message\>, and, implicitly, a \<gamelist\>.
--
db_schedule_id :: Int,
db_odds_info :: JFileGameOddsInfo,
db_season_type :: Maybe String,
- db_game_time :: UTCTime,
+ db_game_time :: Maybe UTCTime,
db_vleague :: Maybe String,
db_hleague :: Maybe String,
db_vscore :: Int,
xml_odds_info :: JFileGameOddsInfo,
xml_season_type :: Maybe String,
xml_game_date :: UTCTime,
- xml_game_time :: UTCTime,
+ xml_game_time :: Maybe UTCTime,
xml_vteam :: VTeam,
xml_vleague :: Maybe String,
xml_hteam :: HTeam,
xml_hscore :: Int,
xml_time_remaining :: Maybe String,
xml_game_status :: JFileGameStatus }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector JFileGameXml
-- * JFileGameListXml
db_time_remaining = xml_time_remaining,
db_game_status = xml_game_status }
where
- -- | Make the database \"game time\" from the XML
- -- date/time. Simply take the day part from one and the time
- -- from the other.
- --
- make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
+ -- | Construct the database game time from the XML \<Game_Date\>
+ -- and \<Game_Time\> elements. The \<Game_Time\> elements
+ -- sometimes have a value of \"TBA\"; in that case, we don't
+ -- want to pretend that we know the time by setting it to
+ -- e.g. midnight, so instead we make the entire date/time
+ -- Nothing.
+ make_game_time :: UTCTime -> Maybe UTCTime -> Maybe UTCTime
+ make_game_time _ Nothing = Nothing
+ make_game_time d (Just t) = Just $ UTCTime (utctDay d) (utctDayTime t)
-- | This allows us to insert the XML representation
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp6Tuple (xpElem "XML_File_ID" xpInt)
(xpElem "heading" xpText)
(xpElem "category" xpText)
(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_gamelist m,
- xml_time_stamp m)
+
pickle_gamelist :: PU JFileGameListXml
pickle_gamelist =
pickle_game :: PU JFileGameXml
pickle_game =
xpElem "game" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xp14Tuple (xpElem "game_id" xpInt)
(xpElem "schedule_id" xpInt)
pickle_odds_info
(xpElem "seasontype" (xpOption xpText))
(xpElem "Game_Date" xp_date_padded)
- (xpElem "Game_Time" xp_time)
+ (xpElem "Game_Time" xp_tba_time)
pickle_away_team
- (xpOption $ xpElem "vleague" xpText)
+ (xpOption $ xpElem "vleague" (xpOption xpText))
pickle_home_team
(xpOption $ xpElem "hleague" xpText)
(xpElem "vscore" xpInt)
(xpOption $ xpElem "time_r" xpText)
pickle_status
where
- from_tuple = uncurryN JFileGameXml
- to_tuple m = (xml_game_id m,
- xml_schedule_id m,
- xml_odds_info m,
- xml_season_type m,
- xml_game_date m,
- xml_game_time m,
- xml_vteam m,
- xml_vleague m,
- xml_hteam m,
- xml_hleague m,
- xml_vscore m,
- xml_hscore m,
- xml_time_remaining m,
- xml_game_status m)
+ from_tuple (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =
+ JFileGameXml a b c d e f g (join h) i j k l m n
+
+ to_tuple' (JFileGameXml a b c d e f g h i j k l m n) =
+ (a, b, c, d, e, f, g, double_just h, i, j, k, l, m, n)
+
pickle_odds_info :: PU JFileGameOddsInfo
pickle_odds_info =
xpElem "Odds_Info" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xp19Tuple (xpElem "ListDate" (xpOption xp_date))
(xpElem "HomeTeamID" (xpOption xpText))
(xpElem "AwayTeamID" (xpOption xpText))
where
notes = intercalate "\n" [n1,n2,n3,n4,n5]
- to_tuple o = (db_list_date o,
- db_info_home_team_id o,
- db_info_away_team_id o,
- db_home_abbr o,
- db_away_abbr o,
- db_home_team_name o,
- db_away_team_name o,
- db_home_starter o,
- db_away_starter o,
- db_game_date o,
- db_home_game_key o,
- db_away_game_key o,
- db_current_timestamp o,
- db_live o,
- n1,n2,n3,n4,n5)
+ to_tuple' o = (db_list_date o,
+ db_info_home_team_id o,
+ db_info_away_team_id o,
+ db_home_abbr o,
+ db_away_abbr o,
+ db_home_team_name o,
+ db_away_team_name o,
+ db_home_starter o,
+ db_away_starter o,
+ db_game_date o,
+ db_home_game_key o,
+ db_away_game_key o,
+ db_current_timestamp o,
+ db_live o,
+ n1,n2,n3,n4,n5)
where
note_lines = split "\n" (db_notes o)
n1 = case note_lines of
pickle_home_team :: PU HTeam
pickle_home_team =
xpElem "hteam" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
(xpAttr "abbr" (xpOption xpText)) -- Some are blank
(xpOption xpText) -- Yup, some are nameless
where
from_tuple = HTeam . (uncurryN Team)
- to_tuple (HTeam t) = (team_id t,
- abbreviation t,
- name t)
+ to_tuple' (HTeam t) = H.convert t
-- | (Un)pickle an away team to/from the dual XML/DB representation
pickle_away_team :: PU VTeam
pickle_away_team =
xpElem "vteam" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
(xpAttr "abbr" (xpOption xpText)) -- Some are blank
(xpOption xpText) -- Yup, some are nameless
where
from_tuple = VTeam . (uncurryN Team)
- to_tuple (VTeam t) = (team_id t,
- abbreviation t,
- name t)
+ to_tuple' (VTeam t) = H.convert t
pickle_status :: PU JFileGameStatus
pickle_status =
xpElem "status" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpPair (xpAttr "numeral" xpInt)
(xpOption xpText)
where
from_tuple = uncurry JFileGameStatus
- to_tuple s = (db_status_numeral s,
- db_status s)
+ -- Avoid unused field warnings.
+ to_tuple' JFileGameStatus{..} = (db_status_numeral, db_status)
--
[ check "pickle composed with unpickle is the identity"
"test/xml/jfilexml.xml",
check "pickle composed with unpickle is the identity (missing fields)"
- "test/xml/jfilexml-missing-fields.xml" ]
+ "test/xml/jfilexml-missing-fields.xml",
+
+ check "pickle composed with unpickle is the identity (TBA game time)"
+ "test/xml/jfilexml-tba-game-time.xml"]
where
check desc path = testCase desc $ do
(expected, actual) <- pickle_unpickle pickle_message path
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds = testGroup "unpickle tests"
[ check "unpickling succeeds" "test/xml/jfilexml.xml",
+
check "unpickling succeeds (missing fields)"
- "test/xml/jfilexml-missing-fields.xml" ]
+ "test/xml/jfilexml-missing-fields.xml",
+
+ check "unpickling succeeds (TBA game time)"
+ "test/xml/jfilexml-tba-game-time.xml" ]
where
check desc path = testCase desc $ do
actual <- unpickleable path pickle_message
test_on_delete_cascade = testGroup "cascading delete tests"
[ check "deleting auto_racing_results deletes its children"
"test/xml/jfilexml.xml"
- 20,
+ 20, -- teams
+
check "deleting auto_racing_results deletes its children (missing fields)"
"test/xml/jfilexml-missing-fields.xml"
- 44 ]
+ 44,
+
+ check "deleting auto_racing_results deletes its children (TBA game time)"
+ "test/xml/jfilexml-tba-game-time.xml"
+ 8 ]
where
check desc path expected = testCase desc $ do
results <- unsafe_unpickle path pickle_message
let c = undefined :: JFileGame
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
migrate c
projects / dead / htsn-import.git / blobdiff