src/TSN/InjuriesDetail.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
   9 --   document contains a root element \<message\> that in turn
  10 --   contains zero or more \<Listing\>s (note: capitalization). The
  11 --   \<Listing\>s contain \<PlayerListing\>s then contain the real
  12 --   meat; everything contained in the parent \<Listing\> can also be
  13 --   found within the \<PlayerListing\>s.
  14 --
  15 --   The player listings will be mapped to a database table called
  16 --   "injuries_detail" automatically. The root "message" and "listing"
  17 --   are not retained.
  18 --
  19 module TSN.InjuriesDetail (
  20   Listing ( player_listings ),
  21   Message ( listings ),
  22   PlayerListing )
  23 where
  24
  25 import Data.Time ( UTCTime )
  26 import Data.Tuple.Curry ( uncurryN )
  27 import Database.Groundhog()
  28 import Database.Groundhog.TH
  29 import Text.XML.HXT.Core (
  30   PU,
  31   XmlPickler(..),
  32   xpTriple,
  33   xp6Tuple,
  34   xp10Tuple,
  35   xpElem,
  36   xpList,
  37   xpPrim,
  38   xpText,
  39   xpText0,
  40   xpWrap )
  41
  42 import TSN.Picklers( xp_date )
  43
  44 data PlayerListing =
  45   PlayerListing {
  46     team_id   :: Int,
  47     player_id :: Int,
  48     date      :: UTCTime,
  49     pos       :: String,
  50     name      :: String,
  51     injury    :: String,
  52     status    :: String,
  53     fantasy   :: String, -- ^ Nobody knows what this is.
  54     injured     :: Bool,
  55     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
  56     }
  57   deriving (Show)
  58
  59 data Listing =
  60   Listing {
  61     listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
  62     , full_name :: String, -- ^ Team full name
  63     player_listings :: [PlayerListing] }
  64   deriving (Show)
  65
  66 data Message =
  67   Message {
  68     xml_file_id :: Int,
  69     heading :: String,
  70     category :: String,
  71     sport :: String,
  72     listings :: [Listing],
  73     time_stamp :: String }
  74   deriving (Show)
  75
  76
  77 mkPersist defaultCodegenConfig [groundhog|
  78 - entity: PlayerListing
  79   dbName: injuries_detail
  80 |]
  81
  82
  83 pickle_player_listing :: PU PlayerListing
  84 pickle_player_listing =
  85   xpElem "PlayerListing" $
  86     xpWrap (from_tuple, to_tuple) $
  87     xp10Tuple (xpElem "TeamID" xpPrim)
  88               (xpElem "PlayerID" xpPrim)
  89               (xpElem "Date" xp_date)
  90               (xpElem "Pos" xpText)
  91               (xpElem "Name" xpText)
  92               (xpElem "Injury" xpText)
  93               (xpElem "Status" xpText)
  94               (xpElem "Fantasy" xpText0)
  95               (xpElem "Injured" xpickle)
  96               (xpElem "Type" xpText)
  97   where
  98     from_tuple = uncurryN PlayerListing
  99     to_tuple pl = (team_id pl,
 100                    player_id pl,
 101                    date pl,
 102                    pos pl,
 103                    name pl,
 104                    injury pl,
 105                    status pl,
 106                    fantasy pl,
 107                    injured pl,
 108                    injury_type pl)
 109
 110 instance XmlPickler PlayerListing where
 111   xpickle = pickle_player_listing
 112
 113 pickle_listing :: PU Listing
 114 pickle_listing =
 115   xpElem "Listing" $
 116     xpWrap (from_tuple, to_tuple) $
 117     xpTriple (xpElem "TeamID" xpPrim)
 118              (xpElem "FullName" xpText)
 119              (xpList pickle_player_listing)
 120   where
 121     from_tuple = uncurryN Listing
 122     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 123
 124 instance XmlPickler Listing where
 125   xpickle = pickle_listing
 126
 127
 128 pickle_message :: PU Message
 129 pickle_message =
 130   xpElem "message" $
 131     xpWrap (from_tuple, to_tuple) $
 132     xp6Tuple (xpElem "XML_File_ID" xpPrim)
 133              (xpElem "heading" xpText)
 134              (xpElem "category" xpText)
 135              (xpElem "sport" xpText)
 136              (xpList pickle_listing)
 137              (xpElem "time_stamp" xpText)
 138   where
 139     from_tuple = uncurryN Message
 140     to_tuple m = (xml_file_id m,
 141                   heading m,
 142                   category m,
 143                   sport m,
 144                   listings m,
 145                   time_stamp m)
 146
 147 instance XmlPickler Message where
 148   xpickle = pickle_message