X-Git-Url: https://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuries.hs;h=2cb14878a1cf02d08e30bf44fcd8318876041529;hb=32147474ba5c91452eeb532381f63e88c257a982;hp=eb369e03eb8d1ecae646a383a4d0a95e9e2b8659;hpb=7a5034bbe4feb8625b3a6c534f07427ecf848ad8;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index eb369e0..2cb1487 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -17,6 +17,7 @@ -- time_stamp. -- module TSN.XML.Injuries ( + dtd, pickle_message, -- * Tests injuries_tests, @@ -29,11 +30,18 @@ where import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Typeable ( Typeable ) -import Database.Groundhog ( migrate ) +import qualified Data.Vector.HFixed as H ( HVector, cons, convert ) +import Database.Groundhog ( + countAll, + deleteAll, + migrate ) import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Data.Tuple.Curry ( uncurryN ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) @@ -57,13 +65,21 @@ import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( + Child(..), FromXml(..), FromXmlFk(..), ToDb(..), pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "injuriesxml.dtd" + -- -- DB/XML Data types -- @@ -82,45 +98,53 @@ data InjuriesTeam = -- * InjuriesListing/InjuriesListingXml --- | XML representation of the injury listings. +-- | XML representation of the injury listings. The leading +-- underscores prevent unused field warnings. -- data InjuriesListingXml = InjuriesListingXml { - xml_team :: InjuriesTeam, - xml_teamno :: Maybe Int, - xml_injuries :: String, - xml_updated :: Maybe Bool } - deriving (Eq, Show) + _xml_team :: InjuriesTeam, + _xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\" + _xml_injuries :: String, + _xml_updated :: Maybe Bool } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector InjuriesListingXml + -- | Database representation of a 'InjuriesListing'. It possesses a -- foreign key to an 'Injuries' object so that we can easily delete -- 'InjuriesListing's based on the parent message's time_stamp. +-- The leading underscores prevent unused field warnings. -- data InjuriesListing = InjuriesListing { - db_injuries_id :: DefaultKey Injuries, - db_team :: InjuriesTeam, - db_teamno :: Maybe Int, - db_injuries :: String, - db_updated :: Maybe Bool } + _db_injuries_id :: DefaultKey Injuries, + _db_team :: InjuriesTeam, + _db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\" + _db_injuries :: String, + _db_updated :: Maybe Bool } + deriving ( GHC.Generic ) + +-- | For 'H.cons'. +-- +instance H.HVector InjuriesListing instance ToDb InjuriesListingXml where -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing' type Db InjuriesListingXml = InjuriesListing -instance FromXmlFk InjuriesListingXml where +instance Child InjuriesListingXml where -- | Our foreign key points to an 'Injuries'. type Parent InjuriesListingXml = Injuries +instance FromXmlFk InjuriesListingXml where -- | To convert between a 'InjuriesListingXml' and a -- 'InjuriesListing', we simply append the foreign key. - from_xml_fk fk InjuriesListingXml{..} = - InjuriesListing { - db_injuries_id = fk, - db_team = xml_team, - db_teamno = xml_teamno, - db_injuries = xml_injuries, - db_updated = xml_updated } + from_xml_fk = H.cons -- | This allows us to insert the XML representation -- 'InjuriesListingXml' directly. @@ -140,7 +164,13 @@ data Message = xml_sport :: String, xml_listings :: [InjuriesListingXml], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.HVector'. +-- +instance H.HVector Message + -- | Database representation of a 'Message'. -- @@ -208,11 +238,11 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: InjuriesListing fields: - - name: db_team + - name: _db_team embeddedType: - {name: team_name, dbName: team_name} - {name: team_league, dbName: team_league} - - name: db_injuries_id + - name: _db_injuries_id reference: onDelete: cascade @@ -233,12 +263,13 @@ mkPersist tsn_codegen_config [groundhog| pickle_injuries_team :: PU InjuriesTeam pickle_injuries_team = xpElem "team" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpPair xpText (xpAttrImplied "league" xpText) where from_tuple = uncurryN InjuriesTeam - to_tuple m = (db_team_name m, db_team_league m) + -- Pointless, but silences two unused field warnings. + to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league) -- | A pickler for 'InjuriesListingXml's that can convert them to/from -- XML. @@ -246,14 +277,14 @@ pickle_injuries_team = pickle_listing :: PU InjuriesListingXml pickle_listing = xpElem "listing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp4Tuple pickle_injuries_team - (xpOption $ xpElem "teamno" xpInt) + (xpOption $ xpElem "teamno" xpText) (xpElem "injuries" xpText) (xpOption $ xpElem "updated" xpPrim) where from_tuple = uncurryN InjuriesListingXml - to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l) + -- | A pickler for 'Message's that can convert them to/from XML. @@ -261,7 +292,7 @@ pickle_listing = pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) @@ -270,12 +301,6 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_category m, - xml_sport m, - xml_listings m, - xml_time_stamp m) -- @@ -288,7 +313,8 @@ injuries_tests :: TestTree injuries_tests = testGroup "Injuries tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -309,7 +335,30 @@ test_pickle_of_unpickle_is_identity = test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testCase "unpickling succeeds" $ do - let path = "test/xml/injuriesxml.xml" - actual <- unpickleable path pickle_message - let expected = True - actual @?= expected + let path = "test/xml/injuriesxml.xml" + 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 = + testCase "deleting an injuries deletes its children" $ do + let path = "test/xml/injuriesxml.xml" + inj <- unsafe_unpickle path pickle_message + let a = undefined :: Injuries + let b = undefined :: InjuriesListing + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigrationSilent $ do + migrate a + migrate b + _ <- dbimport inj + deleteAll a + count_a <- countAll a + count_b <- countAll b + return $ count_a + count_b + let expected = 0 + actual @?= expected