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   xpPrim,
  43   xpText,
  44   xpText0,
  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   :: 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" xpText0)
 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