+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
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 Generics ( Generic(..), to_tuple )
import TSN.Codegen ( tsn_codegen_config )
import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
xml_sport :: String,
xml_gamelist :: JFileGameListXml,
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message
instance ToDb Message where
deriving (Eq, Show)
+
-- | Database representation of a \<game\> contained within a
-- \<message\>, and, implicitly, a \<gamelist\>.
--
xml_hscore :: Int,
xml_time_remaining :: Maybe String,
xml_game_status :: JFileGameStatus }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic JFileGameXml
-- * JFileGameListXml
(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_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)
+
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) = to_tuple 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) = to_tuple 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)
--