--- /dev/null
+{-# 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_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 \<date\>
+-- 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 \<date\>. 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 \<date\>
+ 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" undefined)
+ (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" undefined)
+ 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)
projects / dead / htsn-import.git / commitdiff