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 Control.Monad ( forM_ )
30 import Data.Data ( Data )
31 import Data.Time ( UTCTime )
32 import Data.Typeable ( Typeable )
33 import Database.Groundhog ( insert_, migrate )
34 import Database.Groundhog.Core ( DefaultKey )
35 import Database.Groundhog.TH (
38 import Data.Tuple.Curry ( uncurryN )
39 import Test.Tasty ( TestTree, testGroup )
40 import Test.Tasty.HUnit ( (@?=), testCase )
41 import Text.XML.HXT.Core (
56 import TSN.Codegen ( tsn_codegen_config )
57 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
58 import TSN.Picklers ( xp_time_stamp )
59 import TSN.XmlImport ( XmlImport(..) )
60 import Xml ( FromXml(..), FromXmlFk(..), pickle_unpickle, unpickleable )
62 -- | XML/Database representation of a team as they appear in the
63 -- injuries documents.
67 db_team_name :: String,
68 db_team_league :: Maybe String }
69 deriving (Data, Eq, Show, Typeable)
72 -- | XML/Database representation of the injury listings.
74 data InjuriesListingXml =
76 xml_team :: InjuriesTeam,
77 xml_teamno :: Maybe Int,
78 xml_injuries :: String,
79 xml_updated :: Maybe Bool }
82 -- | Database representation of a 'InjuriesListing'. It possesses a
83 -- foreign key to an 'Injuries' object so that we can easily delete
84 -- 'InjuriesListing's based on the parent message's time_stamp.
86 data InjuriesListing =
88 db_injuries_id :: DefaultKey Injuries,
89 db_team :: InjuriesTeam,
90 db_teamno :: Maybe Int,
91 db_injuries :: String,
92 db_updated :: Maybe Bool }
95 instance FromXmlFk InjuriesListingXml where
96 -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
97 type DbFk InjuriesListingXml = InjuriesListing
99 -- | Our foreign key points to an 'Injuries'.
100 type Parent InjuriesListingXml = Injuries
102 -- | To convert between a 'InjuriesListingXml' and a
103 -- 'InjuriesListing', we simply append the foreign key.
104 from_xml_fk InjuriesListingXml{..} fk =
108 db_teamno = xml_teamno,
109 db_injuries = xml_injuries,
110 db_updated = xml_updated }
113 -- | XML representation of an injuriesxml \<message\>.
117 xml_xml_file_id :: Int,
118 xml_heading :: String,
119 xml_category :: String,
121 xml_listings :: [InjuriesListingXml],
122 xml_time_stamp :: UTCTime }
125 -- | Database representation of a 'Message'. We really only care about
131 db_time_stamp :: UTCTime }
133 instance FromXml Message where
134 -- | The database analogue of a 'Message' is an 'Injuries'.
135 type Db Message = Injuries
137 -- | To convert from XML to DB, we simply drop the fields we don't
140 from_xml Message{..} =
142 db_sport = xml_sport,
143 db_time_stamp = xml_time_stamp }
145 instance XmlImport Message
148 instance DbImport Message where
151 migrate (undefined :: Injuries)
152 migrate (undefined :: InjuriesListing)
154 -- | We import a 'Message' by inserting all of its 'listings'.
157 msg_id <- insert_xml msg
159 forM_ (xml_listings msg) $ \listing ->
160 -- Convert the XML listing to a DB one using the message id and
161 -- insert it (disregarding the result).
162 insert_ $ from_xml_fk listing msg_id
164 return ImportSucceeded
167 mkPersist tsn_codegen_config [groundhog|
170 - entity: InjuriesListing
171 dbName: injuries_listings
173 - name: InjuriesListing
177 - {name: team_name, dbName: team_name}
178 - {name: team_league, dbName: team_league}
179 - name: db_injuries_id
183 - embedded: InjuriesTeam
186 - name: db_team_league
190 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
192 pickle_injuries_team :: PU InjuriesTeam
193 pickle_injuries_team =
195 xpWrap (from_tuple, to_tuple) $
196 xpPair xpText (xpAttrImplied "league" xpText)
198 from_tuple = uncurryN InjuriesTeam
199 to_tuple m = (db_team_name m, db_team_league m)
202 -- | A pickler for 'InjuriesListingXml's that can convert them to/from XML.
204 pickle_listing :: PU InjuriesListingXml
207 xpWrap (from_tuple, to_tuple) $
208 xp4Tuple pickle_injuries_team
209 (xpOption $ xpElem "teamno" xpInt)
210 (xpElem "injuries" xpText)
211 (xpOption $ xpElem "updated" xpPrim)
213 from_tuple = uncurryN InjuriesListingXml
214 to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
217 -- | A pickler for 'Message's that can convert them to/from XML.
219 pickle_message :: PU Message
222 xpWrap (from_tuple, to_tuple) $
223 xp6Tuple (xpElem "XML_File_ID" xpInt)
224 (xpElem "heading" xpText)
225 (xpElem "category" xpText)
226 (xpElem "sport" xpText)
227 (xpList pickle_listing)
228 (xpElem "time_stamp" xp_time_stamp)
230 from_tuple = uncurryN Message
231 to_tuple m = (xml_xml_file_id m,
243 -- | A list of all tests for this module.
245 injuries_tests :: TestTree
249 [ test_pickle_of_unpickle_is_identity,
250 test_unpickle_succeeds ]
253 -- | If we unpickle something and then pickle it, we should wind up
254 -- with the same thing we started with. WARNING: success of this
255 -- test does not mean that unpickling succeeded.
257 test_pickle_of_unpickle_is_identity :: TestTree
258 test_pickle_of_unpickle_is_identity =
259 testCase "pickle composed with unpickle is the identity" $ do
260 let path = "test/xml/injuriesxml.xml"
261 (expected, actual) <- pickle_unpickle pickle_message path
265 -- | Make sure we can actually unpickle these things.
267 test_unpickle_succeeds :: TestTree
268 test_unpickle_succeeds =
269 testCase "unpickling succeeds" $ do
270 let path = "test/xml/injuriesxml.xml"
271 actual <- unpickleable path pickle_message