1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
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 (
24 -- * WARNING: these are private but exported to silence warnings
25 InjuriesConstructor(..),
26 InjuriesListingConstructor(..) )
30 import Data.Data ( Data )
31 import Data.Time ( UTCTime )
32 import Data.Typeable ( Typeable )
33 import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
34 import Database.Groundhog (
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
40 import Database.Groundhog.TH (
43 import qualified GHC.Generics as GHC ( Generic )
44 import Database.Groundhog.Sqlite ( withSqliteConn )
45 import Data.Tuple.Curry ( uncurryN )
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.XML.HXT.Core (
63 import TSN.Codegen ( tsn_codegen_config )
64 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
65 import TSN.Picklers ( xp_time_stamp )
66 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
78 -- | The DTD to which this module corresponds. Used to invoke dbimport.
81 dtd = "injuriesxml.dtd"
89 -- | XML/Database representation of a team as they appear in the
90 -- injuries documents.
94 db_team_name :: String,
95 db_team_league :: Maybe String }
96 deriving (Data, Eq, Show, Typeable)
99 -- * InjuriesListing/InjuriesListingXml
101 -- | XML representation of the injury listings. The leading
102 -- underscores prevent unused field warnings.
104 data InjuriesListingXml =
106 _xml_team :: InjuriesTeam,
107 _xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
108 _xml_injuries :: String,
109 _xml_updated :: Maybe Bool }
110 deriving (Eq, GHC.Generic, Show)
113 -- | For 'H.convert'.
115 instance H.HVector InjuriesListingXml
118 -- | Database representation of a 'InjuriesListing'. It possesses a
119 -- foreign key to an 'Injuries' object so that we can easily delete
120 -- 'InjuriesListing's based on the parent message's time_stamp.
121 -- The leading underscores prevent unused field warnings.
123 data InjuriesListing =
125 _db_injuries_id :: DefaultKey Injuries,
126 _db_team :: InjuriesTeam,
127 _db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
128 _db_injuries :: String,
129 _db_updated :: Maybe Bool }
130 deriving ( GHC.Generic )
134 instance H.HVector InjuriesListing
136 instance ToDb InjuriesListingXml where
137 -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
138 type Db InjuriesListingXml = InjuriesListing
140 instance Child InjuriesListingXml where
141 -- | Our foreign key points to an 'Injuries'.
142 type Parent InjuriesListingXml = Injuries
144 instance FromXmlFk InjuriesListingXml where
145 -- | To convert between a 'InjuriesListingXml' and a
146 -- 'InjuriesListing', we simply append the foreign key.
149 -- | This allows us to insert the XML representation
150 -- 'InjuriesListingXml' directly.
152 instance XmlImportFk InjuriesListingXml
155 -- * Injuries/Message
157 -- | XML representation of an injuriesxml \<message\>.
161 xml_xml_file_id :: Int,
162 xml_heading :: String,
163 xml_category :: String,
165 xml_listings :: [InjuriesListingXml],
166 xml_time_stamp :: UTCTime }
167 deriving (Eq, GHC.Generic, Show)
170 -- | For 'H.HVector'.
172 instance H.HVector Message
175 -- | Database representation of a 'Message'.
179 db_xml_file_id :: Int,
181 db_time_stamp :: UTCTime }
183 instance ToDb Message where
184 -- | The database analogue of a 'Message' is an 'Injuries'.
185 type Db Message = Injuries
187 instance FromXml Message where
188 -- | To convert from XML to DB, we simply drop the fields we don't
191 from_xml Message{..} =
193 db_xml_file_id = xml_xml_file_id,
194 db_sport = xml_sport,
195 db_time_stamp = xml_time_stamp }
197 -- | This allows us to insert the XML representation 'Message'
200 instance XmlImport Message
207 instance DbImport Message where
210 migrate (undefined :: Injuries)
211 migrate (undefined :: InjuriesListing)
213 -- | We import a 'Message' by inserting all of its 'listings', but
214 -- the listings require a foreign key to the parent 'Message'.
217 msg_id <- insert_xml msg
219 -- Convert each XML listing to a DB one using the message id and
220 -- insert it (disregarding the result).
221 mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
223 return ImportSucceeded
226 mkPersist tsn_codegen_config [groundhog|
231 - name: unique_injuries
233 # Prevent multiple imports of the same message.
234 fields: [db_xml_file_id]
236 - entity: InjuriesListing
237 dbName: injuries_listings
239 - name: InjuriesListing
243 - {name: team_name, dbName: team_name}
244 - {name: team_league, dbName: team_league}
245 - name: _db_injuries_id
249 - embedded: InjuriesTeam
252 - name: db_team_league
261 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
263 pickle_injuries_team :: PU InjuriesTeam
264 pickle_injuries_team =
266 xpWrap (from_tuple, to_tuple') $
267 xpPair xpText (xpAttrImplied "league" xpText)
269 from_tuple = uncurryN InjuriesTeam
271 -- Pointless, but silences two unused field warnings.
272 to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league)
274 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
277 pickle_listing :: PU InjuriesListingXml
280 xpWrap (from_tuple, H.convert) $
281 xp4Tuple pickle_injuries_team
282 (xpOption $ xpElem "teamno" xpText)
283 (xpElem "injuries" xpText)
284 (xpOption $ xpElem "updated" xpPrim)
286 from_tuple = uncurryN InjuriesListingXml
290 -- | A pickler for 'Message's that can convert them to/from XML.
292 pickle_message :: PU Message
295 xpWrap (from_tuple, H.convert) $
296 xp6Tuple (xpElem "XML_File_ID" xpInt)
297 (xpElem "heading" xpText)
298 (xpElem "category" xpText)
299 (xpElem "sport" xpText)
300 (xpList pickle_listing)
301 (xpElem "time_stamp" xp_time_stamp)
303 from_tuple = uncurryN Message
310 -- | A list of all tests for this module.
312 injuries_tests :: TestTree
316 [ test_on_delete_cascade,
317 test_pickle_of_unpickle_is_identity,
318 test_unpickle_succeeds ]
321 -- | If we unpickle something and then pickle it, we should wind up
322 -- with the same thing we started with. WARNING: success of this
323 -- test does not mean that unpickling succeeded.
325 test_pickle_of_unpickle_is_identity :: TestTree
326 test_pickle_of_unpickle_is_identity =
327 testCase "pickle composed with unpickle is the identity" $ do
328 let path = "test/xml/injuriesxml.xml"
329 (expected, actual) <- pickle_unpickle pickle_message path
333 -- | Make sure we can actually unpickle these things.
335 test_unpickle_succeeds :: TestTree
336 test_unpickle_succeeds =
337 testCase "unpickling succeeds" $ do
338 let path = "test/xml/injuriesxml.xml"
339 actual <- unpickleable path pickle_message
344 -- | Make sure everything gets deleted when we delete the top-level
347 test_on_delete_cascade :: TestTree
348 test_on_delete_cascade =
349 testCase "deleting an injuries deletes its children" $ do
350 let path = "test/xml/injuriesxml.xml"
351 inj <- unsafe_unpickle path pickle_message
352 let a = undefined :: Injuries
353 let b = undefined :: InjuriesListing
354 actual <- withSqliteConn ":memory:" $ runDbConn $ do
355 runMigrationSilent $ do
360 count_a <- countAll a
361 count_b <- countAll b
362 return $ count_a + count_b