From 1f260c118e8da5679820c8cfa489d8fe4a521140 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Tue, 14 Jan 2014 05:39:58 -0500 Subject: [PATCH] Update (or add) a bunch of documentation. Change two 'String' types to 'UTCTime' and pickle/unpickle them thusly. --- src/TSN/Picklers.hs | 19 +++- src/TSN/XML/Heartbeat.hs | 18 +++- src/TSN/XML/Injuries.hs | 17 +++- src/TSN/XML/InjuriesDetail.hs | 17 +++- src/TSN/XML/News.hs | 19 +++- src/TSN/XML/Odds.hs | 184 +++++++++++++++++++++++++--------- 6 files changed, 209 insertions(+), 65 deletions(-) diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs index 8419f70..d87139b 100644 --- a/src/TSN/Picklers.hs +++ b/src/TSN/Picklers.hs @@ -3,7 +3,8 @@ -- module TSN.Picklers ( xp_date, - xp_team_id ) + xp_team_id, + xp_time ) where -- System imports. @@ -31,6 +32,22 @@ xp_date = from_date = formatTime defaultTimeLocale format +-- | (Un)pickle a UTCTime without the date portion. +-- +xp_time :: PU UTCTime +xp_time = + (to_time, from_time) `xpWrapMaybe` xpText + where + format = "%I:%M %p" + + to_time :: String -> Maybe UTCTime + to_time = parseTime defaultTimeLocale format + + from_time :: UTCTime -> String + from_time = formatTime defaultTimeLocale format + + + -- | Parse a team_id. These are (so far!) three characters long, and -- not necessarily numeric. For simplicity, we return a 'String' -- rather than e.g. a @(Char, Char, Char)@. But unpickling will fail diff --git a/src/TSN/XML/Heartbeat.hs b/src/TSN/XML/Heartbeat.hs index 7c62445..4e0ba07 100644 --- a/src/TSN/XML/Heartbeat.hs +++ b/src/TSN/XML/Heartbeat.hs @@ -3,8 +3,9 @@ -- | Handle documents defined by Heartbeat.dtd. -- module TSN.XML.Heartbeat ( - heartbeat_tests, - verify ) + verify, + -- * Tests + heartbeat_tests ) where -- System imports. @@ -28,6 +29,7 @@ import Xml ( pickle_unpickle, unpickleable ) -- | The data structure that holds the XML representation of a -- Heartbeat message. +-- data Message = Message { xml_file_id :: Int, @@ -38,6 +40,7 @@ data Message = -- | A (un)pickler that turns a Heartbeat XML file into a 'Message' -- and vice-versa. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -63,8 +66,12 @@ verify xml = do Nothing -> ImportFailed "Could not unpickle document in import_generic." Just _ -> ImportSkipped "Heartbeat received. Thump." +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- heartbeat_tests :: TestTree heartbeat_tests = testGroup @@ -73,8 +80,9 @@ heartbeat_tests = test_unpickle_succeeds ] --- | Warning: succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: succeess of this +-- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index 8002799..03f9565 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -14,8 +14,9 @@ -- automatically. The root message is not retained. -- module TSN.XML.Injuries ( - injuries_tests, pickle_message, + -- * Tests + injuries_tests, -- * WARNING: these are private but exported to silence warnings ListingConstructor(..) ) where @@ -145,8 +146,12 @@ pickle_message = time_stamp m) +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- injuries_tests :: TestTree injuries_tests = testGroup @@ -155,8 +160,10 @@ injuries_tests = test_unpickle_succeeds ] --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: succeess of this +-- test does not mean that unpickling succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testCase "pickle composed with unpickle is the identity" $ do @@ -165,6 +172,8 @@ test_pickle_of_unpickle_is_identity = actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testCase "unpickling succeeds" $ do diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index 171b879..38e0268 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -17,8 +17,9 @@ -- are not retained. -- module TSN.XML.InjuriesDetail ( - injuries_detail_tests, pickle_message, + -- * Tests + injuries_detail_tests, -- * WARNING: these are private but exported to silence warnings PlayerListingConstructor(..) ) where @@ -171,8 +172,12 @@ pickle_message = listings m, time_stamp m) +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- injuries_detail_tests :: TestTree injuries_detail_tests = testGroup @@ -181,8 +186,10 @@ injuries_detail_tests = test_unpickle_succeeds ] --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: succeess of this +-- test does not mean that unpickling succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" @@ -196,6 +203,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index b9bc3df..7d8ef75 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -11,8 +11,9 @@ -- root element \ that contains an entire news item. -- module TSN.XML.News ( - news_tests, pickle_message, + -- * Tests + news_tests, -- * WARNING: these are private but exported to silence warnings News_NewsLocationConstructor(..), News_NewsTeamConstructor(..), @@ -387,8 +388,12 @@ pickle_message = to_string = join "\n" +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- news_tests :: TestTree news_tests = testGroup @@ -398,6 +403,8 @@ news_tests = test_unpickle_succeeds ] +-- | Make sure our codegen is producing the correct database names. +-- test_news_fields_have_correct_names :: TestTree test_news_fields_have_correct_names = testCase "news fields get correct database names" $ @@ -419,8 +426,10 @@ test_news_fields_have_correct_names = check (x,y) = (x @?= y) --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: succeess of this +-- test does not mean that unpickling succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" @@ -434,6 +443,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index 7a2a6cc..509b436 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -12,8 +12,9 @@ -- unorganized crap. -- module TSN.XML.Odds ( - odds_tests, pickle_message, + -- * Tests + odds_tests, -- * WARNING: these are private but exported to silence warnings Odds_OddsGameConstructor(..), OddsCasinoConstructor(..), @@ -24,7 +25,9 @@ module TSN.XML.Odds ( OddsGameTeamConstructor(..) ) where +-- System imports. import Control.Monad ( forM_, join ) +import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( (=.), @@ -55,10 +58,11 @@ import Text.XML.HXT.Core ( xpTriple, xpWrap ) +-- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_team_id ) +import TSN.Picklers ( xp_date, xp_team_id, xp_time ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), pickle_unpickle, unpickleable ) @@ -66,7 +70,7 @@ import Xml ( FromXml(..), pickle_unpickle, unpickleable ) -- | The home/away lines are 'Double's, but the over/under lines are -- textual. If we want to use one data type for both, we have to go --- with a String and then attempt to 'read' a 'Double' later when we +-- with a 'String' and then attempt to 'read' a 'Double' later when we -- go to insert the thing. -- data OddsGameCasinoXml = @@ -83,8 +87,9 @@ data OddsGameCasinoXml = home_away_line :: OddsGameCasinoXml -> Maybe Double home_away_line = join . (fmap readMaybe) . xml_casino_line + -- | The casinos should have their own table, but the lines don't --- belong in that table. (There should be another table joining the +-- belong in that table (there should be another table joining the -- casinos and the thing the lines are for together.) -- -- We drop the 'Game' prefix because the Casinos really aren't @@ -96,20 +101,37 @@ data OddsCasino = casino_name :: String } deriving (Eq, Show) + instance FromXml OddsGameCasinoXml where + -- | The database representation of an 'OddsGameCasinoXml' is an + -- 'OddsCasino'. + -- type Db OddsGameCasinoXml = OddsCasino - -- We don't need the key argument (from_xml_fk) since the XML type - -- contains more information in this case. + -- | We convert from XML to the database by dropping the line field. from_xml OddsGameCasinoXml{..} = OddsCasino { casino_client_id = xml_casino_client_id, casino_name = xml_casino_name } - +-- | This allows us to call 'insert_xml' on an 'OddsGameCasinoXml' +-- without first converting it to the database representation. instance XmlImport OddsGameCasinoXml +-- | The database representation of teams as they appear in odds +-- games. +-- +data OddsGameTeam = + OddsGameTeam { + db_team_id :: String, -- ^ The home/away team IDs are 3 characters + db_abbr :: String, + db_team_name :: String } + deriving (Eq, Show) + + +-- | The XML representation of a \, as found in \s. +-- data OddsGameHomeTeamXml = OddsGameHomeTeamXml { xml_home_team_id :: String, -- ^ These are three-character IDs. @@ -120,31 +142,30 @@ data OddsGameHomeTeamXml = deriving (Eq, Show) instance FromXml OddsGameHomeTeamXml where + -- | The database representation of an 'OddsGameHomeTeamXml' is an + -- 'OddsGameTeam'. + -- type Db OddsGameHomeTeamXml = OddsGameTeam + + -- | We convert from XML to the database by dropping the lines and + -- rotation number (which are specific to the games, not the teams + -- themselves). + -- from_xml OddsGameHomeTeamXml{..} = OddsGameTeam { db_team_id = xml_home_team_id, db_abbr = xml_home_abbr, db_team_name = xml_home_team_name } +-- | XmlImport allows us to call 'insert_xml' directly on an +-- 'OddsGameHomeTeamXml' without explicitly converting it to the +-- associated database type. +-- instance XmlImport OddsGameHomeTeamXml where -data OddsGameTeam = - OddsGameTeam { - db_team_id :: String, -- ^ The home/away team IDs are 3 characters - db_abbr :: String, - db_team_name :: String } - deriving (Eq, Show) - - --- | Database mapping between games and their home/away teams. -data OddsGame_OddsGameTeam = - OddsGame_OddsGameTeam { - ogogt_odds_games_id :: DefaultKey OddsGame, - ogogt_away_team_id :: DefaultKey OddsGameTeam, - ogogt_home_team_id :: DefaultKey OddsGameTeam } - +-- | -- | The XML representation of a \, as found in \s. +-- data OddsGameAwayTeamXml = OddsGameAwayTeamXml { xml_away_team_id :: String, -- ^ These are 3 character IDs. @@ -155,19 +176,43 @@ data OddsGameAwayTeamXml = deriving (Eq, Show) instance FromXml OddsGameAwayTeamXml where + -- | The database representation of an 'OddsGameAwayTeamXml' is an + -- 'OddsGameTeam'. + -- type Db OddsGameAwayTeamXml = OddsGameTeam + + -- | We convert from XML to the database by dropping the lines and + -- rotation number (which are specific to the games, not the teams + -- themselves). + -- from_xml OddsGameAwayTeamXml{..} = OddsGameTeam xml_away_team_id xml_away_abbr xml_away_team_name +-- | XmlImport allows us to call 'insert_xml' directly on an +-- 'OddsGameAwayTeamXml' without explicitly converting it to the +-- associated database type. +-- instance XmlImport OddsGameAwayTeamXml where --- | Can't use a newtype with Groundhog. + +-- | Database mapping between games and their home/away teams. +data OddsGame_OddsGameTeam = + OddsGame_OddsGameTeam { + ogogt_odds_games_id :: DefaultKey OddsGame, + ogogt_away_team_id :: DefaultKey OddsGameTeam, + ogogt_home_team_id :: DefaultKey OddsGameTeam } + + +-- | XML representation of the over/under. A wrapper around a bunch of +-- casino elements. +-- newtype OddsGameOverUnderXml = OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] } deriving (Eq, Show) + -- | This database representation of the casino lines can't be -- constructed from the one in the XML. The casinos within -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or @@ -187,34 +232,49 @@ data OddsGameLine = ogl_away_line :: Maybe Double, ogl_home_line :: Maybe Double } + +-- | Database representation of a game. We retain the rotation number +-- of the home/away teams, since those are specific to the game and +-- not the teams. +-- data OddsGame = OddsGame { db_game_id :: Int, - db_game_date :: String, -- TODO - db_game_time :: String, -- TODO + db_game_date :: UTCTime, + db_game_time :: UTCTime, db_game_away_team_rotation_number :: Int, db_game_home_team_rotation_number :: Int } -deriving instance Eq OddsGame -deriving instance Show OddsGame + deriving (Eq, Show) +-- | XML representation of a game. +-- data OddsGameXml = OddsGameXml { xml_game_id :: Int, - xml_game_date :: String, -- TODO - xml_game_time :: String, -- TODO + xml_game_date :: UTCTime, + xml_game_time :: UTCTime, xml_game_away_team :: OddsGameAwayTeamXml, xml_game_home_team :: OddsGameHomeTeamXml, xml_game_over_under :: OddsGameOverUnderXml } deriving (Eq, Show) --- | Pseudo-field that lets us get the 'OddsCasino's out of +-- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of -- xml_game_over_under. +-- xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml] xml_game_over_under_casinos = xml_casinos . xml_game_over_under instance FromXml OddsGameXml where + -- | The database representation of an 'OddsGameXml' is an + -- 'OddsGame'. + -- type Db OddsGameXml = OddsGame + + -- | To convert from the XML representation to the database one, we + -- drop the home/away teams and the casino lines, but retain the + -- home/away rotation numbers. + -- from_xml OddsGameXml{..} = OddsGame { db_game_id = xml_game_id, @@ -225,10 +285,14 @@ instance FromXml OddsGameXml where db_game_home_team_rotation_number = (xml_home_rotation_number xml_game_home_team) } +-- | This lets us call 'insert_xml' directly on an 'OddsGameXml' +-- without converting it to the database representation explicitly. +-- instance XmlImport OddsGameXml - +-- | Database and representation of the top-level Odds object (a +-- 'Message'). data Odds = Odds { db_sport :: String, @@ -262,7 +326,7 @@ data OddsGameWithNotes = game :: OddsGameXml } deriving (Eq, Show) --- | The XML representation of Odds. +-- | The XML representation of 'Odds'. data Message = Message { xml_xml_file_id :: Int, @@ -277,27 +341,34 @@ data Message = -- | Pseudo-field that lets us get the 'OddsGame's out of -- 'xml_games_with_notes'. +-- xml_games :: Message -> [OddsGameXml] xml_games m = map game (xml_games_with_notes m) instance FromXml Message where + -- | The database representation of a 'Message' is 'Odds'. + -- type Db Message = Odds - -- We don't need the key argument (from_xml_fk) since the XML type - -- contains more information in this case. + -- | To convert from the XML representation to the database one, we + -- just drop a bunch of fields. + -- from_xml Message{..} = Odds { db_sport = xml_sport, db_title = xml_title, db_line_time = xml_line_time } +-- | This lets us call 'insert_xml' on a Message directly, without +-- having to convert it to its database representation explicitly. +-- instance XmlImport Message --- * Groundhog database schema. --- | This must come before the dbimport code. +-- | Groundhog database schema. This must come before the DbImport +-- instance definition. -- mkPersist tsn_codegen_config [groundhog| - entity: Odds @@ -317,7 +388,7 @@ mkPersist tsn_codegen_config [groundhog| - name: OddsGameTeam fields: - name: db_team_id - type: varchar(3) + type: varchar(3) # We've only seen 3, so far... uniques: - name: unique_odds_games_team type: constraint @@ -341,9 +412,9 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: Odds_OddsGame fields: - - name: odds_OddsGame0 + - name: odds_OddsGame0 # Default created by mkNormalFieldName dbName: odds_id - - name: odds_OddsGame1 + - name: odds_OddsGame1 # Default created by mkNormalFieldName dbName: odds_games_id - entity: OddsGame_OddsGameTeam @@ -429,6 +500,8 @@ instance DbImport Message where return ImportSucceeded +-- | Pickler for an 'OddsGame' optionally preceded by some notes. +-- pickle_game_with_notes :: PU OddsGameWithNotes pickle_game_with_notes = xpWrap (from_pair, to_pair) $ @@ -440,7 +513,8 @@ pickle_game_with_notes = to_pair OddsGameWithNotes{..} = (notes, game) - +-- | Pickler for an 'OddsGameCasinoXml'. +-- pickle_casino :: PU OddsGameCasinoXml pickle_casino = xpElem "Casino" $ @@ -457,6 +531,8 @@ pickle_casino = xml_casino_line) +-- | Pickler for an 'OddsGameHomeTeamXml'. +-- pickle_home_team :: PU OddsGameHomeTeamXml pickle_home_team = xpElem "HomeTeam" $ @@ -477,7 +553,8 @@ pickle_home_team = xml_home_casinos) - +-- | Pickler for an 'OddsGameAwayTeamXml'. +-- pickle_away_team :: PU OddsGameAwayTeamXml pickle_away_team = xpElem "AwayTeam" $ @@ -499,6 +576,8 @@ pickle_away_team = +-- | Pickler for an 'OddsGameOverUnderXml'. +-- pickle_over_under :: PU OddsGameOverUnderXml pickle_over_under = xpElem "Over_Under" $ @@ -509,15 +588,16 @@ pickle_over_under = to_newtype = OddsGameOverUnderXml - +-- | Pickler for an 'OddsGameXml'. +-- pickle_game :: PU OddsGameXml pickle_game = xpElem "Game" $ xpWrap (from_tuple, to_tuple) $ xp6Tuple (xpElem "GameID" xpInt) - (xpElem "Game_Date" xpText) - (xpElem "Game_Time" xpText) + (xpElem "Game_Date" xp_date) + (xpElem "Game_Time" xp_time) pickle_away_team pickle_home_team pickle_over_under @@ -532,6 +612,8 @@ pickle_game = xml_game_over_under) +-- | Pickler for the top-level 'Message'. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -556,8 +638,12 @@ pickle_message = xml_time_stamp m) +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- odds_tests :: TestTree odds_tests = testGroup @@ -566,8 +652,10 @@ odds_tests = test_unpickle_succeeds ] --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: succeess of this +-- test does not mean that unpickling succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" @@ -587,6 +675,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" -- 2.43.2