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_xml_file_id :: Int,
  89     db_sport :: String,
  90     db_time_stamp :: UTCTime }
  91   deriving (Eq, Show)
  92
  93 instance ToDb Message where
  94   -- | The database representation of a 'Message' is an
  95   --   'InjuriesDetail'.
  96   --
  97   type Db Message = InjuriesDetail
  98
  99 instance FromXml Message where
 100   -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
 101   --   a few fields.
 102   --
 103   from_xml Message{..} =
 104     InjuriesDetail {
 105       db_xml_file_id = xml_xml_file_id,
 106       db_sport = xml_sport,
 107       db_time_stamp = xml_time_stamp }
 108
 109
 110 -- | This allows us to insert the XML representation 'Message'
 111 --   directly.
 112 --
 113 instance XmlImport Message
 114
 115
 116
 117 -- * InjuriesDetailListing/InjuriesDetailListingXml
 118
 119 -- | Database representation of a \<Listing\> element. It has a
 120 --   foreign key pointing to its parent 'InjuriesDetail', and does not
 121 --   contain the list of 'xml_player_listings' (which get their own
 122 --   table).
 123 --
 124 data InjuriesDetailListing =
 125   InjuriesDetailListing {
 126     db_injuries_detail_id :: DefaultKey InjuriesDetail,
 127     db_team_id :: String,
 128     db_full_name :: String }
 129
 130
 131 -- | XML incarnation of a \<Listing\> element. We don't store these;
 132 --   the data type is used only for parsing.
 133 --
 134 data InjuriesDetailListingXml =
 135   InjuriesDetailListingXml {
 136     xml_team_id :: String, -- ^ TeamIDs are (apparently) three
 137                            --   characters long and not necessarily
 138                            --   numeric.
 139
 140     xml_full_name :: String, -- ^ Team full name
 141     xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
 142   deriving (Eq, Show)
 143
 144 instance ToDb InjuriesDetailListingXml where
 145   -- | The database analogue of an 'InjuriesDetailListingXml' is a
 146   --   'InjuriesDetailListing'.
 147   type Db InjuriesDetailListingXml = InjuriesDetailListing
 148
 149 instance FromXmlFk InjuriesDetailListingXml where
 150   -- | Each 'InjuriesDetailListingXml' is contained in an
 151   --   'InjuriesDetail'.
 152   type Parent InjuriesDetailListingXml = InjuriesDetail
 153
 154   -- | Construct a 'InjuriesDetailListing' from a
 155   --   'InjuriesDetailListingXml' and a foreign key to a
 156   --   'InjuriesDetail'.
 157   --
 158   from_xml_fk fk InjuriesDetailListingXml{..} =
 159     InjuriesDetailListing {
 160       db_injuries_detail_id = fk,
 161       db_team_id = xml_team_id,
 162       db_full_name = xml_full_name }
 163
 164 -- | This allows us to insert the XML representation
 165 --   'InjuriesDetailListingXml' directly.
 166 --
 167 instance XmlImportFk InjuriesDetailListingXml
 168
 169
 170 -- * InjuriesDetailListingPlayerListing
 171
 172 -- | XML representation of a \<PlayerListing\>, the main type of
 173 --   element contains in Injuries_Detail_XML messages.
 174 --
 175 data InjuriesDetailListingPlayerListingXml =
 176   InjuriesDetailListingPlayerListingXml {
 177     xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
 178                                   --   characters long and not
 179                                   --   necessarily numeric. Postgres
 180                                   --   imposes no performance penalty
 181                                   --   on a lengthless text field, so
 182                                   --   we ignore the likely upper
 183                                   --   bound of three characters.
 184                                   --   We add the \"player\" to avoid conflict
 185                                   --   with 'InjuriesDetailListingXml'.
 186     xml_player_id :: Int,
 187     xml_date      :: UTCTime,
 188     xml_pos       :: String,
 189     xml_name      :: String,
 190     xml_injury    :: String,
 191     xml_status    :: String,
 192     xml_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 193     xml_injured     :: Bool,
 194     xml_type :: String }
 195   deriving (Eq, Show)
 196
 197
 198
 199 -- | Database representation of a
 200 --   'InjuriesDetailListingPlayerListingXml'. We drop the team_id
 201 --   because it's redundant.
 202 --
 203 data InjuriesDetailListingPlayerListing =
 204   InjuriesDetailListingPlayerListing {
 205     db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
 206     db_player_id :: Int,
 207     db_date      :: UTCTime,
 208     db_pos       :: String,
 209     db_name      :: String,
 210     db_injury    :: String,
 211     db_status    :: String,
 212     db_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 213     db_injured     :: Bool,
 214     db_type :: String }
 215
 216
 217 instance ToDb InjuriesDetailListingPlayerListingXml where
 218   -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
 219   --   'InjuriesDetailListingPlayerListing'.
 220   type Db InjuriesDetailListingPlayerListingXml =
 221     InjuriesDetailListingPlayerListing
 222
 223 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
 224   -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
 225   --   'InjuriesDetailListing'.
 226   --
 227   type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
 228
 229   -- | To construct a 'InjuriesDetailListingPlayerListing' from a
 230   --   'InjuriesDetailListingPlayerListingXml' we need to supply a
 231   --   foreign key to an 'InjuriesDetailListing'.
 232   --
 233   from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
 234     InjuriesDetailListingPlayerListing {
 235       db_injuries_detail_listings_id = fk,
 236       db_player_id = xml_player_id,
 237       db_date = xml_date,
 238       db_pos = xml_pos,
 239       db_name = xml_name,
 240       db_injury = xml_injury,
 241       db_status = xml_status,
 242       db_fantasy = xml_fantasy,
 243       db_injured = xml_injured,
 244       db_type = xml_type }
 245
 246 -- | This lets us insert the XML representation
 247 --   'InjuriesDetailListingPlayerListingXml' directly.
 248 --
 249 instance XmlImportFk InjuriesDetailListingPlayerListingXml
 250
 251
 252 --
 253 -- Database stuff
 254 --
 255
 256 instance DbImport Message where
 257   dbmigrate _ =
 258     run_dbmigrate $ do
 259       migrate (undefined :: InjuriesDetail)
 260       migrate (undefined :: InjuriesDetailListing)
 261       migrate (undefined :: InjuriesDetailListingPlayerListing)
 262
 263   -- | To import a 'Message', we import all of its
 264   --   'InjuriesDetailListingPlayerListingXml's, which we have to dig
 265   --   out of its 'Listing's.
 266   --
 267   dbimport msg = do
 268     msg_id <- insert_xml msg
 269
 270     forM_ (xml_listings msg) $ \listing -> do
 271       l_id <- insert_xml_fk msg_id listing
 272       mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
 273
 274     return ImportSucceeded
 275
 276
 277 mkPersist tsn_codegen_config [groundhog|
 278 - entity: InjuriesDetail
 279   dbName: injuries_detail
 280   constructors:
 281     - name: InjuriesDetail
 282       uniques:
 283         - name: unique_injuries_detail
 284           type: constraint
 285           # Prevent multiple imports of the same message.
 286           fields: [db_xml_file_id]
 287
 288 - entity: InjuriesDetailListing
 289   dbName: injuries_detail_listings
 290   constructors:
 291     - name: InjuriesDetailListing
 292       fields:
 293         - name: db_injuries_detail_id
 294           reference:
 295             onDelete: cascade
 296
 297 - entity: InjuriesDetailListingPlayerListing
 298   dbName: injuries_detail_listings_player_listings
 299   constructors:
 300     - name: InjuriesDetailListingPlayerListing
 301       fields:
 302         - name: db_injuries_detail_listings_id
 303           reference:
 304             onDelete: cascade
 305 |]
 306
 307
 308
 309 --
 310 -- Pickling
 311 --
 312
 313 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
 314 --
 315 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
 316 pickle_player_listing =
 317   xpElem "PlayerListing" $
 318     xpWrap (from_tuple, to_tuple) $
 319     xp10Tuple (xpElem "TeamID" xpText)
 320               (xpElem "PlayerID" xpInt)
 321               (xpElem "Date" xp_date)
 322               (xpElem "Pos" xpText)
 323               (xpElem "Name" xpText)
 324               (xpElem "Injury" xpText)
 325               (xpElem "Status" xpText)
 326               (xpElem "Fantasy" $ xpOption xpText)
 327               (xpElem "Injured" xpPrim)
 328               (xpElem "Type" xpText)
 329   where
 330     from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
 331     to_tuple pl = (xml_player_team_id pl,
 332                    xml_player_id pl,
 333                    xml_date pl,
 334                    xml_pos pl,
 335                    xml_name pl,
 336                    xml_injury pl,
 337                    xml_status pl,
 338                    xml_fantasy pl,
 339                    xml_injured pl,
 340                    xml_type pl)
 341
 342
 343 -- | Convert 'Listing's to/from XML.
 344 --
 345 pickle_listing :: PU InjuriesDetailListingXml
 346 pickle_listing =
 347   xpElem "Listing" $
 348     xpWrap (from_tuple, to_tuple) $
 349     xpTriple (xpElem "TeamID" xpText)
 350              (xpElem "FullName" xpText)
 351              (xpList pickle_player_listing)
 352   where
 353     from_tuple = uncurryN InjuriesDetailListingXml
 354     to_tuple l = (xml_team_id l,
 355                   xml_full_name l,
 356                   xml_player_listings l)
 357
 358
 359 -- | Convert 'Message's to/from XML.
 360 --
 361 pickle_message :: PU Message
 362 pickle_message =
 363   xpElem "message" $
 364     xpWrap (from_tuple, to_tuple) $
 365     xp6Tuple (xpElem "XML_File_ID" xpInt)
 366              (xpElem "heading" xpText)
 367              (xpElem "category" xpText)
 368              (xpElem "sport" xpText)
 369              (xpList pickle_listing)
 370              (xpElem "time_stamp" xp_time_stamp)
 371   where
 372     from_tuple = uncurryN Message
 373     to_tuple m = (xml_xml_file_id m,
 374                   xml_heading m,
 375                   xml_category m,
 376                   xml_sport m,
 377                   xml_listings m,
 378                   xml_time_stamp m)
 379
 380
 381 --
 382 -- Tasty Tests
 383 --
 384
 385 -- | A list of all tests for this module.
 386 --
 387 injuries_detail_tests :: TestTree
 388 injuries_detail_tests =
 389   testGroup
 390     "InjuriesDetail tests"
 391     [ test_pickle_of_unpickle_is_identity,
 392       test_unpickle_succeeds ]
 393
 394
 395 -- | If we unpickle something and then pickle it, we should wind up
 396 --   with the same thing we started with. WARNING: success of this
 397 --   test does not mean that unpickling succeeded.
 398 --
 399 test_pickle_of_unpickle_is_identity :: TestTree
 400 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 401   [ check "pickle composed with unpickle is the identity"
 402           "test/xml/Injuries_Detail_XML.xml",
 403
 404     check "pickle composed with unpickle is the identity (non-int team_id)"
 405           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 406   where
 407     check desc path = testCase desc $ do
 408       (expected, actual) <- pickle_unpickle pickle_message path
 409       actual @?= expected
 410
 411
 412 -- | Make sure we can actually unpickle these things.
 413 --
 414 test_unpickle_succeeds :: TestTree
 415 test_unpickle_succeeds = testGroup "unpickle tests"
 416   [ check "unpickling succeeds"
 417           "test/xml/Injuries_Detail_XML.xml",
 418
 419     check "unpickling succeeds (non-int team_id)"
 420           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 421   where
 422     check desc path = testCase desc $ do
 423       actual <- unpickleable path pickle_message
 424       let expected = True
 425       actual @?= expected