htsn-import-0.0.6: src/TSN/XML/InjuriesDetail.hs
{-# 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 \<message\> that in turn
-- contains zero or more \<Listing\>s (note: capitalization). The
-- \<Listing\>s contain \<PlayerListing\>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 Database.Groundhog (
DefaultKey,
countAll,
deleteAll,
migrate,
runMigration,
silentMigrationLogger )
import Database.Groundhog.Generic ( runDbConn )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
groundhog,
mkPersist )
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 \<message\> 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, Show)
-- | 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 \<Listing\> 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 \<Listing\> 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, Show)
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 \<PlayerListing\>, the main type of
-- element contains in Injuries_Detail_XML messages.
--
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, Show)
-- | Database representation of a
-- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
-- because it's redundant.
--
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 }
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'.
--
from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
InjuriesDetailListingPlayerListing {
db_injuries_detail_listings_id = fk,
db_player_id = xml_player_id,
db_date = xml_date,
db_pos = xml_pos,
db_name = xml_name,
db_injury = xml_injury,
db_status = xml_status,
db_fantasy = xml_fantasy,
db_injured = xml_injured,
db_type = xml_type }
-- | 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, to_tuple) $
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
to_tuple pl = (xml_player_team_id pl,
xml_player_id pl,
xml_date pl,
xml_pos pl,
xml_name pl,
xml_injury pl,
xml_status pl,
xml_fantasy pl,
xml_injured pl,
xml_type pl)
-- | Convert 'Listing's to/from XML.
--
pickle_listing :: PU InjuriesDetailListingXml
pickle_listing =
xpElem "Listing" $
xpWrap (from_tuple, to_tuple) $
xpTriple (xpElem "TeamID" xpText)
(xpElem "FullName" xpText)
(xpList pickle_player_listing)
where
from_tuple = uncurryN InjuriesDetailListingXml
to_tuple l = (xml_team_id l,
xml_full_name l,
xml_player_listings l)
-- | Convert 'Message's to/from XML.
--
pickle_message :: PU Message
pickle_message =
xpElem "message" $
xpWrap (from_tuple, to_tuple) $
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
to_tuple m = (xml_xml_file_id m,
xml_heading m,
xml_category m,
xml_sport m,
xml_listings m,
xml_time_stamp m)
--
-- 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
runMigration silentMigrationLogger $ 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