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   Message,
  21   injuries_detail_tests )
  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   XmlPickler(..),
  37   xpTriple,
  38   xp6Tuple,
  39   xp10Tuple,
  40   xpElem,
  41   xpInt,
  42   xpList,
  43   xpPrim,
  44   xpText,
  45   xpText0,
  46   xpWrap )
  47
  48 import TSN.Picklers( xp_date, xp_team_id )
  49 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  50 import TSN.XmlImport ( XmlImport(..) )
  51 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  52
  53
  54 data PlayerListing =
  55   PlayerListing {
  56     team_id   :: Int,
  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 :: Int -- ^ Avoid conflict with PlayerListing's team_id
  78     , full_name :: String, -- ^ Team full name
  79     player_listings :: [PlayerListing] }
  80   deriving (Eq, Show)
  81
  82
  83 data Message =
  84   Message {
  85     xml_file_id :: Int,
  86     heading :: String,
  87     category :: String,
  88     sport :: String,
  89     listings :: [Listing],
  90     time_stamp :: String }
  91   deriving (Eq, Show)
  92
  93 instance DbImport Message where
  94   dbimport msg = do
  95     mapM_ insert_xml (concatMap player_listings $ listings msg)
  96     return ImportSucceeded
  97
  98   dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
  99
 100 mkPersist defaultCodegenConfig [groundhog|
 101 - entity: PlayerListing
 102   dbName: injuries_detail_player_listings
 103 |]
 104
 105
 106 pickle_player_listing :: PU PlayerListing
 107 pickle_player_listing =
 108   xpElem "PlayerListing" $
 109     xpWrap (from_tuple, to_tuple) $
 110     xp10Tuple (xpElem "TeamID" xp_team_id)
 111               (xpElem "PlayerID" xpInt)
 112               (xpElem "Date" xp_date)
 113               (xpElem "Pos" xpText)
 114               (xpElem "Name" xpText)
 115               (xpElem "Injury" xpText)
 116               (xpElem "Status" xpText)
 117               (xpElem "Fantasy" xpText0)
 118               (xpElem "Injured" xpPrim)
 119               (xpElem "Type" xpText)
 120   where
 121     from_tuple = uncurryN PlayerListing
 122     to_tuple pl = (team_id pl,
 123                    player_id pl,
 124                    date pl,
 125                    pos pl,
 126                    name pl,
 127                    injury pl,
 128                    status pl,
 129                    fantasy pl,
 130                    injured pl,
 131                    injury_type pl)
 132
 133 instance XmlPickler PlayerListing where
 134   xpickle = pickle_player_listing
 135
 136 pickle_listing :: PU Listing
 137 pickle_listing =
 138   xpElem "Listing" $
 139     xpWrap (from_tuple, to_tuple) $
 140     xpTriple (xpElem "TeamID" xp_team_id)
 141              (xpElem "FullName" xpText)
 142              (xpList pickle_player_listing)
 143   where
 144     from_tuple = uncurryN Listing
 145     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 146
 147 instance XmlPickler Listing where
 148   xpickle = pickle_listing
 149
 150
 151 pickle_message :: PU Message
 152 pickle_message =
 153   xpElem "message" $
 154     xpWrap (from_tuple, to_tuple) $
 155     xp6Tuple (xpElem "XML_File_ID" xpInt)
 156              (xpElem "heading" xpText)
 157              (xpElem "category" xpText)
 158              (xpElem "sport" xpText)
 159              (xpList pickle_listing)
 160              (xpElem "time_stamp" xpText)
 161   where
 162     from_tuple = uncurryN Message
 163     to_tuple m = (xml_file_id m,
 164                   heading m,
 165                   category m,
 166                   sport m,
 167                   listings m,
 168                   time_stamp m)
 169
 170 instance XmlPickler Message where
 171   xpickle = pickle_message
 172
 173
 174 -- * Tasty Tests
 175 injuries_detail_tests :: TestTree
 176 injuries_detail_tests =
 177   testGroup
 178     "InjuriesDetail tests"
 179     [ test_pickle_of_unpickle_is_identity,
 180       test_unpickle_succeeds ]
 181
 182
 183 -- | Warning, succeess of this test does not mean that unpickling
 184 --   succeeded.
 185 test_pickle_of_unpickle_is_identity :: TestTree
 186 test_pickle_of_unpickle_is_identity =
 187   testCase "pickle composed with unpickle is the identity" $ do
 188     let path = "test/xml/Injuries_Detail_XML.xml"
 189     (expected, actual) <- pickle_unpickle pickle_message path
 190     actual @?= expected
 191
 192
 193 test_unpickle_succeeds :: TestTree
 194 test_unpickle_succeeds =
 195   testCase "unpickling succeeds" $ do
 196   let path = "test/xml/Injuries_Detail_XML.xml"
 197   actual <- unpickleable path pickle_message
 198   let expected = True
 199   actual @?= expected