+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# 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" automatically. The root "message" and "listing"
+-- are not retained.
+--
+module TSN.InjuriesDetail (
+ Message )
+where
+
+import Data.Time ( UTCTime )
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog()
+import Database.Groundhog.TH
+import Text.XML.HXT.Core (
+ PU,
+ XmlPickler(..),
+ xpTriple,
+ xp6Tuple,
+ xp10Tuple,
+ xpElem,
+ xpList,
+ xpPrim,
+ xpText,
+ xpText0,
+ xpWrap )
+
+import TSN.Picklers( xp_date )
+
+data PlayerListing =
+ PlayerListing {
+ team_id :: Int,
+ player_id :: Int,
+ date :: UTCTime,
+ pos :: String,
+ name :: String,
+ injury :: String,
+ status :: String,
+ fantasy :: String, -- ^ Nobody knows what this is.
+ injured :: Bool,
+ injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
+ }
+ deriving (Show)
+
+data Listing =
+ Listing {
+ listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
+ , full_name :: String, -- ^ Team full name
+ player_listings :: [PlayerListing] }
+ deriving (Show)
+
+data Message =
+ Message {
+ xml_file_id :: Int,
+ heading :: String,
+ category :: String,
+ sport :: String,
+ listings :: [Listing],
+ time_stamp :: String }
+ deriving (Show)
+
+
+mkPersist defaultCodegenConfig [groundhog|
+- entity: PlayerListing
+ dbName: injuries_detail
+|]
+
+--TODO see if it works witout this
+--xpBool :: PU Bool
+--xpBool = xpickle
+
+pickle_player_listing :: PU PlayerListing
+pickle_player_listing =
+ xpElem "PlayerListing" $
+ xpWrap (from_tuple, to_tuple) $
+ xp10Tuple (xpElem "TeamID" xpPrim)
+ (xpElem "PlayerID" xpPrim)
+ (xpElem "Date" xp_date)
+ (xpElem "Pos" xpText)
+ (xpElem "Name" xpText)
+ (xpElem "Injury" xpText)
+ (xpElem "Status" xpText)
+ (xpElem "Fantasy" xpText0)
+ (xpElem "Injured" xpickle)
+ (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)
+
+instance XmlPickler PlayerListing where
+ xpickle = pickle_player_listing
+
+pickle_listing :: PU Listing
+pickle_listing =
+ xpElem "Listing" $
+ xpWrap (from_tuple, to_tuple) $
+ xpTriple (xpElem "TeamID" xpPrim)
+ (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)
+
+instance XmlPickler Listing where
+ xpickle = pickle_listing
+
+
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, to_tuple) $
+ xp6Tuple (xpElem "XML_File_ID" xpPrim)
+ (xpElem "heading" xpText)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpList pickle_listing)
+ (xpElem "time_stamp" xpText)
+ where
+ from_tuple = uncurryN Message
+ to_tuple m = (xml_file_id m,
+ heading m,
+ category m,
+ sport m,
+ listings m,
+ time_stamp m)
+
+instance XmlPickler Message where
+ xpickle = pickle_message