src/TSN/XML/EarlyLine.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 module TSN.XML.EarlyLine (
   9   dtd,
  10   pickle_message,
  11   -- * WARNING: these are private but exported to silence warnings
  12   EarlyLineConstructor(..),
  13   EarlyLineGameConstructor(..) )
  14 where
  15
  16 -- System imports.
  17 import Data.Time ( UTCTime(..) )
  18 import Data.Tuple.Curry ( uncurryN )
  19 import Database.Groundhog.Core ( DefaultKey )
  20 import Database.Groundhog.TH (
  21   groundhog,
  22   mkPersist )
  23 import Text.XML.HXT.Core (
  24   PU,
  25   xp4Tuple,
  26   xp7Tuple,
  27   xpAttr,
  28   xpElem,
  29   xpInt,
  30   xpList,
  31   xpOption,
  32   xpText,
  33   xpTriple,
  34   xpWrap )
  35
  36 -- Local imports.
  37 import TSN.Codegen ( tsn_codegen_config )
  38 import TSN.DbImport ( DbImport(..) )
  39 import TSN.Picklers ( xp_time_stamp )
  40 import TSN.XmlImport ( XmlImport(..) )
  41 import Xml (
  42   FromXml(..),
  43   ToDb(..) )
  44
  45
  46 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  47 --
  48 dtd :: String
  49 dtd = "earlylineXML.dtd"
  50
  51 --
  52 -- DB/XML data types
  53 --
  54
  55 -- * EarlyLine/Message
  56
  57 -- | Database representation of a 'Message'. It lacks the \<date\>
  58 --   elements since they're really properties of the games that they
  59 --   contain.
  60 --
  61 data EarlyLine =
  62   EarlyLine {
  63     db_xml_file_id :: Int,
  64     db_heading :: String,
  65     db_category :: String,
  66     db_sport :: String,
  67     db_title :: String,
  68     db_time_stamp :: UTCTime }
  69   deriving (Eq, Show)
  70
  71
  72
  73 -- | XML Representation of an 'EarlyLine'. It has the same
  74 --   fields, but in addition contains the 'xml_dates'.
  75 --
  76 data Message =
  77   Message {
  78     xml_xml_file_id :: Int,
  79     xml_heading :: String,
  80     xml_category :: String,
  81     xml_sport :: String,
  82     xml_title :: String,
  83     xml_dates :: [EarlyLineDateXml],
  84     xml_time_stamp :: UTCTime }
  85   deriving (Eq, Show)
  86
  87
  88 instance ToDb Message where
  89   -- | The database analogue of a 'Message' is an 'EarlyLine'.
  90   --
  91   type Db Message = EarlyLine
  92
  93
  94 -- | The 'FromXml' instance for 'Message' is required for the
  95 --   'XmlImport' instance.
  96 --
  97 instance FromXml Message where
  98   -- | To convert a 'Message' to an 'EarlyLine', we just drop
  99   --   the 'xml_dates'.
 100   --
 101   from_xml Message{..} =
 102     EarlyLine {
 103       db_xml_file_id = xml_xml_file_id,
 104       db_heading = xml_heading,
 105       db_category = xml_category,
 106       db_sport = xml_sport,
 107       db_title = xml_title,
 108       db_time_stamp = xml_time_stamp }
 109
 110
 111 -- | This allows us to insert the XML representation 'Message'
 112 --   directly.
 113 --
 114 instance XmlImport Message
 115
 116
 117
 118 -- * EarlyLineDateXml
 119
 120 -- | XML representation of a \<date\>. It has a \"value\" attribute
 121 --   containing the actual date string. As children it contains a
 122 --   (non-optional) note, and a game. The note and date value are
 123 --   properties of the game as far as I can tell.
 124 --
 125 data EarlyLineDateXml =
 126   EarlyLineDateXml {
 127     xml_date_value :: UTCTime,
 128     xml_note :: String,
 129     xml_game :: EarlyLineGameXml }
 130   deriving (Eq, Show)
 131
 132
 133
 134 -- * EarlyLineGame / EarlyLineGameXml
 135
 136 data EarlyLineGame =
 137   EarlyLineGame {
 138     db_early_lines_id :: DefaultKey EarlyLine,
 139     db_game_time :: UTCTime, -- ^ Combined date/time
 140     db_note :: String, -- ^ Taken from the parent \<date\>
 141     db_away_team :: EarlyLineGameTeam,
 142     db_home_team :: EarlyLineGameTeam,
 143     db_over_under :: String }
 144
 145 data EarlyLineGameXml =
 146   EarlyLineGameXml {
 147     xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
 148     xml_away_team :: EarlyLineGameTeam,
 149     xml_home_team :: EarlyLineGameTeam,
 150     xml_over_under :: String }
 151   deriving (Eq, Show)
 152
 153
 154 -- | XML representation of an earlyline team. It doubles as an
 155 --   embedded type within the DB representation 'EarlyLineGame'.
 156 --
 157 data EarlyLineGameTeam =
 158   EarlyLineGameTeam {
 159     db_rotation_number :: Int,
 160     db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
 161     db_team_name :: String }
 162   deriving (Eq, Show)
 163
 164
 165 --
 166 -- * Database stuff
 167 --
 168
 169 instance DbImport Message where
 170   dbmigrate = undefined
 171   dbimport = undefined
 172
 173
 174 mkPersist tsn_codegen_config [groundhog|
 175
 176 - entity: EarlyLine
 177   dbName: early_lines
 178   constructors:
 179     - name: EarlyLine
 180       uniques:
 181         - name: unique_early_lines
 182           type: constraint
 183           # Prevent multiple imports of the same message.
 184           fields: [db_xml_file_id]
 185
 186
 187 - entity: EarlyLineGame
 188   dbName: early_lines_games
 189   constructors:
 190     - name: EarlyLineGame
 191       fields:
 192         - name: db_early_lines_id
 193           reference:
 194             onDelete: cascade
 195         - name: db_away_team
 196           embeddedType:
 197             - {name: rotation_number, dbName: away_team_rotation_number}
 198             - {name: line, dbName: away_team_line}
 199             - {name: team_name, dbName: away_team_name}
 200         - name: db_home_team
 201           embeddedType:
 202             - {name: rotation_number, dbName: home_team_rotation_number}
 203             - {name: line, dbName: home_team_line}
 204             - {name: team_name, dbName: home_team_name}
 205
 206 - embedded: EarlyLineGameTeam
 207   fields:
 208     - name: db_rotation_number
 209       dbName: rotation_number
 210     - name: db_line
 211       dbName: line
 212     - name: db_team_name
 213       dbName: team_name
 214
 215 |]
 216
 217
 218
 219 --
 220 -- * Pickling
 221 --
 222 pickle_message :: PU Message
 223 pickle_message =
 224   xpElem "message" $
 225     xpWrap (from_tuple, to_tuple) $
 226     xp7Tuple (xpElem "XML_File_ID" xpInt)
 227              (xpElem "heading" xpText)
 228              (xpElem "category" xpText)
 229              (xpElem "sport" xpText)
 230              (xpElem "title" xpText)
 231              (xpList pickle_date)
 232              (xpElem "time_stamp" xp_time_stamp)
 233   where
 234     from_tuple = uncurryN Message
 235     to_tuple m = (xml_xml_file_id m,
 236                   xml_heading m,
 237                   xml_category m,
 238                   xml_sport m,
 239                   xml_title m,
 240                   xml_dates m,
 241                   xml_time_stamp m)
 242
 243 pickle_date :: PU EarlyLineDateXml
 244 pickle_date =
 245   xpElem "date" $
 246     xpWrap (from_tuple, to_tuple) $
 247     xpTriple (xpAttr "value" undefined)
 248              (xpElem "note" xpText)
 249              pickle_game
 250   where
 251     from_tuple = uncurryN EarlyLineDateXml
 252     to_tuple m = (xml_date_value m, xml_note m, xml_game m)
 253
 254
 255 pickle_game :: PU EarlyLineGameXml
 256 pickle_game =
 257   xpElem "game" $
 258     xpWrap (from_tuple, to_tuple) $
 259     xp4Tuple (xpElem "time" undefined)
 260              pickle_away_team
 261              pickle_home_team
 262              (xpElem "over_under" xpText)
 263   where
 264     from_tuple = uncurryN EarlyLineGameXml
 265     to_tuple m = (xml_game_time m,
 266                   xml_away_team m,
 267                   xml_home_team m,
 268                   xml_over_under m)
 269
 270
 271
 272 pickle_away_team :: PU EarlyLineGameTeam
 273 pickle_away_team = xpElem "teamA" pickle_team
 274
 275 pickle_home_team :: PU EarlyLineGameTeam
 276 pickle_home_team = xpElem "teamH" pickle_team
 277
 278 pickle_team :: PU EarlyLineGameTeam
 279 pickle_team =
 280   xpWrap (from_tuple, to_tuple) $
 281   xpTriple (xpAttr "rotation" xpInt)
 282            (xpAttr "line" (xpOption xpText))
 283            xpText
 284   where
 285     from_tuple = uncurryN EarlyLineGameTeam
 286     to_tuple m = (db_rotation_number m, db_line m, db_team_name m)