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.XML.InjuriesDetail (
22 injuries_detail_tests )
25 import Data.Time ( UTCTime )
26 import Data.Tuple.Curry ( uncurryN )
27 import Database.Groundhog (
29 import Database.Groundhog.TH (
33 import Test.Tasty ( TestTree, testGroup )
34 import Test.Tasty.HUnit ( (@?=), testCase )
35 import Text.XML.HXT.Core (
49 import TSN.Picklers( xp_date, xp_team_id )
50 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
51 import TSN.XmlImport ( XmlImport(..) )
52 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
64 fantasy :: String, -- ^ Nobody knows what this is.
66 injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
70 instance FromXml PlayerListing where
71 type Db PlayerListing = PlayerListing
74 instance XmlImport PlayerListing
78 listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
79 , full_name :: String, -- ^ Team full name
80 player_listings :: [PlayerListing] }
90 listings :: [Listing],
91 time_stamp :: String }
94 instance DbImport Message where
96 mapM_ insert_xml (concatMap player_listings $ listings msg)
97 return ImportSucceeded
99 dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
101 mkPersist defaultCodegenConfig [groundhog|
102 - entity: PlayerListing
103 dbName: injuries_detail_player_listings
107 pickle_player_listing :: PU PlayerListing
108 pickle_player_listing =
109 xpElem "PlayerListing" $
110 xpWrap (from_tuple, to_tuple) $
111 xp10Tuple (xpElem "TeamID" xp_team_id)
112 (xpElem "PlayerID" xpInt)
113 (xpElem "Date" xp_date)
114 (xpElem "Pos" xpText)
115 (xpElem "Name" xpText)
116 (xpElem "Injury" xpText)
117 (xpElem "Status" xpText)
118 (xpElem "Fantasy" xpText0)
119 (xpElem "Injured" xpPrim)
120 (xpElem "Type" xpText)
122 from_tuple = uncurryN PlayerListing
123 to_tuple pl = (team_id pl,
134 instance XmlPickler PlayerListing where
135 xpickle = pickle_player_listing
137 pickle_listing :: PU Listing
140 xpWrap (from_tuple, to_tuple) $
141 xpTriple (xpElem "TeamID" xp_team_id)
142 (xpElem "FullName" xpText)
143 (xpList pickle_player_listing)
145 from_tuple = uncurryN Listing
146 to_tuple l = (listing_team_id l, full_name l, player_listings l)
148 instance XmlPickler Listing where
149 xpickle = pickle_listing
152 pickle_message :: PU Message
155 xpWrap (from_tuple, to_tuple) $
156 xp6Tuple (xpElem "XML_File_ID" xpInt)
157 (xpElem "heading" xpText)
158 (xpElem "category" xpText)
159 (xpElem "sport" xpText)
160 (xpList pickle_listing)
161 (xpElem "time_stamp" xpText)
163 from_tuple = uncurryN Message
164 to_tuple m = (xml_file_id m,
171 instance XmlPickler Message where
172 xpickle = pickle_message
176 injuries_detail_tests :: TestTree
177 injuries_detail_tests =
179 "InjuriesDetail tests"
180 [ test_pickle_of_unpickle_is_identity,
181 test_unpickle_succeeds ]
184 -- | Warning, succeess of this test does not mean that unpickling
186 test_pickle_of_unpickle_is_identity :: TestTree
187 test_pickle_of_unpickle_is_identity =
188 testCase "pickle composed with unpickle is the identity" $ do
189 let path = "test/xml/Injuries_Detail_XML.xml"
190 (expected :: [Message], actual) <- pickle_unpickle "message" path
194 test_unpickle_succeeds :: TestTree
195 test_unpickle_succeeds =
196 testCase "unpickling succeeds" $ do
197 let path = "test/xml/Injuries_Detail_XML.xml"
198 actual <- unpickleable path pickle_message