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   injuries_detail_tests,
  21   pickle_message )
  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   xpTriple,
  37   xp6Tuple,
  38   xp10Tuple,
  39   xpElem,
  40   xpInt,
  41   xpList,
  42   xpPrim,
  43   xpText,
  44   xpText0,
  45   xpWrap )
  46
  47 import TSN.Picklers( xp_date, xp_team_id )
  48 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  49 import TSN.XmlImport ( XmlImport(..) )
  50 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  51
  52
  53 data PlayerListing =
  54   PlayerListing {
  55     team_id   :: Int,
  56     player_id :: Int,
  57     date      :: UTCTime,
  58     pos       :: String,
  59     name      :: String,
  60     injury    :: String,
  61     status    :: String,
  62     fantasy   :: String, -- ^ Nobody knows what this is.
  63     injured     :: Bool,
  64     injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
  65     }
  66   deriving (Eq, Show)
  67
  68 instance FromXml PlayerListing where
  69   type Db PlayerListing = PlayerListing
  70   from_xml = id
  71
  72 instance XmlImport PlayerListing
  73
  74 data Listing =
  75   Listing {
  76     listing_team_id :: Int -- ^ Avoid conflict with PlayerListing's team_id
  77     , full_name :: String, -- ^ Team full name
  78     player_listings :: [PlayerListing] }
  79   deriving (Eq, Show)
  80
  81
  82 data Message =
  83   Message {
  84     xml_file_id :: Int,
  85     heading :: String,
  86     category :: String,
  87     sport :: String,
  88     listings :: [Listing],
  89     time_stamp :: String }
  90   deriving (Eq, Show)
  91
  92 instance DbImport Message where
  93   dbimport msg = do
  94     mapM_ insert_xml (concatMap player_listings $ listings msg)
  95     return ImportSucceeded
  96
  97   dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)
  98
  99 mkPersist defaultCodegenConfig [groundhog|
 100 - entity: PlayerListing
 101   dbName: injuries_detail_player_listings
 102 |]
 103
 104
 105 pickle_player_listing :: PU PlayerListing
 106 pickle_player_listing =
 107   xpElem "PlayerListing" $
 108     xpWrap (from_tuple, to_tuple) $
 109     xp10Tuple (xpElem "TeamID" xp_team_id)
 110               (xpElem "PlayerID" xpInt)
 111               (xpElem "Date" xp_date)
 112               (xpElem "Pos" xpText)
 113               (xpElem "Name" xpText)
 114               (xpElem "Injury" xpText)
 115               (xpElem "Status" xpText)
 116               (xpElem "Fantasy" xpText0)
 117               (xpElem "Injured" xpPrim)
 118               (xpElem "Type" xpText)
 119   where
 120     from_tuple = uncurryN PlayerListing
 121     to_tuple pl = (team_id pl,
 122                    player_id pl,
 123                    date pl,
 124                    pos pl,
 125                    name pl,
 126                    injury pl,
 127                    status pl,
 128                    fantasy pl,
 129                    injured pl,
 130                    injury_type pl)
 131
 132
 133 pickle_listing :: PU Listing
 134 pickle_listing =
 135   xpElem "Listing" $
 136     xpWrap (from_tuple, to_tuple) $
 137     xpTriple (xpElem "TeamID" xp_team_id)
 138              (xpElem "FullName" xpText)
 139              (xpList pickle_player_listing)
 140   where
 141     from_tuple = uncurryN Listing
 142     to_tuple l = (listing_team_id l, full_name l, player_listings l)
 143
 144
 145 pickle_message :: PU Message
 146 pickle_message =
 147   xpElem "message" $
 148     xpWrap (from_tuple, to_tuple) $
 149     xp6Tuple (xpElem "XML_File_ID" xpInt)
 150              (xpElem "heading" xpText)
 151              (xpElem "category" xpText)
 152              (xpElem "sport" xpText)
 153              (xpList pickle_listing)
 154              (xpElem "time_stamp" xpText)
 155   where
 156     from_tuple = uncurryN Message
 157     to_tuple m = (xml_file_id m,
 158                   heading m,
 159                   category m,
 160                   sport m,
 161                   listings m,
 162                   time_stamp m)
 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, actual) <- pickle_unpickle pickle_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