X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FEarlyLine.hs;fp=src%2FTSN%2FXML%2FEarlyLine.hs;h=f4a24d89bb0be57473118985227e29df3b36cc5b;hb=fbaea63ea21b5b35d22f43e096e09983b76dcef7;hp=0000000000000000000000000000000000000000;hpb=75be340947abf838b6325eb450809e242b96df56;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs new file mode 100644 index 0000000..f4a24d8 --- /dev/null +++ b/src/TSN/XML/EarlyLine.hs @@ -0,0 +1,286 @@ +{-# 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 \ +-- 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" 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)