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   xpList,
  44   xpPrim,
  45   xpText,
  46   xpText0,
  47   xpWrap )
  48
  49 import TSN.DbImport ( DbImport(..), import_generic )
  50 import TSN.Picklers( xp_date, xp_team_id )
  51 import Xml ( pickle_unpickle )
  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 data Listing =
  70   Listing {
  71     listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
  72     , full_name :: String, -- ^ Team full name
  73     player_listings :: [PlayerListing] }
  74   deriving (Eq, Show)
  75
  76 data Message =
  77   Message {
  78     xml_file_id :: Int,
  79     heading :: String,
  80     category :: String,
  81     sport :: String,
  82     listings :: [Listing],
  83     time_stamp :: String }
  84   deriving (Eq, Show)
  85
  86
  87 mkPersist defaultCodegenConfig [groundhog|
  88 - entity: PlayerListing
  89   dbName: injuries_detail
  90 |]
  91
  92
  93 pickle_player_listing :: PU PlayerListing
  94 pickle_player_listing =
  95   xpElem "PlayerListing" $
  96     xpWrap (from_tuple, to_tuple) $
  97     xp10Tuple (xpElem "TeamID" xp_team_id)
  98               (xpElem "PlayerID" xpPrim)
  99               (xpElem "Date" xp_date)
 100               (xpElem "Pos" xpText)
 101               (xpElem "Name" xpText)
 102               (xpElem "Injury" xpText)
 103               (xpElem "Status" xpText)
 104               (xpElem "Fantasy" xpText0)
 105               (xpElem "Injured" xpickle)
 106               (xpElem "Type" xpText)
 107   where
 108     from_tuple = uncurryN PlayerListing
 109     to_tuple pl = (team_id pl,
 110                    player_id pl,
 111                    date pl,
 112                    pos pl,
 113                    name pl,
 114                    injury pl,
 115                    status pl,
 116                    fantasy pl,
 117                    injured pl,
 118                    injury_type pl)
 119
 120 instance XmlPickler PlayerListing where
 121   xpickle = pickle_player_listing
 122
 123 pickle_listing :: PU Listing
 124 pickle_listing =
 125   xpElem "Listing" $
 126     xpWrap (from_tuple, to_tuple) $
 127     xpTriple (xpElem "TeamID" xp_team_id)
 128              (xpElem "FullName" xpText)
 129              (xpList pickle_player_listing)
 130   where
 131     from_tuple = uncurryN Listing
 132     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 133
 134 instance XmlPickler Listing where
 135   xpickle = pickle_listing
 136
 137
 138 pickle_message :: PU Message
 139 pickle_message =
 140   xpElem "message" $
 141     xpWrap (from_tuple, to_tuple) $
 142     xp6Tuple (xpElem "XML_File_ID" xpPrim)
 143              (xpElem "heading" xpText)
 144              (xpElem "category" xpText)
 145              (xpElem "sport" xpText)
 146              (xpList pickle_listing)
 147              (xpElem "time_stamp" xpText)
 148   where
 149     from_tuple = uncurryN Message
 150     to_tuple m = (xml_file_id m,
 151                   heading m,
 152                   category m,
 153                   sport m,
 154                   listings m,
 155                   time_stamp m)
 156
 157 instance XmlPickler Message where
 158   xpickle = pickle_message
 159
 160 instance DbImport PlayerListing where
 161   dbimport = import_generic ( (concatMap player_listings) . listings)
 162
 163
 164 -- * Tasty Tests
 165 injuries_detail_tests :: TestTree
 166 injuries_detail_tests =
 167   testGroup
 168     "InjuriesDetail tests"
 169     [ test_pickle_of_unpickle_is_identity ]
 170
 171
 172 test_pickle_of_unpickle_is_identity :: TestTree
 173 test_pickle_of_unpickle_is_identity =
 174   testCase "pickle composed with unpickle is the identity" $ do
 175     let path = "test/xml/Injuries_Detail_XML.xml"
 176     (expected :: [Message], actual) <- pickle_unpickle "message" path
 177     actual @?= expected