]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - XML/EarlyLine.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / 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)