src/TSN/XML/InjuriesDetail.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
  10 --   document contains a root element \<message\> that in turn
  11 --   contains zero or more \<Listing\>s (note: capitalization). The
  12 --   \<Listing\>s contain \<PlayerListing\>s which then contain the
  13 --   real meat.
  14 --
  15 module TSN.XML.InjuriesDetail (
  16   pickle_message,
  17   -- * Tests
  18   injuries_detail_tests,
  19   -- * WARNING: these are private but exported to silence warnings
  20   InjuriesDetailConstructor(..),
  21   InjuriesDetailListingConstructor(..),
  22   InjuriesDetailListingPlayerListingConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Control.Monad ( forM_ )
  27 import Data.Time ( UTCTime )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import Database.Groundhog (
  30   DefaultKey,
  31   migrate )
  32 import Database.Groundhog.TH (
  33   groundhog,
  34   mkPersist )
  35 import Test.Tasty ( TestTree, testGroup )
  36 import Test.Tasty.HUnit ( (@?=), testCase )
  37 import Text.XML.HXT.Core (
  38   PU,
  39   xpTriple,
  40   xp6Tuple,
  41   xp10Tuple,
  42   xpElem,
  43   xpInt,
  44   xpList,
  45   xpOption,
  46   xpPrim,
  47   xpText,
  48   xpWrap )
  49
  50 -- Local imports.
  51 import TSN.Codegen ( tsn_codegen_config )
  52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  53 import TSN.Picklers( xp_date, xp_time_stamp )
  54 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  55 import Xml (
  56   FromXml(..),
  57   FromXmlFk(..),
  58   ToDb(..),
  59   pickle_unpickle,
  60   unpickleable )
  61
  62
  63 --
  64 -- Data types
  65 --
  66
  67
  68 -- * InjuriesDetail/Message
  69
  70
  71 -- | XML representation of the top-level \<message\> element. These
  72 --   are not stored; the data type is used only for parsing.
  73 --
  74 data Message =
  75   Message {
  76     xml_xml_file_id :: Int,
  77     xml_heading :: String,
  78     xml_category :: String,
  79     xml_sport :: String,
  80     xml_listings :: [InjuriesDetailListingXml],
  81     xml_time_stamp :: UTCTime }
  82   deriving (Eq, Show)
  83
  84 -- | Database representation of a 'Message'.
  85 --
  86 data InjuriesDetail =
  87   InjuriesDetail {
  88     db_sport :: String,
  89     db_time_stamp :: UTCTime }
  90   deriving (Eq, Show)
  91
  92 instance ToDb Message where
  93   -- | The database representation of a 'Message' is an
  94   --   'InjuriesDetail'.
  95   type Db Message = InjuriesDetail
  96
  97 instance FromXml Message where
  98   -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
  99   --   a few fields.
 100   --
 101   from_xml Message{..} =
 102     InjuriesDetail {
 103       db_sport = xml_sport,
 104       db_time_stamp = xml_time_stamp }
 105
 106
 107 -- | This allows us to call 'insert_xml' directly on the XML
 108 --   representation.
 109 instance XmlImport Message
 110
 111
 112
 113 -- * InjuriesDetailListing/InjuriesDetailListingXml
 114
 115 data InjuriesDetailListing =
 116   InjuriesDetailListing {
 117     db_injuries_detail_id :: DefaultKey InjuriesDetail,
 118     db_team_id :: String,
 119     db_full_name :: String }
 120
 121
 122 -- | XML incarnation of a \<Listing\> element. We don't store these;
 123 --   the data type is used only for parsing.
 124 --
 125 data InjuriesDetailListingXml =
 126   InjuriesDetailListingXml {
 127     xml_team_id :: String, -- ^ TeamIDs are (apparently) three
 128                            --   characters long and not necessarily
 129                            --   numeric.
 130
 131     xml_full_name :: String, -- ^ Team full name
 132     xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
 133   deriving (Eq, Show)
 134
 135 instance ToDb InjuriesDetailListingXml where
 136   type Db InjuriesDetailListingXml = InjuriesDetailListing
 137
 138 instance FromXmlFk InjuriesDetailListingXml where
 139   type Parent InjuriesDetailListingXml = InjuriesDetail
 140
 141   from_xml_fk fk InjuriesDetailListingXml{..} =
 142     InjuriesDetailListing {
 143       db_injuries_detail_id = fk,
 144       db_team_id = xml_team_id,
 145       db_full_name = xml_full_name }
 146
 147 instance XmlImportFk InjuriesDetailListingXml
 148
 149
 150 -- * InjuriesDetailListingPlayerListing
 151
 152 -- | XML representation of a \<PlayerListing\>, the main type of
 153 --   element contains in Injuries_Detail_XML messages.
 154 --
 155 data InjuriesDetailListingPlayerListingXml =
 156   InjuriesDetailListingPlayerListingXml {
 157     xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
 158                                   --   characters long and not
 159                                   --   necessarily numeric. Postgres
 160                                   --   imposes no performance penalty
 161                                   --   on a lengthless text field, so
 162                                   --   we ignore the likely upper
 163                                   --   bound of three characters.
 164                                   --   We add the \"player\" to avoid conflict
 165                                   --   with 'InjuriesDetailListingXml'.
 166     xml_player_id :: Int,
 167     xml_date      :: UTCTime,
 168     xml_pos       :: String,
 169     xml_name      :: String,
 170     xml_injury    :: String,
 171     xml_status    :: String,
 172     xml_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 173     xml_injured     :: Bool,
 174     xml_type :: String }
 175   deriving (Eq, Show)
 176
 177
 178
 179 -- | Database representation of a
 180 --   'InjuriesDetailListingPlayerListingXml'. We drop the team_id
 181 --   because it's redundant.
 182 --
 183 data InjuriesDetailListingPlayerListing =
 184   InjuriesDetailListingPlayerListing {
 185     db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
 186     db_player_id :: Int,
 187     db_date      :: UTCTime,
 188     db_pos       :: String,
 189     db_name      :: String,
 190     db_injury    :: String,
 191     db_status    :: String,
 192     db_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 193     db_injured     :: Bool,
 194     db_type :: String }
 195
 196
 197 instance ToDb InjuriesDetailListingPlayerListingXml where
 198   -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
 199   --   'InjuriesDetailListingPlayerListing'.
 200   type Db InjuriesDetailListingPlayerListingXml =
 201     InjuriesDetailListingPlayerListing
 202
 203 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
 204   type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
 205
 206   -- | To convert between a 'InjuriesDetailListingPlayerListingXml'
 207   --   and a 'InjuriesDetailListingPlayerListingXml', we do nothing.
 208   from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
 209     InjuriesDetailListingPlayerListing {
 210       db_injuries_detail_listings_id = fk,
 211       db_player_id = xml_player_id,
 212       db_date = xml_date,
 213       db_pos = xml_pos,
 214       db_name = xml_name,
 215       db_injury = xml_injury,
 216       db_status = xml_status,
 217       db_fantasy = xml_fantasy,
 218       db_injured = xml_injured,
 219       db_type = xml_type }
 220
 221 -- | This lets us call 'insert_xml' on a
 222 --   'InjuriesDetailListingPlayerListingXml' without having to
 223 --   explicitly convert it to its database analogue first.
 224 --
 225 instance XmlImportFk InjuriesDetailListingPlayerListingXml
 226
 227
 228 --
 229 -- Database stuff
 230 --
 231
 232 instance DbImport Message where
 233   -- | To import a 'Message', we import all of its
 234   --   'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its
 235   --   'Listing's.
 236   dbimport msg = do
 237     msg_id <- insert_xml msg
 238
 239     forM_ (xml_listings msg) $ \listing -> do
 240       l_id <- insert_xml_fk msg_id listing
 241       mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
 242
 243     return ImportSucceeded
 244
 245   dbmigrate _ =
 246     run_dbmigrate $ do
 247       migrate (undefined :: InjuriesDetail)
 248       migrate (undefined :: InjuriesDetailListing)
 249       migrate (undefined :: InjuriesDetailListingPlayerListing)
 250
 251
 252 mkPersist tsn_codegen_config [groundhog|
 253 - entity: InjuriesDetail
 254   dbName: injuries_detail
 255
 256 - entity: InjuriesDetailListing
 257   dbName: injuries_detail_listings
 258   constructors:
 259     - name: InjuriesDetailListing
 260       fields:
 261         - name: db_injuries_detail_id
 262           reference:
 263             onDelete: cascade
 264
 265 - entity: InjuriesDetailListingPlayerListing
 266   dbName: injuries_detail_listings_player_listings
 267   constructors:
 268     - name: InjuriesDetailListingPlayerListing
 269       fields:
 270         - name: db_injuries_detail_listings_id
 271           reference:
 272             onDelete: cascade
 273 |]
 274
 275
 276
 277 --
 278 -- Pickling
 279 --
 280
 281 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
 282 --
 283 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
 284 pickle_player_listing =
 285   xpElem "PlayerListing" $
 286     xpWrap (from_tuple, to_tuple) $
 287     xp10Tuple (xpElem "TeamID" xpText)
 288               (xpElem "PlayerID" xpInt)
 289               (xpElem "Date" xp_date)
 290               (xpElem "Pos" xpText)
 291               (xpElem "Name" xpText)
 292               (xpElem "Injury" xpText)
 293               (xpElem "Status" xpText)
 294               (xpElem "Fantasy" $ xpOption xpText)
 295               (xpElem "Injured" xpPrim)
 296               (xpElem "Type" xpText)
 297   where
 298     from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
 299     to_tuple pl = (xml_player_team_id pl,
 300                    xml_player_id pl,
 301                    xml_date pl,
 302                    xml_pos pl,
 303                    xml_name pl,
 304                    xml_injury pl,
 305                    xml_status pl,
 306                    xml_fantasy pl,
 307                    xml_injured pl,
 308                    xml_type pl)
 309
 310
 311 -- | Convert 'Listing's to/from XML.
 312 --
 313 pickle_listing :: PU InjuriesDetailListingXml
 314 pickle_listing =
 315   xpElem "Listing" $
 316     xpWrap (from_tuple, to_tuple) $
 317     xpTriple (xpElem "TeamID" xpText)
 318              (xpElem "FullName" xpText)
 319              (xpList pickle_player_listing)
 320   where
 321     from_tuple = uncurryN InjuriesDetailListingXml
 322     to_tuple l = (xml_team_id l,
 323                   xml_full_name l,
 324                   xml_player_listings l)
 325
 326
 327 -- | Convert 'Message's to/from XML.
 328 --
 329 pickle_message :: PU Message
 330 pickle_message =
 331   xpElem "message" $
 332     xpWrap (from_tuple, to_tuple) $
 333     xp6Tuple (xpElem "XML_File_ID" xpInt)
 334              (xpElem "heading" xpText)
 335              (xpElem "category" xpText)
 336              (xpElem "sport" xpText)
 337              (xpList pickle_listing)
 338              (xpElem "time_stamp" xp_time_stamp)
 339   where
 340     from_tuple = uncurryN Message
 341     to_tuple m = (xml_xml_file_id m,
 342                   xml_heading m,
 343                   xml_category m,
 344                   xml_sport m,
 345                   xml_listings m,
 346                   xml_time_stamp m)
 347
 348
 349 --
 350 -- Tasty Tests
 351 --
 352
 353 -- | A list of all tests for this module.
 354 --
 355 injuries_detail_tests :: TestTree
 356 injuries_detail_tests =
 357   testGroup
 358     "InjuriesDetail tests"
 359     [ test_pickle_of_unpickle_is_identity,
 360       test_unpickle_succeeds ]
 361
 362
 363 -- | If we unpickle something and then pickle it, we should wind up
 364 --   with the same thing we started with. WARNING: success of this
 365 --   test does not mean that unpickling succeeded.
 366 --
 367 test_pickle_of_unpickle_is_identity :: TestTree
 368 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 369   [ check "pickle composed with unpickle is the identity"
 370           "test/xml/Injuries_Detail_XML.xml",
 371
 372     check "pickle composed with unpickle is the identity (non-int team_id)"
 373           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 374   where
 375     check desc path = testCase desc $ do
 376       (expected, actual) <- pickle_unpickle pickle_message path
 377       actual @?= expected
 378
 379
 380 -- | Make sure we can actually unpickle these things.
 381 --
 382 test_unpickle_succeeds :: TestTree
 383 test_unpickle_succeeds = testGroup "unpickle tests"
 384   [ check "unpickling succeeds"
 385           "test/xml/Injuries_Detail_XML.xml",
 386
 387     check "unpickling succeeds (non-int team_id)"
 388           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 389   where
 390     check desc path = testCase desc $ do
 391       actual <- unpickleable path pickle_message
 392       let expected = True
 393       actual @?= expected