src/TSN/XML/InjuriesDetail.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
   9 --   document contains a root element \<message\> that in turn
  10 --   contains zero or more \<Listing\>s (note: capitalization). The
  11 --   \<Listing\>s contain \<PlayerListing\>s then contain the real
  12 --   meat; everything contained in the parent \<Listing\> can also be
  13 --   found within the \<PlayerListing\>s.
  14 --
  15 --   The player listings will be mapped to a database table called
  16 --   \"injuries_detail_player_listings\" automatically. The root
  17 --   \"message\" and \"listing\" are not retained.
  18 --
  19 module TSN.XML.InjuriesDetail (
  20   pickle_message,
  21   -- * Tests
  22   injuries_detail_tests,
  23   -- * WARNING: these are private but exported to silence warnings
  24   PlayerListingConstructor(..) )
  25 where
  26
  27 -- System imports.
  28 import Data.Time ( UTCTime )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Database.Groundhog (
  31   migrate )
  32 import Database.Groundhog.TH (
  33   defaultCodegenConfig,
  34   groundhog,
  35   mkPersist )
  36 import Test.Tasty ( TestTree, testGroup )
  37 import Test.Tasty.HUnit ( (@?=), testCase )
  38 import Text.XML.HXT.Core (
  39   PU,
  40   xpTriple,
  41   xp6Tuple,
  42   xp10Tuple,
  43   xpElem,
  44   xpInt,
  45   xpList,
  46   xpOption,
  47   xpPrim,
  48   xpText,
  49   xpWrap )
  50
  51 -- Local imports.
  52 import TSN.Picklers( xp_date, xp_team_id )
  53 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  54 import TSN.XmlImport ( XmlImport(..) )
  55 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  56
  57
  58 -- | Database representation of a \<PlayerListing\>, the main type of
  59 --   element contains in Injuries_Detail_XML messages.
  60 --
  61 data PlayerListing =
  62   PlayerListing {
  63     team_id   :: String, -- ^ TeamIDs are (apparently) three characters long
  64                          --   and not necessarily numeric.
  65     player_id :: Int,
  66     date      :: UTCTime,
  67     pos       :: String,
  68     name      :: String,
  69     injury    :: String,
  70     status    :: String,
  71     fantasy   :: Maybe String, -- ^ Nobody knows what this is.
  72     injured     :: Bool,
  73     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
  74     }
  75   deriving (Eq, Show)
  76
  77
  78 instance FromXml PlayerListing where
  79   -- | The DB analogue of a 'PlayerListing' is... itself!
  80   type Db PlayerListing = PlayerListing
  81
  82     -- | To convert between a 'PlayerListing' and a 'PlayerListing',
  83     --   we do nothing.
  84   from_xml = id
  85
  86 -- | This lets us call 'insert_xml' on a 'PlayerListing' without
  87 --   having to explicitly convert it to its database analogue first.
  88 --
  89 instance XmlImport PlayerListing
  90
  91
  92 -- | XML incarnation of a \<Listing\> element. We don't store these;
  93 --   the data type is used only for parsing.
  94 --
  95 data Listing =
  96   Listing {
  97     listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id.
  98                               --   TeamIDs are (apparently) three characters
  99                               --   long and not necessarily numeric.
 100     , full_name :: String, -- ^ Team full name
 101     player_listings :: [PlayerListing] }
 102   deriving (Eq, Show)
 103
 104
 105 -- | XML representation of the top-level \<message\> element. These
 106 --   are not stored; the data type is used only for parsing.
 107 --
 108 data Message =
 109   Message {
 110     xml_file_id :: Int,
 111     heading :: String,
 112     category :: String,
 113     sport :: String,
 114     listings :: [Listing],
 115     time_stamp :: String }
 116   deriving (Eq, Show)
 117
 118 instance DbImport Message where
 119   -- | To import a 'Message', we import all of its 'PlayerListing's,
 120   --   which we have to dig out of its 'Listing's.
 121   dbimport msg = do
 122     mapM_ insert_xml (concatMap player_listings $ listings msg)
 123     return ImportSucceeded
 124
 125   dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
 126
 127
 128 mkPersist defaultCodegenConfig [groundhog|
 129 - entity: PlayerListing
 130   dbName: injuries_detail_player_listings
 131   constructors:
 132     - name: PlayerListing
 133       fields:
 134         - name: team_id
 135           type: varchar(3) # We've only seen 3... so far.
 136 |]
 137
 138
 139 -- | Convert 'PlayerListing's to/from XML.
 140 --
 141 pickle_player_listing :: PU PlayerListing
 142 pickle_player_listing =
 143   xpElem "PlayerListing" $
 144     xpWrap (from_tuple, to_tuple) $
 145     xp10Tuple (xpElem "TeamID" xp_team_id)
 146               (xpElem "PlayerID" xpInt)
 147               (xpElem "Date" xp_date)
 148               (xpElem "Pos" xpText)
 149               (xpElem "Name" xpText)
 150               (xpElem "Injury" xpText)
 151               (xpElem "Status" xpText)
 152               (xpElem "Fantasy" $ xpOption xpText)
 153               (xpElem "Injured" xpPrim)
 154               (xpElem "Type" xpText)
 155   where
 156     from_tuple = uncurryN PlayerListing
 157     to_tuple pl = (team_id pl,
 158                    player_id pl,
 159                    date pl,
 160                    pos pl,
 161                    name pl,
 162                    injury pl,
 163                    status pl,
 164                    fantasy pl,
 165                    injured pl,
 166                    injury_type pl)
 167
 168
 169 -- | Convert 'Listing's to/from XML.
 170 --
 171 pickle_listing :: PU Listing
 172 pickle_listing =
 173   xpElem "Listing" $
 174     xpWrap (from_tuple, to_tuple) $
 175     xpTriple (xpElem "TeamID" xp_team_id)
 176              (xpElem "FullName" xpText)
 177              (xpList pickle_player_listing)
 178   where
 179     from_tuple = uncurryN Listing
 180     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 181
 182
 183 -- | Convert 'Message's to/from XML.
 184 --
 185 pickle_message :: PU Message
 186 pickle_message =
 187   xpElem "message" $
 188     xpWrap (from_tuple, to_tuple) $
 189     xp6Tuple (xpElem "XML_File_ID" xpInt)
 190              (xpElem "heading" xpText)
 191              (xpElem "category" xpText)
 192              (xpElem "sport" xpText)
 193              (xpList pickle_listing)
 194              (xpElem "time_stamp" xpText)
 195   where
 196     from_tuple = uncurryN Message
 197     to_tuple m = (xml_file_id m,
 198                   heading m,
 199                   category m,
 200                   sport m,
 201                   listings m,
 202                   time_stamp m)
 203
 204
 205 --
 206 -- Tasty Tests
 207 --
 208
 209 -- | A list of all tests for this module.
 210 --
 211 injuries_detail_tests :: TestTree
 212 injuries_detail_tests =
 213   testGroup
 214     "InjuriesDetail tests"
 215     [ test_pickle_of_unpickle_is_identity,
 216       test_unpickle_succeeds ]
 217
 218
 219 -- | If we unpickle something and then pickle it, we should wind up
 220 --   with the same thing we started with. WARNING: succeess of this
 221 --   test does not mean that unpickling succeeded.
 222 --
 223 test_pickle_of_unpickle_is_identity :: TestTree
 224 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 225   [ check "pickle composed with unpickle is the identity"
 226           "test/xml/Injuries_Detail_XML.xml",
 227
 228     check "pickle composed with unpickle is the identity (non-int team_id)"
 229           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 230   where
 231     check desc path = testCase desc $ do
 232       (expected, actual) <- pickle_unpickle pickle_message path
 233       actual @?= expected
 234
 235
 236 -- | Make sure we can actually unpickle these things.
 237 --
 238 test_unpickle_succeeds :: TestTree
 239 test_unpickle_succeeds = testGroup "unpickle tests"
 240   [ check "unpickling succeeds"
 241           "test/xml/Injuries_Detail_XML.xml",
 242
 243     check "unpickling succeeds (non-int team_id)"
 244           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 245   where
 246     check desc path = testCase desc $ do
 247       actual <- unpickleable path pickle_message
 248       let expected = True
 249       actual @?= expected