{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module TSN.XML.EarlyLine ( dtd, pickle_message, -- * WARNING: these are private but exported to silence warnings EarlyLineConstructor(..), EarlyLineGameConstructor(..) ) where -- System imports. import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( groundhog, mkPersist ) import Text.XML.HXT.Core ( PU, xp4Tuple, xp7Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpText, xpTriple, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..) ) import TSN.Picklers ( xp_ambiguous_time, xp_early_line_date, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), ToDb(..) ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "earlylineXML.dtd" -- -- DB/XML data types -- -- * EarlyLine/Message -- | Database representation of a 'Message'. It lacks the \ -- elements since they're really properties of the games that they -- contain. -- data EarlyLine = EarlyLine { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_title :: String, db_time_stamp :: UTCTime } deriving (Eq, Show) -- | XML Representation of an 'EarlyLine'. It has the same -- fields, but in addition contains the 'xml_dates'. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_title :: String, xml_dates :: [EarlyLineDateXml], xml_time_stamp :: UTCTime } deriving (Eq, Show) instance ToDb Message where -- | The database analogue of a 'Message' is an 'EarlyLine'. -- type Db Message = EarlyLine -- | The 'FromXml' instance for 'Message' is required for the -- 'XmlImport' instance. -- instance FromXml Message where -- | To convert a 'Message' to an 'EarlyLine', we just drop -- the 'xml_dates'. -- from_xml Message{..} = EarlyLine { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_title = xml_title, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- instance XmlImport Message -- * EarlyLineDateXml -- | XML representation of a \. It has a \"value\" attribute -- containing the actual date string. As children it contains a -- (non-optional) note, and a game. The note and date value are -- properties of the game as far as I can tell. -- data EarlyLineDateXml = EarlyLineDateXml { xml_date_value :: UTCTime, xml_note :: String, xml_game :: EarlyLineGameXml } deriving (Eq, Show) -- * EarlyLineGame / EarlyLineGameXml data EarlyLineGame = EarlyLineGame { db_early_lines_id :: DefaultKey EarlyLine, db_game_time :: UTCTime, -- ^ Combined date/time db_note :: String, -- ^ Taken from the parent \ db_away_team :: EarlyLineGameTeam, db_home_team :: EarlyLineGameTeam, db_over_under :: String } data EarlyLineGameXml = EarlyLineGameXml { xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\" xml_away_team :: EarlyLineGameTeam, xml_home_team :: EarlyLineGameTeam, xml_over_under :: String } deriving (Eq, Show) -- | XML representation of an earlyline team. It doubles as an -- embedded type within the DB representation 'EarlyLineGame'. -- data EarlyLineGameTeam = EarlyLineGameTeam { db_rotation_number :: Int, db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\". db_team_name :: String } deriving (Eq, Show) -- -- * Database stuff -- instance DbImport Message where dbmigrate = undefined dbimport = undefined mkPersist tsn_codegen_config [groundhog| - entity: EarlyLine dbName: early_lines constructors: - name: EarlyLine uniques: - name: unique_early_lines type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] - entity: EarlyLineGame dbName: early_lines_games constructors: - name: EarlyLineGame fields: - name: db_early_lines_id reference: onDelete: cascade - name: db_away_team embeddedType: - {name: rotation_number, dbName: away_team_rotation_number} - {name: line, dbName: away_team_line} - {name: team_name, dbName: away_team_name} - name: db_home_team embeddedType: - {name: rotation_number, dbName: home_team_rotation_number} - {name: line, dbName: home_team_line} - {name: team_name, dbName: home_team_name} - embedded: EarlyLineGameTeam fields: - name: db_rotation_number dbName: rotation_number - name: db_line dbName: line - name: db_team_name dbName: team_name |] -- -- * Pickling -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ xp7Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "title" xpText) (xpList pickle_date) (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_date :: PU EarlyLineDateXml pickle_date = xpElem "date" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "value" xp_early_line_date) (xpElem "note" xpText) pickle_game where from_tuple = uncurryN EarlyLineDateXml to_tuple m = (xml_date_value m, xml_note m, xml_game m) pickle_game :: PU EarlyLineGameXml pickle_game = xpElem "game" $ xpWrap (from_tuple, to_tuple) $ xp4Tuple (xpElem "time" xp_ambiguous_time) pickle_away_team pickle_home_team (xpElem "over_under" 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_away_team :: PU EarlyLineGameTeam pickle_away_team = xpElem "teamA" pickle_team pickle_home_team :: PU EarlyLineGameTeam pickle_home_team = xpElem "teamH" pickle_team pickle_team :: PU EarlyLineGameTeam pickle_team = xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "rotation" xpInt) (xpAttr "line" (xpOption xpText)) xpText where from_tuple = uncurryN EarlyLineGameTeam to_tuple m = (db_rotation_number m, db_line m, db_team_name m)