+{-# 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
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
-- 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 (EarlyLineGameXml (Just t) _ _ _) =
+ combine_date_time :: Maybe UTCTime -> UTCTime
+ combine_date_time (Just t) =
UTCTime (utctDay $ date_value date) (utctDayTime t)
- combine_date_time (EarlyLineGameXml Nothing _ _ _ ) = date_value date
+ 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) $
+ 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" (xpOption 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 = testGroup "pickle-unpickle tests" $
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
[ check "pickle composed with unpickle is the identity"
"test/xml/earlylineXML.xml",
-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
-test_unpickle_succeeds = testGroup "unpickle tests" $
+test_unpickle_succeeds = testGroup "unpickle tests"
[ check "unpickling succeeds"
"test/xml/earlylineXML.xml",
-- record.
--
test_on_delete_cascade :: TestTree
-test_on_delete_cascade = testGroup "cascading delete tests" $
+test_on_delete_cascade = testGroup "cascading delete tests"
[ check "deleting early_lines deletes its children"
"test/xml/earlylineXML.xml",
let b = undefined :: EarlyLineGame
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
_ <- dbimport results
projects / dead / htsn-import.git / blobdiff