htsn-import-0.2.1: src/TSN/XML/InjuriesDetail.hs
{-# 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 \<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 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 \<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, 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 \<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, 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 \<PlayerListing\>, 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