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