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" automatically. The root "message" and "listing"
  17 --   are not retained.
  18 --
  19 module TSN.XML.InjuriesDetail (
  20   injuries_detail_tests,
  21   pickle_message )
  22 where
  23
  24 import Data.Time ( UTCTime )
  25 import Data.Tuple.Curry ( uncurryN )
  26 import Database.Groundhog (
  27   migrate )
  28 import Database.Groundhog.TH (
  29   defaultCodegenConfig,
  30   groundhog,
  31   mkPersist )
  32 import Test.Tasty ( TestTree, testGroup )
  33 import Test.Tasty.HUnit ( (@?=), testCase )
  34 import Text.XML.HXT.Core (
  35   PU,
  36   xpTriple,
  37   xp6Tuple,
  38   xp10Tuple,
  39   xpElem,
  40   xpInt,
  41   xpList,
  42   xpOption,
  43   xpPrim,
  44   xpText,
  45   xpWrap )
  46
  47 import TSN.Picklers( xp_date, xp_team_id )
  48 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  49 import TSN.XmlImport ( XmlImport(..) )
  50 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  51
  52
  53 data PlayerListing =
  54   PlayerListing {
  55     team_id   :: String, -- ^ TeamIDs are (apparently) three characters long
  56                          --   and not necessarily numeric.
  57     player_id :: Int,
  58     date      :: UTCTime,
  59     pos       :: String,
  60     name      :: String,
  61     injury    :: String,
  62     status    :: String,
  63     fantasy   :: Maybe String, -- ^ Nobody knows what this is.
  64     injured     :: Bool,
  65     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
  66     }
  67   deriving (Eq, Show)
  68
  69 instance FromXml PlayerListing where
  70   type Db PlayerListing = PlayerListing
  71   from_xml = id
  72
  73 instance XmlImport PlayerListing
  74
  75 data Listing =
  76   Listing {
  77     listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id.
  78                               --   TeamIDs are (apparently) three characters
  79                               --   long and not necessarily numeric.
  80     , full_name :: String, -- ^ Team full name
  81     player_listings :: [PlayerListing] }
  82   deriving (Eq, Show)
  83
  84
  85 data Message =
  86   Message {
  87     xml_file_id :: Int,
  88     heading :: String,
  89     category :: String,
  90     sport :: String,
  91     listings :: [Listing],
  92     time_stamp :: String }
  93   deriving (Eq, Show)
  94
  95 instance DbImport Message where
  96   dbimport msg = do
  97     mapM_ insert_xml (concatMap player_listings $ listings msg)
  98     return ImportSucceeded
  99
 100   dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
 101
 102 mkPersist defaultCodegenConfig [groundhog|
 103 - entity: PlayerListing
 104   dbName: injuries_detail_player_listings
 105   constructors:
 106     - name: PlayerListing
 107       fields:
 108         - name: team_id
 109           type: varchar(3)
 110 |]
 111
 112
 113 pickle_player_listing :: PU PlayerListing
 114 pickle_player_listing =
 115   xpElem "PlayerListing" $
 116     xpWrap (from_tuple, to_tuple) $
 117     xp10Tuple (xpElem "TeamID" xp_team_id)
 118               (xpElem "PlayerID" xpInt)
 119               (xpElem "Date" xp_date)
 120               (xpElem "Pos" xpText)
 121               (xpElem "Name" xpText)
 122               (xpElem "Injury" xpText)
 123               (xpElem "Status" xpText)
 124               (xpElem "Fantasy" $ xpOption xpText)
 125               (xpElem "Injured" xpPrim)
 126               (xpElem "Type" xpText)
 127   where
 128     from_tuple = uncurryN PlayerListing
 129     to_tuple pl = (team_id pl,
 130                    player_id pl,
 131                    date pl,
 132                    pos pl,
 133                    name pl,
 134                    injury pl,
 135                    status pl,
 136                    fantasy pl,
 137                    injured pl,
 138                    injury_type pl)
 139
 140
 141 pickle_listing :: PU Listing
 142 pickle_listing =
 143   xpElem "Listing" $
 144     xpWrap (from_tuple, to_tuple) $
 145     xpTriple (xpElem "TeamID" xp_team_id)
 146              (xpElem "FullName" xpText)
 147              (xpList pickle_player_listing)
 148   where
 149     from_tuple = uncurryN Listing
 150     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 151
 152
 153 pickle_message :: PU Message
 154 pickle_message =
 155   xpElem "message" $
 156     xpWrap (from_tuple, to_tuple) $
 157     xp6Tuple (xpElem "XML_File_ID" xpInt)
 158              (xpElem "heading" xpText)
 159              (xpElem "category" xpText)
 160              (xpElem "sport" xpText)
 161              (xpList pickle_listing)
 162              (xpElem "time_stamp" xpText)
 163   where
 164     from_tuple = uncurryN Message
 165     to_tuple m = (xml_file_id m,
 166                   heading m,
 167                   category m,
 168                   sport m,
 169                   listings m,
 170                   time_stamp m)
 171
 172
 173 -- * Tasty Tests
 174 injuries_detail_tests :: TestTree
 175 injuries_detail_tests =
 176   testGroup
 177     "InjuriesDetail tests"
 178     [ test_pickle_of_unpickle_is_identity,
 179       test_unpickle_succeeds ]
 180
 181
 182 -- | Warning, succeess of this test does not mean that unpickling
 183 --   succeeded.
 184 test_pickle_of_unpickle_is_identity :: TestTree
 185 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 186   [ check "pickle composed with unpickle is the identity"
 187           "test/xml/Injuries_Detail_XML.xml",
 188
 189     check "pickle composed with unpickle is the identity (non-int team_id)"
 190           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 191   where
 192     check desc path = testCase desc $ do
 193       (expected, actual) <- pickle_unpickle pickle_message path
 194       actual @?= expected
 195
 196
 197 test_unpickle_succeeds :: TestTree
 198 test_unpickle_succeeds = testGroup "unpickle tests"
 199   [ check "unpickling succeeds"
 200           "test/xml/Injuries_Detail_XML.xml",
 201
 202     check "unpickling succeeds (non-int team_id)"
 203           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 204   where
 205     check desc path = testCase desc $ do
 206       actual <- unpickleable path pickle_message
 207       let expected = True
 208       actual @?= expected