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