1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
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.
16 -- The player listings will be mapped to a database table called
17 -- "injuries_detail" automatically. The root "message" and "listing"
20 module TSN.InjuriesDetail (
21 Listing ( player_listings ),
24 injuries_detail_tests )
27 import Data.Time ( UTCTime )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog()
30 import Database.Groundhog.TH (
34 import Test.Tasty ( TestTree, testGroup )
35 import Test.Tasty.HUnit ( (@?=), testCase )
36 import Text.XML.HXT.Core (
49 import TSN.DbImport ( DbImport(..), import_generic )
50 import TSN.Picklers( xp_date, xp_team_id )
51 import Xml ( pickle_unpickle )
63 fantasy :: String, -- ^ Nobody knows what this is.
65 injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
71 listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
72 , full_name :: String, -- ^ Team full name
73 player_listings :: [PlayerListing] }
82 listings :: [Listing],
83 time_stamp :: String }
87 mkPersist defaultCodegenConfig [groundhog|
88 - entity: PlayerListing
89 dbName: injuries_detail
93 pickle_player_listing :: PU PlayerListing
94 pickle_player_listing =
95 xpElem "PlayerListing" $
96 xpWrap (from_tuple, to_tuple) $
97 xp10Tuple (xpElem "TeamID" xp_team_id)
98 (xpElem "PlayerID" xpPrim)
99 (xpElem "Date" xp_date)
100 (xpElem "Pos" xpText)
101 (xpElem "Name" xpText)
102 (xpElem "Injury" xpText)
103 (xpElem "Status" xpText)
104 (xpElem "Fantasy" xpText0)
105 (xpElem "Injured" xpickle)
106 (xpElem "Type" xpText)
108 from_tuple = uncurryN PlayerListing
109 to_tuple pl = (team_id pl,
120 instance XmlPickler PlayerListing where
121 xpickle = pickle_player_listing
123 pickle_listing :: PU Listing
126 xpWrap (from_tuple, to_tuple) $
127 xpTriple (xpElem "TeamID" xp_team_id)
128 (xpElem "FullName" xpText)
129 (xpList pickle_player_listing)
131 from_tuple = uncurryN Listing
132 to_tuple l = (listing_team_id l, full_name l, player_listings l)
134 instance XmlPickler Listing where
135 xpickle = pickle_listing
138 pickle_message :: PU Message
141 xpWrap (from_tuple, to_tuple) $
142 xp6Tuple (xpElem "XML_File_ID" xpPrim)
143 (xpElem "heading" xpText)
144 (xpElem "category" xpText)
145 (xpElem "sport" xpText)
146 (xpList pickle_listing)
147 (xpElem "time_stamp" xpText)
149 from_tuple = uncurryN Message
150 to_tuple m = (xml_file_id m,
157 instance XmlPickler Message where
158 xpickle = pickle_message
160 instance DbImport PlayerListing where
161 dbimport = import_generic ( (concatMap player_listings) . listings)
165 injuries_detail_tests :: TestTree
166 injuries_detail_tests =
168 "InjuriesDetail tests"
169 [ test_pickle_of_unpickle_is_identity ]
172 test_pickle_of_unpickle_is_identity :: TestTree
173 test_pickle_of_unpickle_is_identity =
174 testCase "pickle composed with unpickle is the identity" $ do
175 let path = "test/xml/Injuries_Detail_XML.xml"
176 (expected :: [Message], actual) <- pickle_unpickle "message" path