+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
import Control.Monad ( join )
import Data.Time ( UTCTime(..) )
import Data.Tuple.Curry ( uncurryN )
+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 (
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers (
xp_ambiguous_time,
+ xp_attr_option,
xp_early_line_date,
xp_time_stamp )
import TSN.XmlImport ( XmlImport(..) )
xml_title :: String,
xml_dates :: [EarlyLineDate],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
instance ToDb Message where
-- with. But it allows us to pickle and unpickle correctly at least.
--
data EarlyLineGameWithNote =
- EarlyLineGameWithNote {
- date_note :: Maybe String,
- date_game :: EarlyLineGameXml }
- deriving (Eq, Show)
+ EarlyLineGameWithNote
+ (Maybe String) -- date_note, unused
+ EarlyLineGameXml -- date_game
+ deriving (Eq, GHC.Generic, Show)
+
+-- | Accessor for the game within a 'EarlyLineGameWithNote'. We define
+-- this ourselves to avoid an unused field warning for date_note.
+--
+date_game :: EarlyLineGameWithNote -> EarlyLineGameXml
+date_game (EarlyLineGameWithNote _ g) = g
+
+-- | For 'H.convert'.
+--
+instance H.HVector EarlyLineGameWithNote
+
-- | XML representation of a \<date\>. It has a \"value\" attribute
EarlyLineDate {
date_value :: UTCTime,
date_games_with_notes :: [EarlyLineGameWithNote] }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector EarlyLineDate
--
data EarlyLineGameXml =
EarlyLineGameXml {
- xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
+ xml_game_time :: Maybe UTCTime, -- ^ Only an ambiguous time string,
+ -- e.g. \"8:30\". Can be empty.
xml_away_team :: EarlyLineGameTeamXml,
xml_home_team :: EarlyLineGameTeamXml,
xml_over_under :: Maybe String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+-- | For 'H.convert'.
+--
+instance H.HVector EarlyLineGameXml
+
-- * EarlyLineGameTeam / EarlyLineGameTeamXml
--
data EarlyLineGameTeam =
EarlyLineGameTeam {
- db_rotation_number :: Int,
+ db_rotation_number :: Maybe Int, -- ^ Usually there but sometimes empty.
db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
db_team_name :: Maybe String, -- ^ NOT optional, see the data type docs.
db_pitcher :: Maybe String -- ^ Optional in MLB_earlylineXML.dtd,
--
data EarlyLineGameTeamXml =
EarlyLineGameTeamXml {
- xml_rotation_number :: Int,
+ xml_rotation_number :: Maybe Int,
xml_line_attr :: Maybe String,
xml_team_name_attr :: Maybe String,
xml_team_name_text :: Maybe String,
games_only :: [EarlyLineGameXml]
games_only = (map date_game (date_games_with_notes date))
- -- | Stick the date value into the given game.
+ -- | Stick the date value into the given game. If our
+ -- 'EarlyLineGameXml' has an 'xml_game_time', then we combine it
+ -- with the day portion of the supplied @date@. If not, then we
+ -- just use @date as-is.
--
- combine_date_time :: EarlyLineGameXml -> UTCTime
- combine_date_time elgx =
- UTCTime (utctDay $ date_value date) (utctDayTime $ xml_game_time elgx)
+ combine_date_time :: Maybe UTCTime -> UTCTime
+ combine_date_time (Just t) =
+ UTCTime (utctDay $ date_value date) (utctDayTime t)
+ combine_date_time Nothing = date_value date
-- | Convert an XML game to a database one.
--
convert_game :: EarlyLineGameXml -> EarlyLineGame
- convert_game gx =
+ convert_game EarlyLineGameXml{..} =
EarlyLineGame {
db_early_lines_id = fk,
- db_game_time = combine_date_time gx,
- db_away_team = from_xml (xml_away_team gx),
- db_home_team = from_xml (xml_home_team gx),
- db_over_under = xml_over_under gx }
+ db_game_time = combine_date_time xml_game_time,
+ db_away_team = from_xml xml_away_team,
+ db_home_team = from_xml xml_home_team,
+ db_over_under = xml_over_under }
--
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp7Tuple (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_title m,
- xml_dates m,
- xml_time_stamp m)
--
pickle_game_with_note :: PU EarlyLineGameWithNote
pickle_game_with_note =
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpPair (xpOption $ xpElem "note" xpText)
pickle_game
where
from_tuple = uncurry EarlyLineGameWithNote
- to_tuple m = (date_note m, date_game m)
-- | Pickler for the \<date\> elements within each \<message\>.
pickle_date :: PU EarlyLineDate
pickle_date =
xpElem "date" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpPair (xpAttr "value" xp_early_line_date)
(xpList pickle_game_with_note)
where
from_tuple = uncurry EarlyLineDate
- to_tuple m = (date_value m, date_games_with_notes m)
pickle_game :: PU EarlyLineGameXml
pickle_game =
xpElem "game" $
- xpWrap (from_tuple, to_tuple) $
- xp4Tuple (xpElem "time" xp_ambiguous_time)
+ xpWrap (from_tuple, H.convert) $
+ xp4Tuple (xpElem "time" (xpOption xp_ambiguous_time))
pickle_away_team
pickle_home_team
(xpElem "over_under" (xpOption xpText))
where
from_tuple = uncurryN EarlyLineGameXml
- to_tuple m = (xml_game_time m,
- xml_away_team m,
- xml_home_team m,
- xml_over_under m)
--
pickle_team :: PU EarlyLineGameTeamXml
pickle_team =
- xpWrap (from_tuple, to_tuple) $
- xp6Tuple (xpAttr "rotation" xpInt)
+ xpWrap (from_tuple, to_tuple') $
+ xp6Tuple (xpAttr "rotation" xp_attr_option)
(xpOption $ xpAttr "line" (xpOption xpText))
(xpOption $ xpAttr "name" xpText)
(xpOption xpText)
from_tuple (u,v,w,x,y,z) =
EarlyLineGameTeamXml u (join v) w x (join y) (join z)
- to_tuple (EarlyLineGameTeamXml u v w x y z) =
+ to_tuple' (EarlyLineGameTeamXml u v w x y z) =
(u, double_just v, w, x, double_just y, double_just z)
where
double_just val = case val of
-- test does not mean that unpickling succeeded.
--
test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
- testCase "pickle composed with unpickle is the identity" $ do
- let path = "test/xml/earlylineXML.xml"
- (expected, actual) <- pickle_unpickle pickle_message path
- actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+ [ check "pickle composed with unpickle is the identity"
+ "test/xml/earlylineXML.xml",
+
+ check "pickle composed with unpickle is the identity (empty game time)"
+ "test/xml/earlylineXML-empty-game-time.xml" ]
+ where
+ check desc path = testCase desc $ do
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
-test_unpickle_succeeds =
- testCase "unpickling succeeds" $ do
- let path = "test/xml/earlylineXML.xml"
- actual <- unpickleable path pickle_message
+test_unpickle_succeeds = testGroup "unpickle tests"
+ [ check "unpickling succeeds"
+ "test/xml/earlylineXML.xml",
- let expected = True
- actual @?= expected
+ check "unpickling succeeds (empty game time)"
+ "test/xml/earlylineXML-empty-game-time.xml" ]
+ where
+ check desc path = testCase desc $ do
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
-- record.
--
test_on_delete_cascade :: TestTree
-test_on_delete_cascade =
- testCase "deleting early_lines deletes its children" $ do
- let path = "test/xml/earlylineXML.xml"
- results <- unsafe_unpickle path pickle_message
- let a = undefined :: EarlyLine
- let b = undefined :: EarlyLineGame
-
- actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
- migrate a
- migrate b
- _ <- dbimport results
- deleteAll a
- count_a <- countAll a
- count_b <- countAll b
- return $ sum [count_a, count_b]
- let expected = 0
- actual @?= expected
+test_on_delete_cascade = testGroup "cascading delete tests"
+ [ check "deleting early_lines deletes its children"
+ "test/xml/earlylineXML.xml",
+
+ check "deleting early_lines deletes its children (empty game time)"
+ "test/xml/earlylineXML-empty-game-time.xml" ]
+ where
+ check desc path = testCase desc $ do
+ results <- unsafe_unpickle path pickle_message
+ let a = undefined :: EarlyLine
+ let b = undefined :: EarlyLineGame
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigrationSilent $ do
+ migrate a
+ migrate b
+ _ <- dbimport results
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ return $ sum [count_a, count_b]
+ let expected = 0
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff