{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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 then contain the real
--- meat; everything contained in the parent \<Listing\> can also be
--- found within the \<PlayerListing\>s.
---
--- The player listings will be mapped to a database table called
--- \"injuries_detail_player_listings\" automatically. The root
--- \"message\" and \"listing\" are not retained.
+-- \<Listing\>s contain \<PlayerListing\>s which then contain the
+-- real meat.
--
module TSN.XML.InjuriesDetail (
pickle_message,
-- * Tests
injuries_detail_tests,
-- * WARNING: these are private but exported to silence warnings
- PlayerListingConstructor(..) )
+ InjuriesDetailConstructor(..),
+ InjuriesDetailListingConstructor(..),
+ InjuriesDetailListingPlayerListingConstructor(..) )
where
-- System imports.
+import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
+ DefaultKey,
migrate )
import Database.Groundhog.TH (
- defaultCodegenConfig,
groundhog,
mkPersist )
import Test.Tasty ( TestTree, testGroup )
xpWrap )
-- Local imports.
-import TSN.Picklers( xp_date )
+import TSN.Codegen ( tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import TSN.Picklers( xp_date, xp_time_stamp )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+ FromXml(..),
+ FromXmlFk(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable )
--- | Database representation of a \<PlayerListing\>, the main type of
--- element contains in Injuries_Detail_XML messages.
--
-data PlayerListing =
- PlayerListing {
- 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 :: 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)
+-- Data types
+--
+
+-- * InjuriesDetail/Message
-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
+-- | 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)
--- | This lets us call 'insert_xml' on a 'PlayerListing' without
--- having to explicitly convert it to its database analogue first.
+-- | Database representation of a 'Message'.
--
-instance XmlImport PlayerListing
+data InjuriesDetail =
+ InjuriesDetail {
+ 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_sport = xml_sport,
+ db_time_stamp = xml_time_stamp }
+
+
+-- | This allows us to call 'insert_xml' directly on the XML
+-- representation.
+instance XmlImport Message
+
+
+
+-- * InjuriesDetailListing/InjuriesDetailListingXml
+
+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 Listing =
- Listing {
- 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] }
+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
+ type Db InjuriesDetailListingXml = InjuriesDetailListing
--- | XML representation of the top-level \<message\> element. These
--- are not stored; the data type is used only for parsing.
+instance FromXmlFk InjuriesDetailListingXml where
+ type Parent InjuriesDetailListingXml = InjuriesDetail
+
+ from_xml_fk fk InjuriesDetailListingXml{..} =
+ InjuriesDetailListing {
+ db_injuries_detail_id = fk,
+ db_team_id = xml_team_id,
+ db_full_name = xml_full_name }
+
+instance XmlImportFk InjuriesDetailListingXml
+
+
+-- * InjuriesDetailListingPlayerListing
+
+-- | XML representation of a \<PlayerListing\>, the main type of
+-- element contains in Injuries_Detail_XML messages.
--
-data Message =
- Message {
- xml_file_id :: Int,
- heading :: String,
- category :: String,
- sport :: String,
- listings :: [Listing],
- time_stamp :: String }
+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 FromXmlFk InjuriesDetailListingPlayerListingXml where
+ type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
+
+ -- | To convert between a 'InjuriesDetailListingPlayerListingXml'
+ -- and a 'InjuriesDetailListingPlayerListingXml', we do nothing.
+ 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 call 'insert_xml' on a
+-- 'InjuriesDetailListingPlayerListingXml' without having to
+-- explicitly convert it to its database analogue first.
+--
+instance XmlImportFk InjuriesDetailListingPlayerListingXml
+
+
+--
+-- Database stuff
+--
+
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.
+ -- | To import a 'Message', we import all of its
+ -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its
+ -- 'Listing's.
dbimport msg = do
- mapM_ insert_xml (concatMap player_listings $ listings msg)
- return ImportSucceeded
+ msg_id <- insert_xml msg
- dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
+ 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 defaultCodegenConfig [groundhog|
-- entity: PlayerListing
- dbName: injuries_detail_player_listings
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: InjuriesDetail)
+ migrate (undefined :: InjuriesDetailListing)
+ migrate (undefined :: InjuriesDetailListingPlayerListing)
+
+
+mkPersist tsn_codegen_config [groundhog|
+- entity: InjuriesDetail
+ dbName: injuries_detail
+
+- 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
|]
--- | Convert 'PlayerListing's to/from XML.
+
+--
+-- Pickling
+--
+
+-- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
--
-pickle_player_listing :: PU PlayerListing
+pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
pickle_player_listing =
xpElem "PlayerListing" $
xpWrap (from_tuple, to_tuple) $
(xpElem "Injured" xpPrim)
(xpElem "Type" xpText)
where
- from_tuple = uncurryN PlayerListing
- to_tuple pl = (team_id pl,
- player_id pl,
- date pl,
- pos pl,
- name pl,
- injury pl,
- status pl,
- fantasy pl,
- injured pl,
- injury_type pl)
+ 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 Listing
+pickle_listing :: PU InjuriesDetailListingXml
pickle_listing =
xpElem "Listing" $
xpWrap (from_tuple, to_tuple) $
(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)
+ 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.
(xpElem "category" xpText)
(xpElem "sport" xpText)
(xpList pickle_listing)
- (xpElem "time_stamp" xpText)
+ (xpElem "time_stamp" xp_time_stamp)
where
from_tuple = uncurryN Message
- to_tuple m = (xml_file_id m,
- heading m,
- category m,
- sport m,
- listings m,
- time_stamp m)
+ to_tuple m = (xml_xml_file_id m,
+ xml_heading m,
+ xml_category m,
+ xml_sport m,
+ xml_listings m,
+ xml_time_stamp m)
--
projects / dead / htsn-import.git / commitdiff
