From: Michael Orlitzky Date: Tue, 21 Jan 2014 04:30:12 +0000 (-0500) Subject: Update TSN.XML.InjuriesDetail for the new typeclass hierarchy. X-Git-Tag: 0.0.1~20 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=e207228e7b7b47f4cbe16b578ce16cea009b15f9;p=dead%2Fhtsn-import.git Update TSN.XML.InjuriesDetail for the new typeclass hierarchy. Add InjuriesDetail and InjuriesDetailListing to the database. Update the database schema diagram for Injuries_Detail_XML. --- diff --git a/doc/dbschema/Injuries_Detail_XML.png b/doc/dbschema/Injuries_Detail_XML.png index f4db18e..616f98a 100644 Binary files a/doc/dbschema/Injuries_Detail_XML.png and b/doc/dbschema/Injuries_Detail_XML.png differ diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index b51c19d..fee6ce2 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,29 +9,27 @@ -- | 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 then contain the real --- meat; everything contained in the parent \ can also be --- found within the \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. +-- \s contain \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 ) @@ -49,95 +48,239 @@ import Text.XML.HXT.Core ( 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 \, 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 \ 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 \ 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 \ 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 \, 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) $ @@ -152,22 +295,22 @@ pickle_player_listing = (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) $ @@ -175,8 +318,10 @@ pickle_listing = (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. @@ -190,15 +335,15 @@ pickle_message = (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) --