1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD \"AutoRacingDriverList.dtd\". Each
11 -- \<message\> element contains a bunch of \<Listing\>s, each of
12 -- which describes a driver/car.
14 module TSN.XML.AutoRacingDriverList (
18 auto_racing_driver_list_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 AutoRacingDriverListConstructor(..),
21 AutoRacingDriverListListingConstructor(..) )
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime(..) )
27 import Data.Tuple.Curry ( uncurryN )
28 import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
29 import Database.Groundhog (
34 silentMigrationLogger )
35 import Database.Groundhog.Core ( DefaultKey )
36 import Database.Groundhog.Generic ( runDbConn )
37 import Database.Groundhog.Sqlite ( withSqliteConn )
38 import Database.Groundhog.TH (
41 import qualified GHC.Generics as GHC ( Generic )
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 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_date, xp_time_stamp )
59 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
69 -- | The DTD to which this module corresponds. Used to invoke dbimport.
72 dtd = "AutoRacingDriverList.dtd"
75 -- * DB/XML data types
78 -- AutoRacingDriverList/Message
80 -- | Database representation of a 'Message'. Comparatively, it lacks
83 data AutoRacingDriverList =
84 AutoRacingDriverList {
85 db_xml_file_id :: Int,
87 db_category :: String,
90 db_time_stamp :: UTCTime }
95 -- | XML Representation of an 'AutoRacingDriverList'. It has the same
96 -- fields, but in addition contains the 'xml_listings'.
100 xml_xml_file_id :: Int,
101 xml_heading :: String,
102 xml_category :: String,
105 xml_listings :: [AutoRacingDriverListListingXml],
106 xml_time_stamp :: UTCTime }
107 deriving (Eq, GHC.Generic, Show)
109 -- | For 'H.convert'.
111 instance H.HVector Message
114 instance ToDb Message where
115 -- | The database analogue of a 'Message' is a 'AutoRacingDriverList'.
117 type Db Message = AutoRacingDriverList
120 -- | The 'FromXml' instance for 'Message' is required for the
121 -- 'XmlImport' instance.
123 instance FromXml Message where
124 -- | To convert a 'Message' to an 'AutoRacingDriverList', we just drop
125 -- the 'xml_listings'.
127 from_xml Message{..} =
128 AutoRacingDriverList {
129 db_xml_file_id = xml_xml_file_id,
130 db_heading = xml_heading,
131 db_category = xml_category,
132 db_sport = xml_sport,
133 db_title = xml_title,
134 db_time_stamp = xml_time_stamp }
137 -- | This allows us to insert the XML representation 'Message'
140 instance XmlImport Message
143 -- AutoRacingDriverListListing / AutoRacingDriverListListingXml
145 -- | Database representation of a \<Listing\> contained within a
146 -- \<message\>. The leading underscores prevent unused field
149 data AutoRacingDriverListListing =
150 AutoRacingDriverListListing {
151 _db_auto_racing_driver_lists_id :: DefaultKey AutoRacingDriverList,
152 _db_driver_id :: Int,
153 _db_driver :: String,
154 _db_height :: Maybe String,
156 _db_date_of_birth :: UTCTime,
157 _db_hometown :: String,
158 _db_nationality :: Maybe String,
159 _db_car_number :: Int,
161 deriving ( GHC.Generic )
163 -- | For 'H.convert'.
165 instance H.HVector AutoRacingDriverListListing
168 -- | XML representation of a \<Listing\> contained within a
169 -- \<message\>. The underscores prevent unused field warnings.
171 data AutoRacingDriverListListingXml =
172 AutoRacingDriverListListingXml {
173 _xml_driver_id :: Int,
174 _xml_driver :: String,
175 _xml_height :: Maybe String,
177 _xml_date_of_birth :: UTCTime,
178 _xml_hometown :: String,
179 _xml_nationality :: Maybe String,
180 _xml_car_number :: Int,
182 deriving (Eq, GHC.Generic, Show)
184 -- | For 'H.convert' and 'H.cons'.
186 instance H.HVector AutoRacingDriverListListingXml
188 instance ToDb AutoRacingDriverListListingXml where
189 -- | The database analogue of an 'AutoRacingDriverListListingXml' is
190 -- an 'AutoRacingDriverListListing'.
192 type Db AutoRacingDriverListListingXml = AutoRacingDriverListListing
195 instance Child AutoRacingDriverListListingXml where
196 -- | Each 'AutoRacingDriverListListingXml' is contained in (i.e. has a
197 -- foreign key to) a 'AutoRacingDriverList'.
199 type Parent AutoRacingDriverListListingXml = AutoRacingDriverList
202 instance FromXmlFk AutoRacingDriverListListingXml where
203 -- | To convert an 'AutoRacingDriverListListingXml' to an
204 -- 'AutoRacingDriverListListing', we add the foreign key and copy
205 -- everything else verbatim.
211 -- | This allows us to insert the XML representation
212 -- 'AutoRacingDriverListListingXml' directly.
214 instance XmlImportFk AutoRacingDriverListListingXml
222 instance DbImport Message where
225 migrate (undefined :: AutoRacingDriverList)
226 migrate (undefined :: AutoRacingDriverListListing)
228 -- | We insert the message, then use its ID to insert the listings.
230 msg_id <- insert_xml m
231 forM_ (xml_listings m) $ insert_xml_fk_ msg_id
233 return ImportSucceeded
237 mkPersist tsn_codegen_config [groundhog|
238 - entity: AutoRacingDriverList
239 dbName: auto_racing_driver_lists
241 - name: AutoRacingDriverList
243 - name: unique_auto_racing_driver_lists
245 # Prevent multiple imports of the same message.
246 fields: [db_xml_file_id]
249 - entity: AutoRacingDriverListListing
250 dbName: auto_racing_driver_lists_listings
252 - name: AutoRacingDriverListListing
254 - name: _db_auto_racing_driver_lists_id
265 -- | Pickler for the \<Listing\>s contained within \<message\>s.
267 pickle_listing :: PU AutoRacingDriverListListingXml
270 xpWrap (from_tuple, H.convert) $
271 xp9Tuple (xpElem "DriverID" xpInt)
272 (xpElem "Driver" xpText)
273 (xpElem "Height" $ xpOption xpText)
274 (xpElem "Weight" xpInt)
275 (xpElem "DOB" xp_date)
276 (xpElem "Hometown" xpText)
277 (xpElem "Nationality" $ xpOption xpText)
278 (xpElem "Car_Number" xpInt)
279 (xpElem "Car" xpText)
281 from_tuple = uncurryN AutoRacingDriverListListingXml
283 -- | Pickler for the top-level 'Message'.
285 pickle_message :: PU Message
288 xpWrap (from_tuple, H.convert) $
289 xp7Tuple (xpElem "XML_File_ID" xpInt)
290 (xpElem "heading" xpText)
291 (xpElem "category" xpText)
292 (xpElem "sport" xpText)
293 (xpElem "Title" xpText)
294 (xpList pickle_listing)
295 (xpElem "time_stamp" xp_time_stamp)
297 from_tuple = uncurryN Message
305 -- | A list of all tests for this module.
307 auto_racing_driver_list_tests :: TestTree
308 auto_racing_driver_list_tests =
310 "AutoRacingDriverList tests"
311 [ test_on_delete_cascade,
312 test_pickle_of_unpickle_is_identity,
313 test_unpickle_succeeds ]
316 -- | If we unpickle something and then pickle it, we should wind up
317 -- with the same thing we started with. WARNING: success of this
318 -- test does not mean that unpickling succeeded.
320 test_pickle_of_unpickle_is_identity :: TestTree
321 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
322 [ check "pickle composed with unpickle is the identity"
323 "test/xml/AutoRacingDriverList.xml" ]
325 check desc path = testCase desc $ do
326 (expected, actual) <- pickle_unpickle pickle_message path
330 -- | Make sure we can actually unpickle these things.
332 test_unpickle_succeeds :: TestTree
333 test_unpickle_succeeds = testGroup "unpickle tests"
334 [ check "unpickling succeeds"
335 "test/xml/AutoRacingDriverList.xml" ]
337 check desc path = testCase desc $ do
338 actual <- unpickleable path pickle_message
343 -- | Make sure everything gets deleted when we delete the top-level
346 test_on_delete_cascade :: TestTree
347 test_on_delete_cascade = testGroup "cascading delete tests"
348 [ check "deleting auto_racing_driver_lists deletes its children"
349 "test/xml/AutoRacingDriverList.xml" ]
351 check desc path = testCase desc $ do
352 results <- unsafe_unpickle path pickle_message
353 let a = undefined :: AutoRacingDriverList
354 let b = undefined :: AutoRacingDriverListListing
356 actual <- withSqliteConn ":memory:" $ runDbConn $ do
357 runMigration silentMigrationLogger $ do
360 _ <- dbimport results
362 count_a <- countAll a
363 count_b <- countAll b
364 return $ sum [count_a, count_b]