+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Monad ( forM_, join )
import Data.Time ( UTCTime(..) )
import Data.Tuple.Curry ( uncurryN )
+import qualified Data.Vector.HFixed as H ( HVector, convert )
import Database.Groundhog (
(=.),
(==.),
deleteAll,
insert_,
migrate,
- runMigration,
- silentMigrationLogger,
update )
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.Read ( readMaybe )
import TSN.Codegen ( tsn_codegen_config )
import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
+import TSN.Picklers (
+ xp_attr_option,
+ xp_date_padded,
+ xp_tba_time,
+ xp_time_stamp )
import TSN.Team ( FromXmlFkTeams(..), Team(..) )
import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
import Xml (
xml_casino_client_id :: Maybe Int,
xml_casino_name :: Maybe String,
xml_casino_line :: Maybe String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameCasinoXml
-- | Try to get a 'Double' out of the 'xml_casino_line' which is a
OddsGameTeamStarterXml {
xml_starter_id :: Int,
xml_starter_name :: Maybe String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameTeamStarterXml
-- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
xml_team_name :: String,
xml_team_starter :: Maybe OddsGameTeamStarterXml,
xml_team_casinos :: [OddsGameCasinoXml] }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameTeamXml
+
instance ToDb OddsGameTeamXml where
-- | The database representation of an 'OddsGameTeamXml' is an
xml_away_team :: OddsGameTeamXml,
xml_home_team :: OddsGameTeamXml,
xml_over_under :: OddsGameOverUnderXml }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector OddsGameXml
+
-- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
-- xml_over_under.
xml_line_time :: String,
xml_games_with_notes :: [OddsGameWithNotes],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
+
-- | Pseudo-field that lets us get the 'OddsGame's out of
-- 'xml_games_with_notes'.
where
nonempty_casino :: OddsGameCasinoXml -> Bool
- nonempty_casino (OddsGameCasinoXml Nothing _ _) = False
- nonempty_casino (OddsGameCasinoXml _ Nothing _) = False
- nonempty_casino _ = True
+ nonempty_casino OddsGameCasinoXml{..}
+ | Nothing <- xml_casino_client_id = False
+ | Nothing <- xml_casino_name = False
+ | otherwise = True
--
-- Pickling
pickle_casino :: PU OddsGameCasinoXml
pickle_casino =
xpElem "Casino" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpTriple
- (xpAttr "ClientID" $ xpOption xpInt)
+ (xpAttr "ClientID" $ xp_attr_option)
(xpAttr "Name" $ xpOption xpText)
(xpOption xpText)
where
from_tuple = uncurryN OddsGameCasinoXml
- -- Use record wildcards to avoid unused field warnings.
- to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
- xml_casino_name,
- xml_casino_line)
-- | Pickler for an 'OddsGameTeamXml'.
pickle_home_team :: PU OddsGameTeamXml
pickle_home_team =
xpElem "HomeTeam" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp6Tuple
(xpElem "HomeTeamID" xpText)
(xpElem "HomeRotationNumber" (xpOption xpInt))
where
from_tuple = uncurryN OddsGameTeamXml
- -- Use record wildcards to avoid unused field warnings.
- to_tuple OddsGameTeamXml{..} = (xml_team_id,
- xml_team_rotation_number,
- xml_team_abbr,
- xml_team_name,
- xml_team_starter,
- xml_team_casinos)
-- | Portion of the 'OddsGameTeamStarterXml' pickler that is not
--
pickle_starter :: PU OddsGameTeamStarterXml
pickle_starter =
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpPair (xpAttr "ID" xpInt) (xpOption xpText)
where
from_tuple = uncurry OddsGameTeamStarterXml
- to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id,
- xml_starter_name)
+
-- | Pickler for an home team 'OddsGameTeamStarterXml'
--
pickle_away_team :: PU OddsGameTeamXml
pickle_away_team =
xpElem "AwayTeam" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp6Tuple
(xpElem "AwayTeamID" xpText)
(xpElem "AwayRotationNumber" (xpOption xpInt))
where
from_tuple = uncurryN OddsGameTeamXml
- -- Use record wildcards to avoid unused field warnings.
- to_tuple OddsGameTeamXml{..} = (xml_team_id,
- xml_team_rotation_number,
- xml_team_abbr,
- xml_team_name,
- xml_team_starter,
- xml_team_casinos)
-
-- | Pickler for an 'OddsGameOverUnderXml'.
pickle_game :: PU OddsGameXml
pickle_game =
xpElem "Game" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp6Tuple
(xpElem "GameID" xpInt)
(xpElem "Game_Date" xp_date_padded)
pickle_over_under
where
from_tuple = uncurryN OddsGameXml
- -- Use record wildcards to avoid unused field warnings.
- to_tuple OddsGameXml{..} = (xml_game_id,
- xml_game_date,
- xml_game_time,
- xml_away_team,
- xml_home_team,
- xml_over_under)
-- | Pickler for the top-level 'Message'.
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp8Tuple (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_line_time m,
- xml_games_with_notes m,
- xml_time_stamp m)
--
let d = undefined :: OddsGame
let e = undefined :: OddsGameLine
actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
+ runMigrationSilent $ do
migrate a
migrate b
migrate c
projects / dead / htsn-import.git / blobdiff