1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
10 -- contains a root element \<message\> that in turn contains zero or
13 -- The listings will be mapped to a database table called "injuries"
14 -- automatically. The root message is not retained.
16 module TSN.XML.Injuries (
22 import Data.Tuple.Curry ( uncurryN )
23 import Database.Groundhog()
24 import Database.Groundhog.TH (
28 import Test.Tasty ( TestTree, testGroup )
29 import Test.Tasty.HUnit ( (@?=), testCase )
30 import Text.XML.HXT.Core (
43 import TSN.DbImport ( DbImport(..), import_generic )
44 import Xml ( pickle_unpickle, unpickleable )
61 listings :: [Listing],
62 time_stamp :: String }
66 mkPersist defaultCodegenConfig [groundhog|
72 pickle_listing :: PU Listing
75 xpWrap (from_tuple, to_tuple) $
76 xp4Tuple (xpElem "team" xpText)
77 (xpElem "teamno" xpInt)
78 (xpElem "injuries" xpText)
79 (xpElem "updated" xpPrim)
81 from_tuple = uncurryN Listing
82 to_tuple l = (team l, teamno l, injuries l, updated l)
84 instance XmlPickler Listing where
85 xpickle = pickle_listing
88 pickle_message :: PU Message
91 xpWrap (from_tuple, to_tuple) $
92 xp6Tuple (xpElem "XML_File_ID" xpInt)
93 (xpElem "heading" xpText)
94 (xpElem "category" xpText)
95 (xpElem "sport" xpText)
96 (xpList pickle_listing)
97 (xpElem "time_stamp" xpText)
99 from_tuple = uncurryN Message
100 to_tuple m = (xml_file_id m,
107 instance XmlPickler Message where
108 xpickle = pickle_message
112 instance DbImport Listing where
113 dbimport = import_generic listings
116 injuries_tests :: TestTree
120 [ test_pickle_of_unpickle_is_identity,
121 test_unpickle_succeeds ]
124 -- | Warning, succeess of this test does not mean that unpickling
126 test_pickle_of_unpickle_is_identity :: TestTree
127 test_pickle_of_unpickle_is_identity =
128 testCase "pickle composed with unpickle is the identity" $ do
129 let path = "test/xml/injuriesxml.xml"
130 (expected :: [Message], actual) <- pickle_unpickle "message" path
134 test_unpickle_succeeds :: TestTree
135 test_unpickle_succeeds =
136 testCase "unpickling succeeds" $ do
137 let path = "test/xml/injuriesxml.xml"
138 actual <- unpickleable path pickle_message