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