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" automatically. The root "message" and "listing"
19 module TSN.XML.InjuriesDetail (
22 injuries_detail_tests,
23 -- * WARNING: these are private but exported to silence warnings
24 PlayerListingConstructor(..) )
27 import Data.Time ( UTCTime )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
31 import Database.Groundhog.TH (
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
50 import TSN.Picklers( xp_date, xp_team_id )
51 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
52 import TSN.XmlImport ( XmlImport(..) )
53 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
58 team_id :: String, -- ^ TeamIDs are (apparently) three characters long
59 -- and not necessarily numeric.
66 fantasy :: Maybe String, -- ^ Nobody knows what this is.
68 injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
72 instance FromXml PlayerListing where
73 type Db PlayerListing = PlayerListing
76 instance XmlImport PlayerListing
80 listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id.
81 -- TeamIDs are (apparently) three characters
82 -- long and not necessarily numeric.
83 , full_name :: String, -- ^ Team full name
84 player_listings :: [PlayerListing] }
94 listings :: [Listing],
95 time_stamp :: String }
98 instance DbImport Message where
100 mapM_ insert_xml (concatMap player_listings $ listings msg)
101 return ImportSucceeded
103 dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
105 mkPersist defaultCodegenConfig [groundhog|
106 - entity: PlayerListing
107 dbName: injuries_detail_player_listings
109 - name: PlayerListing
116 pickle_player_listing :: PU PlayerListing
117 pickle_player_listing =
118 xpElem "PlayerListing" $
119 xpWrap (from_tuple, to_tuple) $
120 xp10Tuple (xpElem "TeamID" xp_team_id)
121 (xpElem "PlayerID" xpInt)
122 (xpElem "Date" xp_date)
123 (xpElem "Pos" xpText)
124 (xpElem "Name" xpText)
125 (xpElem "Injury" xpText)
126 (xpElem "Status" xpText)
127 (xpElem "Fantasy" $ xpOption xpText)
128 (xpElem "Injured" xpPrim)
129 (xpElem "Type" xpText)
131 from_tuple = uncurryN PlayerListing
132 to_tuple pl = (team_id pl,
144 pickle_listing :: PU Listing
147 xpWrap (from_tuple, to_tuple) $
148 xpTriple (xpElem "TeamID" xp_team_id)
149 (xpElem "FullName" xpText)
150 (xpList pickle_player_listing)
152 from_tuple = uncurryN Listing
153 to_tuple l = (listing_team_id l, full_name l, player_listings l)
156 pickle_message :: PU Message
159 xpWrap (from_tuple, to_tuple) $
160 xp6Tuple (xpElem "XML_File_ID" xpInt)
161 (xpElem "heading" xpText)
162 (xpElem "category" xpText)
163 (xpElem "sport" xpText)
164 (xpList pickle_listing)
165 (xpElem "time_stamp" xpText)
167 from_tuple = uncurryN Message
168 to_tuple m = (xml_file_id m,
179 -- | A list of all tests for this module.
181 injuries_detail_tests :: TestTree
182 injuries_detail_tests =
184 "InjuriesDetail tests"
185 [ test_pickle_of_unpickle_is_identity,
186 test_unpickle_succeeds ]
189 -- | If we unpickle something and then pickle it, we should wind up
190 -- with the same thing we started with. WARNING: succeess of this
191 -- test does not mean that unpickling succeeded.
193 test_pickle_of_unpickle_is_identity :: TestTree
194 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
195 [ check "pickle composed with unpickle is the identity"
196 "test/xml/Injuries_Detail_XML.xml",
198 check "pickle composed with unpickle is the identity (non-int team_id)"
199 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
201 check desc path = testCase desc $ do
202 (expected, actual) <- pickle_unpickle pickle_message path
206 -- | Make sure we can actually unpickle these things.
208 test_unpickle_succeeds :: TestTree
209 test_unpickle_succeeds = testGroup "unpickle tests"
210 [ check "unpickling succeeds"
211 "test/xml/Injuries_Detail_XML.xml",
213 check "unpickling succeeds (non-int team_id)"
214 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
216 check desc path = testCase desc $ do
217 actual <- unpickleable path pickle_message