src/TSN/XML/InjuriesDetail.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   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 then contain the real
  13 --   meat; everything contained in the parent \<Listing\> can also be
  14 --   found within the \<PlayerListing\>s.
  15 --
  16 --   The player listings will be mapped to a database table called
  17 --   "injuries_detail" automatically. The root "message" and "listing"
  18 --   are not retained.
  19 --
  20 module TSN.XML.InjuriesDetail (
  21   Listing ( player_listings ),
  22   Message ( listings ),
  23   PlayerListing,
  24   injuries_detail_tests )
  25 where
  26
  27 import Data.Time ( UTCTime )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import Database.Groundhog()
  30 import Database.Groundhog.TH (
  31   defaultCodegenConfig,
  32   groundhog,
  33   mkPersist )
  34 import Test.Tasty ( TestTree, testGroup )
  35 import Test.Tasty.HUnit ( (@?=), testCase )
  36 import Text.XML.HXT.Core (
  37   PU,
  38   XmlPickler(..),
  39   xpTriple,
  40   xp6Tuple,
  41   xp10Tuple,
  42   xpElem,
  43   xpInt,
  44   xpList,
  45   xpPrim,
  46   xpText,
  47   xpText0,
  48   xpWrap )
  49
  50 import TSN.DbImport ( DbImport(..), import_generic )
  51 import TSN.Picklers( xp_date, xp_team_id )
  52 import Xml ( pickle_unpickle, unpickleable )
  53
  54
  55 data PlayerListing =
  56   PlayerListing {
  57     team_id   :: Int,
  58     player_id :: Int,
  59     date      :: UTCTime,
  60     pos       :: String,
  61     name      :: String,
  62     injury    :: String,
  63     status    :: String,
  64     fantasy   :: String, -- ^ Nobody knows what this is.
  65     injured     :: Bool,
  66     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
  67     }
  68   deriving (Eq, Show)
  69
  70 data Listing =
  71   Listing {
  72     listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
  73     , full_name :: String, -- ^ Team full name
  74     player_listings :: [PlayerListing] }
  75   deriving (Eq, Show)
  76
  77 data Message =
  78   Message {
  79     xml_file_id :: Int,
  80     heading :: String,
  81     category :: String,
  82     sport :: String,
  83     listings :: [Listing],
  84     time_stamp :: String }
  85   deriving (Eq, Show)
  86
  87
  88 mkPersist defaultCodegenConfig [groundhog|
  89 - entity: PlayerListing
  90   dbName: injuries_detail
  91 |]
  92
  93
  94 pickle_player_listing :: PU PlayerListing
  95 pickle_player_listing =
  96   xpElem "PlayerListing" $
  97     xpWrap (from_tuple, to_tuple) $
  98     xp10Tuple (xpElem "TeamID" xp_team_id)
  99               (xpElem "PlayerID" xpInt)
 100               (xpElem "Date" xp_date)
 101               (xpElem "Pos" xpText)
 102               (xpElem "Name" xpText)
 103               (xpElem "Injury" xpText)
 104               (xpElem "Status" xpText)
 105               (xpElem "Fantasy" xpText0)
 106               (xpElem "Injured" xpPrim)
 107               (xpElem "Type" xpText)
 108   where
 109     from_tuple = uncurryN PlayerListing
 110     to_tuple pl = (team_id pl,
 111                    player_id pl,
 112                    date pl,
 113                    pos pl,
 114                    name pl,
 115                    injury pl,
 116                    status pl,
 117                    fantasy pl,
 118                    injured pl,
 119                    injury_type pl)
 120
 121 instance XmlPickler PlayerListing where
 122   xpickle = pickle_player_listing
 123
 124 pickle_listing :: PU Listing
 125 pickle_listing =
 126   xpElem "Listing" $
 127     xpWrap (from_tuple, to_tuple) $
 128     xpTriple (xpElem "TeamID" xp_team_id)
 129              (xpElem "FullName" xpText)
 130              (xpList pickle_player_listing)
 131   where
 132     from_tuple = uncurryN Listing
 133     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 134
 135 instance XmlPickler Listing where
 136   xpickle = pickle_listing
 137
 138
 139 pickle_message :: PU Message
 140 pickle_message =
 141   xpElem "message" $
 142     xpWrap (from_tuple, to_tuple) $
 143     xp6Tuple (xpElem "XML_File_ID" xpInt)
 144              (xpElem "heading" xpText)
 145              (xpElem "category" xpText)
 146              (xpElem "sport" xpText)
 147              (xpList pickle_listing)
 148              (xpElem "time_stamp" xpText)
 149   where
 150     from_tuple = uncurryN Message
 151     to_tuple m = (xml_file_id m,
 152                   heading m,
 153                   category m,
 154                   sport m,
 155                   listings m,
 156                   time_stamp m)
 157
 158 instance XmlPickler Message where
 159   xpickle = pickle_message
 160
 161 instance DbImport PlayerListing where
 162   dbimport = import_generic ( (concatMap player_listings) . listings)
 163
 164
 165 -- * Tasty Tests
 166 injuries_detail_tests :: TestTree
 167 injuries_detail_tests =
 168   testGroup
 169     "InjuriesDetail tests"
 170     [ test_pickle_of_unpickle_is_identity,
 171       test_unpickle_succeeds ]
 172
 173
 174 -- | Warning, succeess of this test does not mean that unpickling
 175 --   succeeded.
 176 test_pickle_of_unpickle_is_identity :: TestTree
 177 test_pickle_of_unpickle_is_identity =
 178   testCase "pickle composed with unpickle is the identity" $ do
 179     let path = "test/xml/Injuries_Detail_XML.xml"
 180     (expected :: [Message], actual) <- pickle_unpickle "message" path
 181     actual @?= expected
 182
 183
 184 test_unpickle_succeeds :: TestTree
 185 test_unpickle_succeeds =
 186   testCase "unpickling succeeds" $ do
 187   let path = "test/xml/Injuries_Detail_XML.xml"
 188   actual <- unpickleable path pickle_message
 189   let expected = True
 190   actual @?= expected