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 "newsxml.dtd". Each document contains a
10 -- root element \<message\> that contains an entire news item.
17 import Data.List.Utils ( join, split )
18 import Data.Tuple.Curry ( uncurryN )
19 import Database.Groundhog()
20 import Database.Groundhog.TH
21 import Test.Tasty ( TestTree, testGroup )
22 import Test.Tasty.HUnit ( (@?=), testCase )
23 import Text.XML.HXT.Core (
38 import Xml ( pickle_unpickle )
41 -- Can't use a newtype with groundhog.
43 NewsTeam { team_name :: String }
68 locations :: [NewsLocation],
72 time_stamp :: String }
76 mkPersist defaultCodegenConfig [groundhog|
80 - entity: NewsLocation
81 dbName: news_locations
90 - {name: msg_id, dbName: msg_id}
91 - {name: event_id, dbName: event_id}
100 pickle_news_team :: PU NewsTeam
103 xpWrap (from_string, to_string) xpText
105 to_string :: NewsTeam -> String
106 to_string = team_name
108 from_string :: String -> NewsTeam
109 from_string = NewsTeam
111 instance XmlPickler NewsTeam where
112 xpickle = pickle_news_team
114 pickle_msg_id :: PU MsgId
117 xpWrap (from_tuple, to_tuple) $
118 xpPair xpPrim (xpAttr "EventId" xpText0)
120 from_tuple = uncurryN MsgId
121 to_tuple m = (msg_id m, event_id m)
123 instance XmlPickler MsgId where
124 xpickle = pickle_msg_id
126 pickle_location :: PU NewsLocation
129 xpWrap (from_tuple, to_tuple) $
130 xpTriple (xpElem "city" xpText)
131 (xpElem "state" xpText)
132 (xpElem "country" xpText)
134 from_tuple = uncurryN NewsLocation
135 to_tuple l = (city l, state l, country l)
137 instance XmlPickler NewsLocation where
138 xpickle = pickle_location
141 pickle_message :: PU Message
144 xpWrap (from_tuple, to_tuple) $
145 xp12Tuple (xpElem "XML_File_ID" xpPrim)
146 (xpElem "heading" xpText)
148 (xpElem "category" xpText)
149 (xpElem "sport" xpText)
150 (xpElem "url" xpText)
151 (xpList $ pickle_news_team)
152 (xpList $ pickle_location)
153 (xpElem "SMS" xpText)
154 (xpElem "text" xpText)
156 (xpElem "time_stamp" xpText)
158 from_tuple = uncurryN Message
159 to_tuple m = (xml_file_id m,
172 pickle_continue :: PU String
174 xpWrap (to_string, from_string) $
176 (xpList $ xpElem "P" xpText)
178 from_string :: String -> [String]
179 from_string = split "\n"
181 to_string :: [String] -> String
182 to_string = join "\n"
184 instance XmlPickler Message where
185 xpickle = pickle_message
190 news_tests :: TestTree
194 [ test_pickle_of_unpickle_is_identity ]
197 test_pickle_of_unpickle_is_identity :: TestTree
198 test_pickle_of_unpickle_is_identity =
199 testCase "pickle composed with unpickle is the identity" $ do
200 let path = "test/xml/newsxml.xml"
201 (expected :: [Message], actual) <- pickle_unpickle "message" path