X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingDriverList.hs;h=482c1f3835699f30fcff5a1716714353d4890e8f;hb=f9a9d6fdcdd2ee0e6bb1882ed2eba936535a52ac;hp=d2c83586608cc1fabc61af0e4c5bfd5ecf2cfc51;hpb=e88453d996ef8c94d581122309669c5c2aa87c9d;p=dead%2Fhtsn-import.git
diff --git a/src/TSN/XML/AutoRacingDriverList.hs b/src/TSN/XML/AutoRacingDriverList.hs
index d2c8358..482c1f3 100644
--- a/src/TSN/XML/AutoRacingDriverList.hs
+++ b/src/TSN/XML/AutoRacingDriverList.hs
@@ -1,4 +1,9 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
@@ -8,22 +13,56 @@
--
module TSN.XML.AutoRacingDriverList (
dtd,
- pickle_message )
+ pickle_message,
+ -- * Tests
+ auto_racing_driver_list_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ AutoRacingDriverListConstructor(..),
+ AutoRacingDriverListListingConstructor(..) )
where
-- System imports.
+import Control.Monad ( forM_ )
import Data.Time ( UTCTime(..) )
+import Data.Tuple.Curry ( uncurryN )
+import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
+import Database.Groundhog (
+ countAll,
+ deleteAll,
+ migrate )
import Database.Groundhog.Core ( DefaultKey )
-import Text.XML.HXT.Core ( PU )
+import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Database.Groundhog.TH (
+ groundhog,
+ mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+ PU,
+ xp7Tuple,
+ xp9Tuple,
+ xpElem,
+ xpInt,
+ xpList,
+ xpOption,
+ xpText,
+ xpWrap )
-- Local imports.
-import TSN.DbImport ( DbImport(..) )
+import TSN.Codegen ( tsn_codegen_config )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Picklers ( xp_date, xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
Child(..),
FromXml(..),
FromXmlFk(..),
- ToDb(..) )
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
@@ -31,10 +70,10 @@ dtd :: String
dtd = "AutoRacingDriverList.dtd"
--
--- DB/XML data types
+-- * DB/XML data types
--
--- * AutoRacingDriverList/Message
+-- AutoRacingDriverList/Message
-- | Database representation of a 'Message'. Comparatively, it lacks
-- only the listings.
@@ -63,7 +102,11 @@ data Message =
xml_title :: String,
xml_listings :: [AutoRacingDriverListListingXml],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
instance ToDb Message where
@@ -95,40 +138,50 @@ instance FromXml Message where
instance XmlImport Message
--- * AutoRacingDriverListListing / AutoRacingDriverListListingXml
+-- AutoRacingDriverListListing / AutoRacingDriverListListingXml
-- | Database representation of a \
contained within a
--- \.
+-- \. The leading underscores prevent unused field
+-- warnings.
--
data AutoRacingDriverListListing =
AutoRacingDriverListListing {
- db_auto_racing_driver_list_id :: DefaultKey AutoRacingDriverList,
- db_driver_id :: Int,
- db_driver :: String,
- db_height :: Maybe String,
- db_weight :: Int,
- db_date_of_birth :: UTCTime,
- db_hometown :: String,
- db_nationality :: String,
- db_car_number :: Int,
- db_car :: String }
+ _db_auto_racing_driver_lists_id :: DefaultKey AutoRacingDriverList,
+ _db_driver_id :: Int,
+ _db_driver :: String,
+ _db_height :: Maybe String,
+ _db_weight :: Int,
+ _db_date_of_birth :: UTCTime,
+ _db_hometown :: String,
+ _db_nationality :: Maybe String,
+ _db_car_number :: Int,
+ _db_car :: String }
+ deriving ( GHC.Generic )
+
+-- | For 'H.convert'.
+--
+instance H.HVector AutoRacingDriverListListing
+
-- | XML representation of a \ contained within a
--- \.
+-- \. The underscores prevent unused field warnings.
--
data AutoRacingDriverListListingXml =
AutoRacingDriverListListingXml {
- xml_driver_id :: Int,
- xml_driver :: String,
- xml_height :: Maybe String,
- xml_weight :: Int,
- xml_date_of_birth :: UTCTime,
- xml_hometown :: String,
- xml_nationality :: String,
- xml_car_number :: Int,
- xml_car :: String }
- deriving (Eq, Show)
+ _xml_driver_id :: Int,
+ _xml_driver :: String,
+ _xml_height :: Maybe String,
+ _xml_weight :: Int,
+ _xml_date_of_birth :: UTCTime,
+ _xml_hometown :: String,
+ _xml_nationality :: Maybe String,
+ _xml_car_number :: Int,
+ _xml_car :: String }
+ deriving (Eq, GHC.Generic, Show)
+-- | For 'H.convert' and 'H.cons'.
+--
+instance H.HVector AutoRacingDriverListListingXml
instance ToDb AutoRacingDriverListListingXml where
-- | The database analogue of an 'AutoRacingDriverListListingXml' is
@@ -149,21 +202,163 @@ instance FromXmlFk AutoRacingDriverListListingXml where
-- 'AutoRacingDriverListListing', we add the foreign key and copy
-- everything else verbatim.
--
- from_xml_fk fk AutoRacingDriverListListingXml{..} =
- AutoRacingDriverListListing {
- db_auto_racing_driver_list_id = fk,
- db_driver_id = xml_driver_id,
- db_driver = xml_driver,
- db_height = xml_height,
- db_weight = xml_weight,
- db_date_of_birth = xml_date_of_birth,
- db_hometown = xml_hometown,
- db_nationality = xml_nationality,
- db_car_number = xml_car_number,
- db_car = xml_car }
+ from_xml_fk = H.cons
+
-- | This allows us to insert the XML representation
-- 'AutoRacingDriverListListingXml' directly.
--
instance XmlImportFk AutoRacingDriverListListingXml
+
+
+
+--
+-- * Database
+--
+
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: AutoRacingDriverList)
+ migrate (undefined :: AutoRacingDriverListListing)
+
+ -- | We insert the message, then use its ID to insert the listings.
+ dbimport m = do
+ msg_id <- insert_xml m
+ forM_ (xml_listings m) $ insert_xml_fk_ msg_id
+
+ return ImportSucceeded
+
+
+
+mkPersist tsn_codegen_config [groundhog|
+- entity: AutoRacingDriverList
+ dbName: auto_racing_driver_lists
+ constructors:
+ - name: AutoRacingDriverList
+ uniques:
+ - name: unique_auto_racing_driver_lists
+ type: constraint
+ # Prevent multiple imports of the same message.
+ fields: [db_xml_file_id]
+
+
+- entity: AutoRacingDriverListListing
+ dbName: auto_racing_driver_lists_listings
+ constructors:
+ - name: AutoRacingDriverListListing
+ fields:
+ - name: _db_auto_racing_driver_lists_id
+ reference:
+ onDelete: cascade
+
+|]
+
+
+--
+-- * Pickling
+--
+
+-- | Pickler for the \s contained within \s.
+--
+pickle_listing :: PU AutoRacingDriverListListingXml
+pickle_listing =
+ xpElem "Listing" $
+ xpWrap (from_tuple, H.convert) $
+ xp9Tuple (xpElem "DriverID" xpInt)
+ (xpElem "Driver" xpText)
+ (xpElem "Height" $ xpOption xpText)
+ (xpElem "Weight" xpInt)
+ (xpElem "DOB" xp_date)
+ (xpElem "Hometown" xpText)
+ (xpElem "Nationality" $ xpOption xpText)
+ (xpElem "Car_Number" xpInt)
+ (xpElem "Car" xpText)
+ where
+ from_tuple = uncurryN AutoRacingDriverListListingXml
+
+-- | Pickler for the top-level 'Message'.
+--
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, H.convert) $
+ xp7Tuple (xpElem "XML_File_ID" xpInt)
+ (xpElem "heading" xpText)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpElem "Title" xpText)
+ (xpList pickle_listing)
+ (xpElem "time_stamp" xp_time_stamp)
+ where
+ from_tuple = uncurryN Message
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+auto_racing_driver_list_tests :: TestTree
+auto_racing_driver_list_tests =
+ testGroup
+ "AutoRacingDriverList tests"
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
+ test_unpickle_succeeds ]
+
+
+-- | If we unpickle something and then pickle it, we should wind up
+-- with the same thing we started with. WARNING: success of this
+-- test does not mean that unpickling succeeded.
+--
+test_pickle_of_unpickle_is_identity :: TestTree
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+ [ check "pickle composed with unpickle is the identity"
+ "test/xml/AutoRacingDriverList.xml" ]
+ where
+ check desc path = testCase desc $ do
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds = testGroup "unpickle tests"
+ [ check "unpickling succeeds"
+ "test/xml/AutoRacingDriverList.xml" ]
+ where
+ check desc path = testCase desc $ do
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+-- record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade = testGroup "cascading delete tests"
+ [ check "deleting auto_racing_driver_lists deletes its children"
+ "test/xml/AutoRacingDriverList.xml" ]
+ where
+ check desc path = testCase desc $ do
+ results <- unsafe_unpickle path pickle_message
+ let a = undefined :: AutoRacingDriverList
+ let b = undefined :: AutoRacingDriverListListing
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigrationSilent $ do
+ migrate a
+ migrate b
+ _ <- dbimport results
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ return $ sum [count_a, count_b]
+ let expected = 0
+ actual @?= expected