1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
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.
15 -- The player listings will be mapped to a database table called
16 -- \"injuries_detail_player_listings\" automatically. The root
17 -- \"message\" and \"listing\" are not retained.
19 module TSN.XML.InjuriesDetail (
22 injuries_detail_tests,
23 -- * WARNING: these are private but exported to silence warnings
24 PlayerListingConstructor(..) )
28 import Data.Time ( UTCTime )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
32 import Database.Groundhog.TH (
36 import Test.Tasty ( TestTree, testGroup )
37 import Test.Tasty.HUnit ( (@?=), testCase )
38 import Text.XML.HXT.Core (
52 import TSN.Picklers( xp_date, xp_team_id )
53 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
54 import TSN.XmlImport ( XmlImport(..) )
55 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
58 -- | Database representation of a \<PlayerListing\>, the main type of
59 -- element contains in Injuries_Detail_XML messages.
63 team_id :: String, -- ^ TeamIDs are (apparently) three characters long
64 -- and not necessarily numeric.
71 fantasy :: Maybe String, -- ^ Nobody knows what this is.
73 injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
78 instance FromXml PlayerListing where
79 -- | The DB analogue of a 'PlayerListing' is... itself!
80 type Db PlayerListing = PlayerListing
82 -- | To convert between a 'PlayerListing' and a 'PlayerListing',
86 -- | This lets us call 'insert_xml' on a 'PlayerListing' without
87 -- having to explicitly convert it to its database analogue first.
89 instance XmlImport PlayerListing
92 -- | XML incarnation of a \<Listing\> element. We don't store these;
93 -- the data type is used only for parsing.
97 listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id.
98 -- TeamIDs are (apparently) three characters
99 -- long and not necessarily numeric.
100 , full_name :: String, -- ^ Team full name
101 player_listings :: [PlayerListing] }
105 -- | XML representation of the top-level \<message\> element. These
106 -- are not stored; the data type is used only for parsing.
114 listings :: [Listing],
115 time_stamp :: String }
118 instance DbImport Message where
119 -- | To import a 'Message', we import all of its 'PlayerListing's,
120 -- which we have to dig out of its 'Listing's.
122 mapM_ insert_xml (concatMap player_listings $ listings msg)
123 return ImportSucceeded
125 dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
128 mkPersist defaultCodegenConfig [groundhog|
129 - entity: PlayerListing
130 dbName: injuries_detail_player_listings
132 - name: PlayerListing
135 type: varchar(3) # We've only seen 3... so far.
139 -- | Convert 'PlayerListing's to/from XML.
141 pickle_player_listing :: PU PlayerListing
142 pickle_player_listing =
143 xpElem "PlayerListing" $
144 xpWrap (from_tuple, to_tuple) $
145 xp10Tuple (xpElem "TeamID" xp_team_id)
146 (xpElem "PlayerID" xpInt)
147 (xpElem "Date" xp_date)
148 (xpElem "Pos" xpText)
149 (xpElem "Name" xpText)
150 (xpElem "Injury" xpText)
151 (xpElem "Status" xpText)
152 (xpElem "Fantasy" $ xpOption xpText)
153 (xpElem "Injured" xpPrim)
154 (xpElem "Type" xpText)
156 from_tuple = uncurryN PlayerListing
157 to_tuple pl = (team_id pl,
169 -- | Convert 'Listing's to/from XML.
171 pickle_listing :: PU Listing
174 xpWrap (from_tuple, to_tuple) $
175 xpTriple (xpElem "TeamID" xp_team_id)
176 (xpElem "FullName" xpText)
177 (xpList pickle_player_listing)
179 from_tuple = uncurryN Listing
180 to_tuple l = (listing_team_id l, full_name l, player_listings l)
183 -- | Convert 'Message's to/from XML.
185 pickle_message :: PU Message
188 xpWrap (from_tuple, to_tuple) $
189 xp6Tuple (xpElem "XML_File_ID" xpInt)
190 (xpElem "heading" xpText)
191 (xpElem "category" xpText)
192 (xpElem "sport" xpText)
193 (xpList pickle_listing)
194 (xpElem "time_stamp" xpText)
196 from_tuple = uncurryN Message
197 to_tuple m = (xml_file_id m,
209 -- | A list of all tests for this module.
211 injuries_detail_tests :: TestTree
212 injuries_detail_tests =
214 "InjuriesDetail tests"
215 [ test_pickle_of_unpickle_is_identity,
216 test_unpickle_succeeds ]
219 -- | If we unpickle something and then pickle it, we should wind up
220 -- with the same thing we started with. WARNING: succeess of this
221 -- test does not mean that unpickling succeeded.
223 test_pickle_of_unpickle_is_identity :: TestTree
224 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
225 [ check "pickle composed with unpickle is the identity"
226 "test/xml/Injuries_Detail_XML.xml",
228 check "pickle composed with unpickle is the identity (non-int team_id)"
229 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
231 check desc path = testCase desc $ do
232 (expected, actual) <- pickle_unpickle pickle_message path
236 -- | Make sure we can actually unpickle these things.
238 test_unpickle_succeeds :: TestTree
239 test_unpickle_succeeds = testGroup "unpickle tests"
240 [ check "unpickling succeeds"
241 "test/xml/Injuries_Detail_XML.xml",
243 check "unpickling succeeds (non-int team_id)"
244 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
246 check desc path = testCase desc $ do
247 actual <- unpickleable path pickle_message