X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=c2f189bcd0bb0189204d982a90e6e2411b7020d2;hb=f9a9d6fdcdd2ee0e6bb1882ed2eba936535a52ac;hp=f14b0f153d3c473c9a192f785a8b0856730379ef;hpb=bc54be6029dafbb7121eaeb1a2190ed1b5d87a00;p=dead%2Fhtsn-import.git
diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs
index f14b0f1..c2f189b 100644
--- a/src/TSN/XML/InjuriesDetail.hs
+++ b/src/TSN/XML/InjuriesDetail.hs
@@ -1,8 +1,8 @@
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
@@ -13,6 +13,7 @@
-- real meat.
--
module TSN.XML.InjuriesDetail (
+ dtd,
pickle_message,
-- * Tests
injuries_detail_tests,
@@ -26,12 +27,23 @@ where
import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
+import qualified Data.Vector.HFixed as H (
+ HVector,
+ asCVec,
+ cons,
+ convert,
+ tail )
import Database.Groundhog (
DefaultKey,
+ countAll,
+ deleteAll,
migrate )
+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 (
@@ -53,11 +65,20 @@ 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"
--
@@ -79,7 +100,13 @@ data Message =
xml_sport :: String,
xml_listings :: [InjuriesDetailListingXml],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
+
-- | Database representation of a 'Message'.
--
@@ -93,6 +120,7 @@ data InjuriesDetail =
instance ToDb Message where
-- | The database representation of a 'Message' is an
-- 'InjuriesDetail'.
+ --
type Db Message = InjuriesDetail
instance FromXml Message where
@@ -106,15 +134,16 @@ instance FromXml Message where
db_time_stamp = xml_time_stamp }
--- | This allows us to call 'insert_xml' directly on the XML
--- representation.
+-- | This allows us to insert the XML representation 'Message'
+-- directly.
+--
instance XmlImport Message
-- * InjuriesDetailListing/InjuriesDetailListingXml
--- | Database representation of an InjuriesDetailListing. It has a
+-- | Database representation of a \
element. It has a
-- foreign key pointing to its parent 'InjuriesDetail', and does not
-- contain the list of 'xml_player_listings' (which get their own
-- table).
@@ -137,16 +166,27 @@ data InjuriesDetailListingXml =
xml_full_name :: String, -- ^ Team full name
xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector 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'.
@@ -157,17 +197,21 @@ instance FromXmlFk InjuriesDetailListingXml where
db_team_id = xml_team_id,
db_full_name = xml_full_name }
+-- | This allows us to insert the XML representation
+-- 'InjuriesDetailListingXml' directly.
+--
instance XmlImportFk InjuriesDetailListingXml
-- * InjuriesDetailListingPlayerListing
-- | XML representation of a \, the main type of
--- element contains in Injuries_Detail_XML messages.
+-- element contains in Injuries_Detail_XML messages. The leading
+-- underscores prevent unused field warnings.
--
data InjuriesDetailListingPlayerListingXml =
InjuriesDetailListingPlayerListingXml {
- xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
+ _xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
-- characters long and not
-- necessarily numeric. Postgres
-- imposes no performance penalty
@@ -176,35 +220,45 @@ data InjuriesDetailListingPlayerListingXml =
-- bound of three characters.
-- We add the \"player\" to avoid conflict
-- with 'InjuriesDetailListingXml'.
- xml_player_id :: Int,
- xml_date :: UTCTime,
- xml_pos :: String,
- xml_name :: String,
- xml_injury :: String,
- xml_status :: String,
- xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
- xml_injured :: Bool,
- xml_type :: String }
- deriving (Eq, Show)
-
+ _xml_player_id :: Int,
+ _xml_date :: UTCTime,
+ _xml_pos :: String,
+ _xml_name :: String,
+ _xml_injury :: String,
+ _xml_status :: String,
+ _xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
+ _xml_injured :: Bool,
+ _xml_type :: String }
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector InjuriesDetailListingPlayerListingXml
-- | Database representation of a
-- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
--- because it's redundant.
+-- because it's redundant. The leading underscores prevent unused
+-- field warnings.
--
data InjuriesDetailListingPlayerListing =
InjuriesDetailListingPlayerListing {
- db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
- db_player_id :: Int,
- db_date :: UTCTime,
- db_pos :: String,
- db_name :: String,
- db_injury :: String,
- db_status :: String,
- db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
- db_injured :: Bool,
- db_type :: String }
+ _db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
+ _db_player_id :: Int,
+ _db_date :: UTCTime,
+ _db_pos :: String,
+ _db_name :: String,
+ _db_injury :: String,
+ _db_status :: String,
+ _db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
+ _db_injured :: Bool,
+ _db_type :: String }
+ deriving ( GHC.Generic )
+
+-- | For 'H.cons', 'H.tail', etc.
+--
+instance H.HVector InjuriesDetailListingPlayerListing
instance ToDb InjuriesDetailListingPlayerListingXml where
@@ -213,27 +267,28 @@ instance ToDb InjuriesDetailListingPlayerListingXml where
type Db InjuriesDetailListingPlayerListingXml =
InjuriesDetailListingPlayerListing
-instance FromXmlFk InjuriesDetailListingPlayerListingXml where
+
+instance Child InjuriesDetailListingPlayerListingXml where
+ -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
+ -- 'InjuriesDetailListing'.
+ --
type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
- -- | To convert between a 'InjuriesDetailListingPlayerListingXml'
- -- and a 'InjuriesDetailListingPlayerListingXml', we do nothing.
- from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
- InjuriesDetailListingPlayerListing {
- db_injuries_detail_listings_id = fk,
- db_player_id = xml_player_id,
- db_date = xml_date,
- db_pos = xml_pos,
- db_name = xml_name,
- db_injury = xml_injury,
- db_status = xml_status,
- db_fantasy = xml_fantasy,
- db_injured = xml_injured,
- db_type = xml_type }
-
--- | This lets us call 'insert_xml' on a
--- 'InjuriesDetailListingPlayerListingXml' without having to
--- explicitly convert it to its database analogue first.
+
+instance FromXmlFk InjuriesDetailListingPlayerListingXml where
+ -- | To construct a 'InjuriesDetailListingPlayerListing' from a
+ -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
+ -- foreign key to an 'InjuriesDetailListing' after dropping the
+ -- '_xml_player_team_id'.
+ --
+ -- The 'H.asCVec' trick allows type inference to proceed in the
+ -- middle of two different magics.
+ --
+ from_xml_fk fk = (H.cons fk) . H.asCVec . H.tail
+
+
+-- | This lets us insert the XML representation
+-- 'InjuriesDetailListingPlayerListingXml' directly.
--
instance XmlImportFk InjuriesDetailListingPlayerListingXml
@@ -243,9 +298,16 @@ instance XmlImportFk InjuriesDetailListingPlayerListingXml
--
instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: InjuriesDetail)
+ migrate (undefined :: InjuriesDetailListing)
+ migrate (undefined :: InjuriesDetailListingPlayerListing)
+
-- | To import a 'Message', we import all of its
- -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its
- -- 'Listing's.
+ -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
+ -- out of its 'Listing's.
+ --
dbimport msg = do
msg_id <- insert_xml msg
@@ -255,12 +317,6 @@ instance DbImport Message where
return ImportSucceeded
- dbmigrate _ =
- run_dbmigrate $ do
- migrate (undefined :: InjuriesDetail)
- migrate (undefined :: InjuriesDetailListing)
- migrate (undefined :: InjuriesDetailListingPlayerListing)
-
mkPersist tsn_codegen_config [groundhog|
- entity: InjuriesDetail
@@ -287,7 +343,7 @@ mkPersist tsn_codegen_config [groundhog|
constructors:
- name: InjuriesDetailListingPlayerListing
fields:
- - name: db_injuries_detail_listings_id
+ - name: _db_injuries_detail_listings_id
reference:
onDelete: cascade
|]
@@ -303,7 +359,7 @@ mkPersist tsn_codegen_config [groundhog|
pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
pickle_player_listing =
xpElem "PlayerListing" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp10Tuple (xpElem "TeamID" xpText)
(xpElem "PlayerID" xpInt)
(xpElem "Date" xp_date)
@@ -316,16 +372,6 @@ pickle_player_listing =
(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.
@@ -333,15 +379,12 @@ pickle_player_listing =
pickle_listing :: PU InjuriesDetailListingXml
pickle_listing =
xpElem "Listing" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xpTriple (xpElem "TeamID" xpText)
(xpElem "FullName" xpText)
(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.
@@ -349,7 +392,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)
@@ -358,12 +401,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)
--
@@ -376,7 +413,8 @@ injuries_detail_tests :: TestTree
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 ]
@@ -411,3 +449,34 @@ test_unpickle_succeeds = testGroup "unpickle tests"
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
+ runMigrationSilent $ 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