{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each -- document contains a root element \ that in turn -- contains zero or more \s (note: capitalization). The -- \s contain \s which then contain the -- real meat. -- module TSN.XML.InjuriesDetail ( dtd, pickle_message, -- * Tests injuries_detail_tests, -- * WARNING: these are private but exported to silence warnings InjuriesDetailConstructor(..), InjuriesDetailListingConstructor(..), InjuriesDetailListingPlayerListingConstructor(..) ) where -- System imports. import Control.Monad ( forM_ ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import qualified Data.Vector.HFixed as H ( HVector, asCVec, cons, convert, tail ) import Database.Groundhog ( DefaultKey, countAll, deleteAll, migrate ) import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, xpTriple, xp6Tuple, xp10Tuple, xpElem, xpInt, xpList, xpOption, xpPrim, xpText, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers( xp_date, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), FromXml(..), FromXmlFk(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "Injuries_Detail_XML.dtd" -- -- Data types -- -- * InjuriesDetail/Message -- | XML representation of the top-level \ element. These -- are not stored; the data type is used only for parsing. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_listings :: [InjuriesDetailListingXml], xml_time_stamp :: UTCTime } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector Message -- | Database representation of a 'Message'. -- data InjuriesDetail = InjuriesDetail { db_xml_file_id :: Int, db_sport :: String, db_time_stamp :: UTCTime } deriving (Eq, Show) instance ToDb Message where -- | The database representation of a 'Message' is an -- 'InjuriesDetail'. -- type Db Message = InjuriesDetail instance FromXml Message where -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop -- a few fields. -- from_xml Message{..} = InjuriesDetail { db_xml_file_id = xml_xml_file_id, db_sport = xml_sport, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- instance XmlImport Message -- * InjuriesDetailListing/InjuriesDetailListingXml -- | Database representation of a \ element. It has a -- foreign key pointing to its parent 'InjuriesDetail', and does not -- contain the list of 'xml_player_listings' (which get their own -- table). -- data InjuriesDetailListing = InjuriesDetailListing { db_injuries_detail_id :: DefaultKey InjuriesDetail, db_team_id :: String, db_full_name :: String } -- | XML incarnation of a \ element. We don't store these; -- the data type is used only for parsing. -- data InjuriesDetailListingXml = InjuriesDetailListingXml { xml_team_id :: String, -- ^ TeamIDs are (apparently) three -- characters long and not necessarily -- numeric. xml_full_name :: String, -- ^ Team full name xml_player_listings :: [InjuriesDetailListingPlayerListingXml] } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector InjuriesDetailListingXml instance ToDb InjuriesDetailListingXml where -- | The database analogue of an 'InjuriesDetailListingXml' is a -- 'InjuriesDetailListing'. type Db InjuriesDetailListingXml = InjuriesDetailListing instance Child InjuriesDetailListingXml where -- | Each 'InjuriesDetailListingXml' is contained in an -- 'InjuriesDetail'. type Parent InjuriesDetailListingXml = InjuriesDetail instance FromXmlFk InjuriesDetailListingXml where -- | Construct a 'InjuriesDetailListing' from a -- 'InjuriesDetailListingXml' and a foreign key to a -- 'InjuriesDetail'. -- from_xml_fk fk InjuriesDetailListingXml{..} = InjuriesDetailListing { db_injuries_detail_id = fk, db_team_id = xml_team_id, db_full_name = xml_full_name } -- | This allows us to insert the XML representation -- 'InjuriesDetailListingXml' directly. -- instance XmlImportFk InjuriesDetailListingXml -- * InjuriesDetailListingPlayerListing -- | XML representation of a \, the main type of -- element contains in Injuries_Detail_XML messages. The leading -- underscores prevent unused field warnings. -- data InjuriesDetailListingPlayerListingXml = InjuriesDetailListingPlayerListingXml { _xml_player_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. -- We add the \"player\" to avoid conflict -- with 'InjuriesDetailListingXml'. _xml_player_id :: Int, _xml_date :: UTCTime, _xml_pos :: String, _xml_name :: String, _xml_injury :: String, _xml_status :: String, _xml_fantasy :: Maybe String, -- ^ Nobody knows what this is. _xml_injured :: Bool, _xml_type :: String } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector InjuriesDetailListingPlayerListingXml -- | Database representation of a -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id -- because it's redundant. The leading underscores prevent unused -- field warnings. -- data InjuriesDetailListingPlayerListing = InjuriesDetailListingPlayerListing { _db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing, _db_player_id :: Int, _db_date :: UTCTime, _db_pos :: String, _db_name :: String, _db_injury :: String, _db_status :: String, _db_fantasy :: Maybe String, -- ^ Nobody knows what this is. _db_injured :: Bool, _db_type :: String } deriving ( GHC.Generic ) -- | For 'H.cons', 'H.tail', etc. -- instance H.HVector InjuriesDetailListingPlayerListing instance ToDb InjuriesDetailListingPlayerListingXml where -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is -- 'InjuriesDetailListingPlayerListing'. type Db InjuriesDetailListingPlayerListingXml = InjuriesDetailListingPlayerListing instance Child InjuriesDetailListingPlayerListingXml where -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an -- 'InjuriesDetailListing'. -- type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing instance FromXmlFk InjuriesDetailListingPlayerListingXml where -- | To construct a 'InjuriesDetailListingPlayerListing' from a -- 'InjuriesDetailListingPlayerListingXml' we need to supply a -- foreign key to an 'InjuriesDetailListing' after dropping the -- '_xml_player_team_id'. -- -- The 'H.asCVec' trick allows type inference to proceed in the -- middle of two different magics. -- from_xml_fk fk = (H.cons fk) . H.asCVec . H.tail -- | This lets us insert the XML representation -- 'InjuriesDetailListingPlayerListingXml' directly. -- instance XmlImportFk InjuriesDetailListingPlayerListingXml -- -- Database stuff -- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: InjuriesDetail) migrate (undefined :: InjuriesDetailListing) migrate (undefined :: InjuriesDetailListingPlayerListing) -- | To import a 'Message', we import all of its -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig -- out of its 'Listing's. -- dbimport msg = do msg_id <- insert_xml msg forM_ (xml_listings msg) $ \listing -> do l_id <- insert_xml_fk msg_id listing mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing) return ImportSucceeded mkPersist tsn_codegen_config [groundhog| - entity: InjuriesDetail dbName: injuries_detail constructors: - name: InjuriesDetail uniques: - name: unique_injuries_detail type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] - entity: InjuriesDetailListing dbName: injuries_detail_listings constructors: - name: InjuriesDetailListing fields: - name: db_injuries_detail_id reference: onDelete: cascade - entity: InjuriesDetailListingPlayerListing dbName: injuries_detail_listings_player_listings constructors: - name: InjuriesDetailListingPlayerListing fields: - name: _db_injuries_detail_listings_id reference: onDelete: cascade |] -- -- Pickling -- -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML. -- pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml pickle_player_listing = xpElem "PlayerListing" $ xpWrap (from_tuple, H.convert) $ 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" $ xpOption xpText) (xpElem "Injured" xpPrim) (xpElem "Type" xpText) where from_tuple = uncurryN InjuriesDetailListingPlayerListingXml -- | Convert 'Listing's to/from XML. -- pickle_listing :: PU InjuriesDetailListingXml pickle_listing = xpElem "Listing" $ xpWrap (from_tuple, H.convert) $ xpTriple (xpElem "TeamID" xpText) (xpElem "FullName" xpText) (xpList pickle_player_listing) where from_tuple = uncurryN InjuriesDetailListingXml -- | Convert 'Message's to/from XML. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpList pickle_listing) (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message -- -- Tasty Tests -- -- | A list of all tests for this module. -- injuries_detail_tests :: TestTree injuries_detail_tests = testGroup "InjuriesDetail tests" [ test_on_delete_cascade, 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 = 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 -- | Make sure everything gets deleted when we delete the top-level -- record. -- test_on_delete_cascade :: TestTree test_on_delete_cascade = testGroup "cascading delete tests" [ check "delete of injuries_detail deletes its children" "test/xml/Injuries_Detail_XML.xml", check "delete of injuries_detail deletes its children (non-int team_id)" "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ] where check desc path = testCase desc $ do inj <- unsafe_unpickle path pickle_message let a = undefined :: InjuriesDetail let b = undefined :: InjuriesDetailListing let c = undefined :: InjuriesDetailListingPlayerListing actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigrationSilent $ do migrate a migrate b migrate c _ <- dbimport inj deleteAll a count_a <- countAll a count_b <- countAll b count_c <- countAll c return $ count_a + count_b + count_c let expected = 0 actual @?= expected