src/TSN/InjuriesDetail.hs

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