src/TSN/XML/Injuries.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
  11 --   contains a root element \<message\> that in turn contains zero or
  12 --   more \<listing\>s.
  13 --
  14 --   The listings will be mapped to a database table called "injuries"
  15 --   automatically. The root message is not retained.
  16 --
  17 module TSN.XML.Injuries (
  18   Listing,
  19   Message( listings ),
  20   injuries_tests )
  21 where
  22
  23 import Data.Data ( Data )
  24 import Data.Typeable ( Typeable )
  25 import Database.Groundhog()
  26 import Database.Groundhog.TH (
  27   defaultCodegenConfig,
  28   groundhog,
  29   mkPersist )
  30 import Data.Tuple.Curry ( uncurryN )
  31 import Test.Tasty ( TestTree, testGroup )
  32 import Test.Tasty.HUnit ( (@?=), testCase )
  33 import Text.XML.HXT.Core (
  34   PU,
  35   XmlPickler(..),
  36   xp4Tuple,
  37   xp6Tuple,
  38   xpAttr,
  39   xpElem,
  40   xpInt,
  41   xpList,
  42   xpOption,
  43   xpPair,
  44   xpPrim,
  45   xpText,
  46   xpWrap )
  47
  48
  49 import TSN.DbImport ( DbImport(..), import_generic )
  50 import Xml ( pickle_unpickle, unpickleable )
  51
  52
  53 data InjuriesTeam =
  54   InjuriesTeam {
  55     team_name :: String,
  56     team_league :: Maybe String }
  57   deriving (Data, Eq, Show, Typeable)
  58
  59 data Listing =
  60   Listing {
  61     team :: InjuriesTeam,
  62     teamno :: Maybe Int,
  63     injuries :: String,
  64     updated :: Maybe Bool }
  65   deriving (Eq, Show)
  66
  67 data Message =
  68   Message {
  69     xml_file_id :: Int,
  70     heading :: String,
  71     category :: String,
  72     sport :: String,
  73     listings :: [Listing],
  74     time_stamp :: String }
  75   deriving (Eq, Show)
  76
  77
  78 mkPersist defaultCodegenConfig [groundhog|
  79 - entity: Listing
  80   dbName: injuries
  81   constructors:
  82     - name: Listing
  83       fields:
  84         - name: team
  85           embeddedType:
  86             - {name: team_name, dbName: team_name}
  87             - {name: team_league, dbName: team_league}
  88 - embedded: InjuriesTeam
  89   fields:
  90     - name: team_name
  91     - name: team_league
  92 |]
  93
  94
  95 pickle_injuries_team :: PU InjuriesTeam
  96 pickle_injuries_team =
  97   xpElem "team" $
  98     xpWrap (from_tuple, to_tuple) $
  99     xpPair xpText (xpOption $ xpAttr "league" xpText)
 100   where
 101     from_tuple = uncurryN InjuriesTeam
 102     to_tuple m = (team_name m, team_league m)
 103
 104 instance XmlPickler InjuriesTeam where
 105   xpickle = pickle_injuries_team
 106
 107 pickle_listing :: PU Listing
 108 pickle_listing =
 109   xpElem "listing" $
 110     xpWrap (from_tuple, to_tuple) $
 111     xp4Tuple pickle_injuries_team
 112              (xpOption $ xpElem "teamno" xpInt)
 113              (xpElem "injuries" xpText)
 114              (xpOption $ xpElem "updated" xpPrim)
 115   where
 116     from_tuple = uncurryN Listing
 117     to_tuple l = (team l, teamno l, injuries l, updated l)
 118
 119 instance XmlPickler Listing where
 120   xpickle = pickle_listing
 121
 122
 123 pickle_message :: PU Message
 124 pickle_message =
 125   xpElem "message" $
 126     xpWrap (from_tuple, to_tuple) $
 127     xp6Tuple (xpElem "XML_File_ID" xpInt)
 128              (xpElem "heading" xpText)
 129              (xpElem "category" xpText)
 130              (xpElem "sport" xpText)
 131              (xpList pickle_listing)
 132              (xpElem "time_stamp" xpText)
 133   where
 134     from_tuple = uncurryN Message
 135     to_tuple m = (xml_file_id m,
 136                   heading m,
 137                   category m,
 138                   sport m,
 139                   listings m,
 140                   time_stamp m)
 141
 142 instance XmlPickler Message where
 143   xpickle = pickle_message
 144
 145
 146
 147 instance DbImport Listing where
 148   dbimport = import_generic listings
 149
 150 -- * Tasty Tests
 151 injuries_tests :: TestTree
 152 injuries_tests =
 153   testGroup
 154     "Injuries tests"
 155     [ test_pickle_of_unpickle_is_identity,
 156       test_unpickle_succeeds ]
 157
 158
 159 -- | Warning, succeess of this test does not mean that unpickling
 160 --   succeeded.
 161 test_pickle_of_unpickle_is_identity :: TestTree
 162 test_pickle_of_unpickle_is_identity =
 163   testCase "pickle composed with unpickle is the identity" $ do
 164     let path = "test/xml/injuriesxml.xml"
 165     (expected :: [Message], actual) <- pickle_unpickle "message" path
 166     actual @?= expected
 167
 168
 169 test_unpickle_succeeds :: TestTree
 170 test_unpickle_succeeds =
 171   testCase "unpickling succeeds" $ do
 172   let path = "test/xml/injuriesxml.xml"
 173   actual <- unpickleable path pickle_message
 174   let expected = True
 175   actual @?= expected