{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"jfilexml.dtd\". There's a top-level -- \, containing a \, containing -- \s. Those games contain a bunch of other stuff. The -- \ is pretty irrelevant; we ignore it and pretend that -- a message contains a bunch of games. -- module TSN.XML.JFile ( dtd ) where -- System imports import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( migrate ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( groundhog, mkPersist ) import Text.XML.HXT.Core ( PU, xpTriple, xp6Tuple, xp7Tuple, xp8Tuple, xp10Tuple, xp14Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpPair, xpText, xpWrap ) -- Local imports import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) import TSN.Team ( Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( FromXml(..), FromXmlFk(..), ToDb(..) ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "jfilexml.dtd" -- -- DB/XML data types -- -- * JFile/Message -- | Database representation of a 'Message'. -- data JFile = JFile { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_time_stamp :: UTCTime } -- | XML Representation of an 'JFile'. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_gamelist :: JFileGameListXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) instance ToDb Message where -- | The database analogue of a 'Message' is a 'JFile'. -- type Db Message = JFile -- | The 'FromXml' instance for 'Message' is required for the -- 'XmlImport' instance. -- instance FromXml Message where -- | To convert a 'Message' to an 'JFile', we just drop -- the 'xml_gamelist'. -- from_xml Message{..} = JFile { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- instance XmlImport Message -- * JFileGameAwayTeamXml / JFileGameHomeTeamXml -- | The XML representation of a JFile away team. Its corresponding -- database representation (along with that of the home team) is a -- TSN.Team, but their XML representations are different. data JFileGameAwayTeamXml = JFileGameAwayTeamXml { away_team_id :: String, away_team_abbreviation :: String, away_team_name :: String } deriving (Eq, Show) instance ToDb JFileGameAwayTeamXml where -- | The database analogue of an 'JFileGameAwayTeamXml' is -- a 'Team'. -- type Db JFileGameAwayTeamXml = Team instance FromXml JFileGameAwayTeamXml where -- | To convert a 'JFileGameAwayTeamXml' to a 'Team', we do just -- about nothing. -- from_xml JFileGameAwayTeamXml{..} = Team { team_id = away_team_id, team_abbreviation = away_team_abbreviation, team_name = away_team_name } -- | Allow us to import JFileGameAwayTeamXml directly. instance XmlImport JFileGameAwayTeamXml -- | The XML representation of a JFile home team. Its corresponding -- database representation (along with that of the away team) is a -- TSN.Team, but their XML representations are different. data JFileGameHomeTeamXml = JFileGameHomeTeamXml { home_team_id :: String, home_team_abbreviation :: String, home_team_name :: String } deriving (Eq, Show) instance ToDb JFileGameHomeTeamXml where -- | The database analogue of an 'JFileGameHomeTeamXml' is -- a 'Team'. -- type Db JFileGameHomeTeamXml = Team instance FromXml JFileGameHomeTeamXml where -- | To convert a 'JFileGameHomeTeamXml' to a 'Team', we do just -- about nothing. -- from_xml JFileGameHomeTeamXml{..} = Team { team_id = home_team_id, team_abbreviation = home_team_abbreviation, team_name = home_team_name } -- | Allow us to import JFileGameHomeTeamXml directly. instance XmlImport JFileGameHomeTeamXml -- * JFileGame/JFileGameXml -- | This is an embedded type within each JFileGame. It has its own -- element, \, but there's only one of them per game. So -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd -- most of them are redundant. We'll (un)pickle them for good -- measure, but in the conversion to the database type, we can drop -- all of the redundant information. -- data JFileGameOddsInfo = JFileGameOddsInfo { db_list_date :: UTCTime, db_home_team_id :: String, -- redundant (Team) db_away_team_id :: String, -- redundant (Team) db_home_abbr :: String, -- redundant (Team) db_away_abbr :: String, -- redundant (Team) db_home_team_name :: String, -- redundant (Team) db_away_team_name :: String, -- redundant (Team) db_home_starter :: String, db_away_starter :: String, db_game_date :: UTCTime, -- redundant (JFileGame) db_home_game_key :: Int, db_away_game_key :: Int, db_current_timestamp :: UTCTime, db_live :: Bool, db_notes :: String } deriving (Eq, Show) -- | Another embedded type within 'JFileGame'. These look like, -- \FINAL\ within the XML, but -- they're in one-to-one correspondence with the games. -- data JFileGameStatus = JFileGameStatus { db_status_numeral :: Int, db_status :: String } deriving (Eq, Show) -- | Database representation of a \ contained within a -- \, and, implicitly, a \. -- -- We've left out the game date, opting instead to combine the -- date/time into the 'db_game_time' field. -- data JFileGame = JFileGame { db_jfile_id :: DefaultKey JFile, db_game_id :: Int, db_schedule_id :: Int, db_odds_info :: JFileGameOddsInfo, db_season_type :: String, db_game_time :: UTCTime, db_vleague :: Maybe String, db_hleague :: Maybe String, db_vscore :: Int, db_hscore :: Int, db_time_remaining :: Maybe String, db_game_status :: JFileGameStatus } -- | XML representation of a \ contained within a \, -- and a \. The Away/Home teams seem to coincide with -- those of 'OddsGame', so we're reusing the DB type via the common -- 'TSN.Team' structure. But the XML types are different, because -- they have different picklers! -- data JFileGameXml = JFileGameXml { xml_game_id :: Int, xml_schedule_id :: Int, xml_odds_info :: JFileGameOddsInfo, xml_season_type :: String, xml_game_date :: UTCTime, xml_game_time :: UTCTime, xml_vteam :: JFileGameAwayTeamXml, xml_vleague :: Maybe String, xml_hteam :: JFileGameHomeTeamXml, xml_hleague :: Maybe String, xml_vscore :: Int, xml_hscore :: Int, xml_time_remaining :: Maybe String, xml_game_status :: JFileGameStatus } deriving (Eq, Show) -- * JFileGameListXml -- | The XML representation of \ -> \. This -- element serves only to contain \s, so we don't store the -- intermediate table in the database. -- newtype JFileGameListXml = JFileGameListXml { xml_games :: [JFileGameXml] } deriving (Eq, Show) instance ToDb JFileGameXml where -- | The database analogue of an 'JFileGameXml' is -- an 'JFileGame'. -- type Db JFileGameXml = JFileGame instance FromXmlFk JFileGameXml where -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to) -- a 'JFile'. -- type Parent JFileGameXml = JFile -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the -- foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash -- the date/time together into one field. -- from_xml_fk fk JFileGameXml{..} = JFileGame { db_jfile_id = fk, db_game_id = xml_game_id, db_schedule_id = xml_schedule_id, db_odds_info = xml_odds_info, db_season_type = xml_season_type, db_game_time = xml_game_time, db_vleague = xml_vleague, db_hleague = xml_hleague, db_vscore = xml_vscore, db_hscore = xml_hscore, 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 Nothing = d make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t) -- | This allows us to insert the XML representation -- 'JFileGameXml' directly. -- instance XmlImportFk JFileGameXml -- * JFileGame_Team -- | Database mapping between games and their home/away teams. -- data JFileGame_Team = JFileGame_Team { jgt_jfile_games_id :: DefaultKey JFileGame, jgt_away_team_id :: DefaultKey Team, jgt_home_team_id :: DefaultKey Team } --- --- Database stuff. --- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Team) migrate (undefined :: JFile) migrate (undefined :: JFileGame) migrate (undefined :: JFileGame_Team) dbimport m = return ImportSucceeded mkPersist tsn_codegen_config [groundhog| - entity: JFile dbName: jfile constructors: - name: JFile uniques: - name: unique_jfile type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] - embedded: JFileGameStatus fields: - name: db_status_numeral dbName: status_numeral - name: db_status dbName: status # Many of the JFileGameOddsInfo fields are redundant and have # been left out. - embedded: JFileGameOddsInfo fields: - name: db_list_date dbName: list_date - name: db_home_starter dbName: home_starter - name: db_home_game_key dbName: home_game_key - name: db_away_game_key dbName: away_game_key - name: db_current_timestamp dbName: current_timestamp - name: db_live dbName: live - name: db_notes dbName: notes - entity: JFileGame dbName: jfile_games constructors: - name: JFileGame fields: - name: db_jfile_id reference: onDelete: cascade - name: db_odds_info embeddedType: - {name: list_date, dbName: list_date} - {name: home_starter, dbName: home_starter} - {name: away_starter, dbName: away_starter} - {name: home_game_key, dbName: home_game_key} - {name: away_game_key, dbName: home_game_key} - {name: current_timestamp, dbName: current_timestamp} - {name: live, dbName: live} - {name: notes, dbName: notes} - name: db_game_status embeddedType: - {name: status_numeral, dbName: status_numeral} - {name: status, dbName: status} - entity: JFileGame_Team dbName: jfile_games__teams constructors: - name: JFileGame_Team fields: - name: jgt_jfile_games_id reference: onDelete: cascade - name: jgt_away_team_id reference: onDelete: cascade - name: jgt_home_team_id reference: onDelete: cascade |] --- --- Pickling --- -- | Pickler for the top-level 'Message'. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) pickle_gamelist (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 = xpElem "gamelist" $ xpWrap (to_result, from_result) $ xpList pickle_game where to_result = JFileGameListXml from_result = xml_games pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ xpWrap (from_tuple, to_tuple) $ xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info (xpElem "seasontype" xpText) (xpElem "Game_Date" xp_date_padded) (xpElem "Game_Time" xp_time) pickle_away_team (xpOption $ xpElem "vleague" xpText) pickle_home_team (xpOption $ xpElem "hleague" xpText) (xpElem "vscore" xpInt) (xpElem "hscore" 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) pickle_odds_info = undefined pickle_home_team :: PU JFileGameHomeTeamXml pickle_home_team = xpElem "hteam" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. (xpAttr "abbr" xpText) xpText where from_tuple = uncurryN JFileGameHomeTeamXml to_tuple t = (home_team_id t, home_team_abbreviation t, home_team_name t) pickle_away_team :: PU JFileGameAwayTeamXml pickle_away_team = xpElem "vteam" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. (xpAttr "abbr" xpText) xpText where from_tuple = uncurryN JFileGameAwayTeamXml to_tuple t = (away_team_id t, away_team_abbreviation t, away_team_name t) pickle_status :: PU JFileGameStatus pickle_status = xpElem "status" $ xpWrap (from_tuple, to_tuple) $ xpPair (xpAttr "numeral" xpInt) xpText where from_tuple = uncurry JFileGameStatus to_tuple s = (db_status_numeral s, db_status s)