X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=7d7c19f99d2d236716171f0a381ea0dc8ca20cb1;hb=bd75961380ef07c2ba0ab5412e4326a197fd40c5;hp=cb3afeae4446892f9dafece85b063a8d29e62716;hpb=76cf3eee776d35ba2b18dd0d07df7496a083ae3a;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index cb3afea..7d7c19f 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -14,19 +13,22 @@ -- found within the \s. -- -- The player listings will be mapped to a database table called --- "injuries_detail" automatically. The root "message" and "listing" --- are not retained. +-- \"injuries_detail_player_listings\" automatically. The root +-- \"message\" and \"listing\" are not retained. -- module TSN.XML.InjuriesDetail ( - Listing ( player_listings ), - Message ( listings ), - PlayerListing, - injuries_detail_tests ) + pickle_message, + -- * Tests + injuries_detail_tests, + -- * WARNING: these are private but exported to silence warnings + PlayerListingConstructor(..) ) where +-- System imports. import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) -import Database.Groundhog() +import Database.Groundhog ( + migrate ) import Database.Groundhog.TH ( defaultCodegenConfig, groundhog, @@ -35,44 +37,78 @@ import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, - XmlPickler(..), xpTriple, xp6Tuple, xp10Tuple, xpElem, + xpInt, xpList, + xpOption, xpPrim, xpText, - xpText0, xpWrap ) -import TSN.DbImport ( DbImport(..), import_generic ) -import TSN.Picklers( xp_date, xp_team_id ) -import Xml ( pickle_unpickle ) +-- Local imports. +import TSN.Picklers( xp_date ) +import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) +import TSN.XmlImport ( XmlImport(..) ) +import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +-- | Database representation of a \, the main type of +-- element contains in Injuries_Detail_XML messages. +-- data PlayerListing = PlayerListing { - team_id :: Int, + team_id :: String, -- ^ TeamIDs are (apparently) three + -- characters long and not necessarily + -- numeric. Postgres imposes no performance + -- penalty on a lengthless text field, + -- so we ignore the likely upper bound of + -- three characters. player_id :: Int, date :: UTCTime, pos :: String, name :: String, injury :: String, status :: String, - fantasy :: String, -- ^ Nobody knows what this is. + fantasy :: Maybe String, -- ^ Nobody knows what this is. injured :: Bool, injury_type :: String -- ^ "type" is a reserved keyword so we can't use it } deriving (Eq, Show) + +instance FromXml PlayerListing where + -- | The DB analogue of a 'PlayerListing' is... itself! + type Db PlayerListing = PlayerListing + + -- | To convert between a 'PlayerListing' and a 'PlayerListing', + -- we do nothing. + from_xml = id + +-- | This lets us call 'insert_xml' on a 'PlayerListing' without +-- having to explicitly convert it to its database analogue first. +-- +instance XmlImport PlayerListing + + +-- | XML incarnation of a \ element. We don't store these; +-- the data type is used only for parsing. +-- data Listing = Listing { - listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id + listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id. + -- TeamIDs are (apparently) three characters + -- long and not necessarily numeric. , full_name :: String, -- ^ Team full name player_listings :: [PlayerListing] } deriving (Eq, Show) + +-- | XML representation of the top-level \ element. These +-- are not stored; the data type is used only for parsing. +-- data Message = Message { xml_file_id :: Int, @@ -83,26 +119,37 @@ data Message = time_stamp :: String } deriving (Eq, Show) +instance DbImport Message where + -- | To import a 'Message', we import all of its 'PlayerListing's, + -- which we have to dig out of its 'Listing's. + dbimport msg = do + mapM_ insert_xml (concatMap player_listings $ listings msg) + return ImportSucceeded + + dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing) + mkPersist defaultCodegenConfig [groundhog| - entity: PlayerListing - dbName: injuries_detail + dbName: injuries_detail_player_listings |] +-- | Convert 'PlayerListing's to/from XML. +-- pickle_player_listing :: PU PlayerListing pickle_player_listing = xpElem "PlayerListing" $ xpWrap (from_tuple, to_tuple) $ - xp10Tuple (xpElem "TeamID" xp_team_id) - (xpElem "PlayerID" xpPrim) + xp10Tuple (xpElem "TeamID" xpText) + (xpElem "PlayerID" xpInt) (xpElem "Date" xp_date) (xpElem "Pos" xpText) (xpElem "Name" xpText) (xpElem "Injury" xpText) (xpElem "Status" xpText) - (xpElem "Fantasy" xpText0) - (xpElem "Injured" xpickle) + (xpElem "Fantasy" $ xpOption xpText) + (xpElem "Injured" xpPrim) (xpElem "Type" xpText) where from_tuple = uncurryN PlayerListing @@ -117,29 +164,28 @@ pickle_player_listing = injured pl, injury_type pl) -instance XmlPickler PlayerListing where - xpickle = pickle_player_listing +-- | Convert 'Listing's to/from XML. +-- pickle_listing :: PU Listing pickle_listing = xpElem "Listing" $ xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "TeamID" xp_team_id) + xpTriple (xpElem "TeamID" xpText) (xpElem "FullName" xpText) (xpList pickle_player_listing) where from_tuple = uncurryN Listing to_tuple l = (listing_team_id l, full_name l, player_listings l) -instance XmlPickler Listing where - xpickle = pickle_listing - +-- | Convert 'Message's to/from XML. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ - xp6Tuple (xpElem "XML_File_ID" xpPrim) + xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) @@ -154,24 +200,49 @@ pickle_message = listings m, time_stamp m) -instance XmlPickler Message where - xpickle = pickle_message - -instance DbImport PlayerListing where - dbimport = import_generic ( (concatMap player_listings) . listings) +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- injuries_detail_tests :: TestTree injuries_detail_tests = testGroup "InjuriesDetail tests" - [ test_pickle_of_unpickle_is_identity ] + [ test_pickle_of_unpickle_is_identity, + test_unpickle_succeeds ] +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: success 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 - let path = "test/xml/Injuries_Detail_XML.xml" - (expected :: [Message], actual) <- pickle_unpickle "message" path - actual @?= expected +test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" + [ check "pickle composed with unpickle is the identity" + "test/xml/Injuries_Detail_XML.xml", + + check "pickle composed with unpickle is the identity (non-int team_id)" + "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ] + where + check desc path = testCase desc $ do + (expected, actual) <- pickle_unpickle pickle_message path + actual @?= expected + + +-- | Make sure we can actually unpickle these things. +-- +test_unpickle_succeeds :: TestTree +test_unpickle_succeeds = testGroup "unpickle tests" + [ check "unpickling succeeds" + "test/xml/Injuries_Detail_XML.xml", + + check "unpickling succeeds (non-int team_id)" + "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ] + where + check desc path = testCase desc $ do + actual <- unpickleable path pickle_message + let expected = True + actual @?= expected