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   Message )
  21 where
  22
  23 import Data.Time ( UTCTime )
  24 import Data.Tuple.Curry ( uncurryN )
  25 import Database.Groundhog()
  26 import Database.Groundhog.TH
  27 import Text.XML.HXT.Core (
  28   PU,
  29   XmlPickler(..),
  30   xpTriple,
  31   xp6Tuple,
  32   xp10Tuple,
  33   xpElem,
  34   xpList,
  35   xpPrim,
  36   xpText,
  37   xpText0,
  38   xpWrap )
  39
  40 import TSN.Picklers( xp_date )
  41
  42 data PlayerListing =
  43   PlayerListing {
  44     team_id   :: Int,
  45     player_id :: Int,
  46     date      :: UTCTime,
  47     pos       :: String,
  48     name      :: String,
  49     injury    :: String,
  50     status    :: String,
  51     fantasy   :: String, -- ^ Nobody knows what this is.
  52     injured     :: Bool,
  53     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
  54     }
  55   deriving (Show)
  56
  57 data Listing =
  58   Listing {
  59     listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
  60     , full_name :: String, -- ^ Team full name
  61     player_listings :: [PlayerListing] }
  62   deriving (Show)
  63
  64 data Message =
  65   Message {
  66     xml_file_id :: Int,
  67     heading :: String,
  68     category :: String,
  69     sport :: String,
  70     listings :: [Listing],
  71     time_stamp :: String }
  72   deriving (Show)
  73
  74
  75 mkPersist defaultCodegenConfig [groundhog|
  76 - entity: PlayerListing
  77   dbName: injuries_detail
  78 |]
  79
  80 --TODO see if it works witout this
  81 --xpBool :: PU Bool
  82 --xpBool = xpickle
  83
  84 pickle_player_listing :: PU PlayerListing
  85 pickle_player_listing =
  86   xpElem "PlayerListing" $
  87     xpWrap (from_tuple, to_tuple) $
  88     xp10Tuple (xpElem "TeamID" xpPrim)
  89               (xpElem "PlayerID" xpPrim)
  90               (xpElem "Date" xp_date)
  91               (xpElem "Pos" xpText)
  92               (xpElem "Name" xpText)
  93               (xpElem "Injury" xpText)
  94               (xpElem "Status" xpText)
  95               (xpElem "Fantasy" xpText0)
  96               (xpElem "Injured" xpickle)
  97               (xpElem "Type" xpText)
  98   where
  99     from_tuple = uncurryN PlayerListing
 100     to_tuple pl = (team_id pl,
 101                    player_id pl,
 102                    date pl,
 103                    pos pl,
 104                    name pl,
 105                    injury pl,
 106                    status pl,
 107                    fantasy pl,
 108                    injured pl,
 109                    injury_type pl)
 110
 111 instance XmlPickler PlayerListing where
 112   xpickle = pickle_player_listing
 113
 114 pickle_listing :: PU Listing
 115 pickle_listing =
 116   xpElem "Listing" $
 117     xpWrap (from_tuple, to_tuple) $
 118     xpTriple (xpElem "TeamID" xpPrim)
 119              (xpElem "FullName" xpText)
 120              (xpList pickle_player_listing)
 121   where
 122     from_tuple = uncurryN Listing
 123     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 124
 125 instance XmlPickler Listing where
 126   xpickle = pickle_listing
 127
 128
 129 pickle_message :: PU Message
 130 pickle_message =
 131   xpElem "message" $
 132     xpWrap (from_tuple, to_tuple) $
 133     xp6Tuple (xpElem "XML_File_ID" xpPrim)
 134              (xpElem "heading" xpText)
 135              (xpElem "category" xpText)
 136              (xpElem "sport" xpText)
 137              (xpList pickle_listing)
 138              (xpElem "time_stamp" xpText)
 139   where
 140     from_tuple = uncurryN Message
 141     to_tuple m = (xml_file_id m,
 142                   heading m,
 143                   category m,
 144                   sport m,
 145                   listings m,
 146                   time_stamp m)
 147
 148 instance XmlPickler Message where
 149   xpickle = pickle_message