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