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