+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- real meat.
--
module TSN.XML.InjuriesDetail (
+ dtd,
pickle_message,
-- * Tests
injuries_detail_tests,
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
DefaultKey,
- migrate )
+ countAll,
+ deleteAll,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
+import Database.Groundhog.Generic ( runDbConn )
+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 (
xpWrap )
-- Local imports.
+import Generics ( Generic(..), to_tuple )
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(..),
pickle_unpickle,
- unpickleable )
+ unpickleable,
+ unsafe_unpickle )
+
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "Injuries_Detail_XML.dtd"
--
xml_sport :: String,
xml_listings :: [InjuriesDetailListingXml],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message
+
-- | Database representation of a 'Message'.
--
xml_full_name :: String, -- ^ Team full name
xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic InjuriesDetailListingXml
+
instance ToDb InjuriesDetailListingXml where
-- | The database analogue of an 'InjuriesDetailListingXml' is a
-- 'InjuriesDetailListing'.
type Db InjuriesDetailListingXml = InjuriesDetailListing
-instance FromXmlFk InjuriesDetailListingXml where
+
+instance Child InjuriesDetailListingXml where
-- | Each 'InjuriesDetailListingXml' is contained in an
-- 'InjuriesDetail'.
type Parent InjuriesDetailListingXml = InjuriesDetail
+
+instance FromXmlFk InjuriesDetailListingXml where
-- | Construct a 'InjuriesDetailListing' from a
-- 'InjuriesDetailListingXml' and a foreign key to a
-- 'InjuriesDetail'.
xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
xml_injured :: Bool,
xml_type :: String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+-- | For 'Generics.to_tuple'.
+--
+instance Generic InjuriesDetailListingPlayerListingXml
+
-- | Database representation of a
-- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
type Db InjuriesDetailListingPlayerListingXml =
InjuriesDetailListingPlayerListing
-instance FromXmlFk InjuriesDetailListingPlayerListingXml where
+
+instance Child InjuriesDetailListingPlayerListingXml where
-- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
-- 'InjuriesDetailListing'.
--
type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
+
+instance FromXmlFk InjuriesDetailListingPlayerListingXml where
-- | To construct a 'InjuriesDetailListingPlayerListing' from a
-- 'InjuriesDetailListingPlayerListingXml' we need to supply a
-- foreign key to an 'InjuriesDetailListing'.
(xpElem "Type" xpText)
where
from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
- to_tuple pl = (xml_player_team_id pl,
- xml_player_id pl,
- xml_date pl,
- xml_pos pl,
- xml_name pl,
- xml_injury pl,
- xml_status pl,
- xml_fantasy pl,
- xml_injured pl,
- xml_type pl)
-- | Convert 'Listing's to/from XML.
(xpList pickle_player_listing)
where
from_tuple = uncurryN InjuriesDetailListingXml
- to_tuple l = (xml_team_id l,
- xml_full_name l,
- xml_player_listings l)
-- | Convert 'Message's to/from XML.
(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)
--
injuries_detail_tests =
testGroup
"InjuriesDetail tests"
- [ test_pickle_of_unpickle_is_identity,
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
test_unpickle_succeeds ]
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 "delete of injuries_detail deletes its children"
+ "test/xml/Injuries_Detail_XML.xml",
+
+ check "delete of injuries_detail deletes its children (non-int team_id)"
+ "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
+ where
+ check desc path = testCase desc $ do
+ inj <- unsafe_unpickle path pickle_message
+ let a = undefined :: InjuriesDetail
+ let b = undefined :: InjuriesDetailListing
+ let c = undefined :: InjuriesDetailListingPlayerListing
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ migrate c
+ _ <- dbimport inj
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ return $ count_a + count_b + count_c
+ let expected = 0
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff