1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
11 -- contains a root element \<message\> that in turn contains zero or
14 -- The listings will be mapped to a database table called
15 -- \"injuries_listings\" automatically. The root message is retained
16 -- so that we can easily delete its associated listings based on its
19 module TSN.XML.Injuries (
23 -- * WARNING: these are private but exported to silence warnings
24 InjuriesConstructor(..),
25 InjuriesListingConstructor(..) )
29 import Data.Data ( Data )
30 import Data.Time ( UTCTime )
31 import Data.Typeable ( Typeable )
32 import Database.Groundhog ( migrate )
33 import Database.Groundhog.Core ( DefaultKey )
34 import Database.Groundhog.TH (
37 import Data.Tuple.Curry ( uncurryN )
38 import Test.Tasty ( TestTree, testGroup )
39 import Test.Tasty.HUnit ( (@?=), testCase )
40 import Text.XML.HXT.Core (
55 import TSN.Codegen ( tsn_codegen_config )
56 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
57 import TSN.Picklers ( xp_time_stamp )
58 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
73 -- | XML/Database representation of a team as they appear in the
74 -- injuries documents.
78 db_team_name :: String,
79 db_team_league :: Maybe String }
80 deriving (Data, Eq, Show, Typeable)
83 -- * InjuriesListing/InjuriesListingXml
85 -- | XML representation of the injury listings.
87 data InjuriesListingXml =
89 xml_team :: InjuriesTeam,
90 xml_teamno :: Maybe Int,
91 xml_injuries :: String,
92 xml_updated :: Maybe Bool }
95 -- | Database representation of a 'InjuriesListing'. It possesses a
96 -- foreign key to an 'Injuries' object so that we can easily delete
97 -- 'InjuriesListing's based on the parent message's time_stamp.
99 data InjuriesListing =
101 db_injuries_id :: DefaultKey Injuries,
102 db_team :: InjuriesTeam,
103 db_teamno :: Maybe Int,
104 db_injuries :: String,
105 db_updated :: Maybe Bool }
107 instance ToDb InjuriesListingXml where
108 -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
109 type Db InjuriesListingXml = InjuriesListing
111 instance FromXmlFk InjuriesListingXml where
112 -- | Our foreign key points to an 'Injuries'.
113 type Parent InjuriesListingXml = Injuries
115 -- | To convert between a 'InjuriesListingXml' and a
116 -- 'InjuriesListing', we simply append the foreign key.
117 from_xml_fk fk InjuriesListingXml{..} =
121 db_teamno = xml_teamno,
122 db_injuries = xml_injuries,
123 db_updated = xml_updated }
125 -- | This allows us to insert the XML representation
126 -- 'InjuriesListingXml' directly.
128 instance XmlImportFk InjuriesListingXml
131 -- * Injuries/Message
133 -- | XML representation of an injuriesxml \<message\>.
137 xml_xml_file_id :: Int,
138 xml_heading :: String,
139 xml_category :: String,
141 xml_listings :: [InjuriesListingXml],
142 xml_time_stamp :: UTCTime }
145 -- | Database representation of a 'Message'.
149 db_xml_file_id :: Int,
151 db_time_stamp :: UTCTime }
153 instance ToDb Message where
154 -- | The database analogue of a 'Message' is an 'Injuries'.
155 type Db Message = Injuries
157 instance FromXml Message where
158 -- | To convert from XML to DB, we simply drop the fields we don't
161 from_xml Message{..} =
163 db_xml_file_id = xml_xml_file_id,
164 db_sport = xml_sport,
165 db_time_stamp = xml_time_stamp }
167 -- | This allows us to insert the XML representation 'Message'
170 instance XmlImport Message
177 instance DbImport Message where
180 migrate (undefined :: Injuries)
181 migrate (undefined :: InjuriesListing)
183 -- | We import a 'Message' by inserting all of its 'listings', but
184 -- the listings require a foreign key to the parent 'Message'.
187 msg_id <- insert_xml msg
189 -- Convert each XML listing to a DB one using the message id and
190 -- insert it (disregarding the result).
191 mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
193 return ImportSucceeded
196 mkPersist tsn_codegen_config [groundhog|
201 - name: unique_injuries
203 # Prevent multiple imports of the same message.
204 fields: [db_xml_file_id]
206 - entity: InjuriesListing
207 dbName: injuries_listings
209 - name: InjuriesListing
213 - {name: team_name, dbName: team_name}
214 - {name: team_league, dbName: team_league}
215 - name: db_injuries_id
219 - embedded: InjuriesTeam
222 - name: db_team_league
231 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
233 pickle_injuries_team :: PU InjuriesTeam
234 pickle_injuries_team =
236 xpWrap (from_tuple, to_tuple) $
237 xpPair xpText (xpAttrImplied "league" xpText)
239 from_tuple = uncurryN InjuriesTeam
240 to_tuple m = (db_team_name m, db_team_league m)
243 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
246 pickle_listing :: PU InjuriesListingXml
249 xpWrap (from_tuple, to_tuple) $
250 xp4Tuple pickle_injuries_team
251 (xpOption $ xpElem "teamno" xpInt)
252 (xpElem "injuries" xpText)
253 (xpOption $ xpElem "updated" xpPrim)
255 from_tuple = uncurryN InjuriesListingXml
256 to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
259 -- | A pickler for 'Message's that can convert them to/from XML.
261 pickle_message :: PU Message
264 xpWrap (from_tuple, to_tuple) $
265 xp6Tuple (xpElem "XML_File_ID" xpInt)
266 (xpElem "heading" xpText)
267 (xpElem "category" xpText)
268 (xpElem "sport" xpText)
269 (xpList pickle_listing)
270 (xpElem "time_stamp" xp_time_stamp)
272 from_tuple = uncurryN Message
273 to_tuple m = (xml_xml_file_id m,
285 -- | A list of all tests for this module.
287 injuries_tests :: TestTree
291 [ test_pickle_of_unpickle_is_identity,
292 test_unpickle_succeeds ]
295 -- | If we unpickle something and then pickle it, we should wind up
296 -- with the same thing we started with. WARNING: success of this
297 -- test does not mean that unpickling succeeded.
299 test_pickle_of_unpickle_is_identity :: TestTree
300 test_pickle_of_unpickle_is_identity =
301 testCase "pickle composed with unpickle is the identity" $ do
302 let path = "test/xml/injuriesxml.xml"
303 (expected, actual) <- pickle_unpickle pickle_message path
307 -- | Make sure we can actually unpickle these things.
309 test_unpickle_succeeds :: TestTree
310 test_unpickle_succeeds =
311 testCase "unpickling succeeds" $ do
312 let path = "test/xml/injuriesxml.xml"
313 actual <- unpickleable path pickle_message