+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- time_stamp.
--
module TSN.XML.Injuries (
+ dtd,
pickle_message,
-- * Tests
injuries_tests,
import Data.Typeable ( Typeable )
import Database.Groundhog (
countAll,
- executeRaw,
+ deleteAll,
migrate,
runMigration,
silentMigrationLogger )
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 )
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_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
+ Child(..),
FromXml(..),
FromXmlFk(..),
ToDb(..),
unsafe_unpickle )
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "injuriesxml.dtd"
+
--
-- DB/XML Data types
--
data InjuriesListingXml =
InjuriesListingXml {
xml_team :: InjuriesTeam,
- xml_teamno :: Maybe Int,
+ xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
xml_injuries :: String,
xml_updated :: Maybe Bool }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic InjuriesListingXml
+
-- | Database representation of a 'InjuriesListing'. It possesses a
-- foreign key to an 'Injuries' object so that we can easily delete
InjuriesListing {
db_injuries_id :: DefaultKey Injuries,
db_team :: InjuriesTeam,
- db_teamno :: Maybe Int,
+ db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
db_injuries :: String,
db_updated :: Maybe Bool }
-- | 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{..} =
xml_sport :: String,
xml_listings :: [InjuriesListingXml],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message
+
-- | Database representation of a 'Message'.
--
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.
xpElem "listing" $
xpWrap (from_tuple, to_tuple) $
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.
(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)
--
migrate a
migrate b
_ <- dbimport inj
- -- No idea how 'delete' works, so do this instead.
- executeRaw False "DELETE FROM injuries;" []
+ deleteAll a
count_a <- countAll a
count_b <- countAll b
return $ count_a + count_b