1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 -- | Parse TSN XML for the DTD "weatherxml.dtd". Each document
9 -- contains a bunch of forecasts, which each contain one league, and
10 -- that league contains a bunch of listings.
12 module TSN.XML.Weather (
16 -- * WARNING: these are private but exported to silence warnings
17 Weather_WeatherForecastConstructor(..),
18 WeatherConstructor(..),
19 WeatherForecast_WeatherForecastListingConstructor(..),
20 WeatherForecastConstructor(..),
21 WeatherForecastListingConstructor(..) )
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime )
27 import Data.Tuple.Curry ( uncurryN )
28 import Database.Groundhog (
31 import Database.Groundhog.Core ( DefaultKey )
32 import Database.Groundhog.TH (
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
53 import TSN.Picklers ( xp_gamedate )
54 import TSN.XmlImport ( XmlImport(..) )
55 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
58 data WeatherForecastListing =
59 WeatherForecastListing {
61 db_weather :: String }
64 instance FromXml WeatherForecastListing where
65 type Db WeatherForecastListing = WeatherForecastListing
68 instance XmlImport WeatherForecastListing
73 league_name :: Maybe String,
74 listings :: [WeatherForecastListing] }
77 data WeatherForecast =
79 db_game_date :: UTCTime,
80 db_league_name :: Maybe String }
82 data WeatherForecastXml =
84 xml_game_date :: UTCTime,
85 xml_league :: WeatherLeague }
89 instance FromXml WeatherForecastXml where
90 type Db WeatherForecastXml = WeatherForecast
91 from_xml WeatherForecastXml{..} =
92 WeatherForecast { db_game_date = xml_game_date,
93 db_league_name = (league_name xml_league) }
95 instance XmlImport WeatherForecastXml
105 xml_xml_file_id :: Int,
106 xml_heading :: String,
107 xml_category :: String,
110 xml_forecasts :: [WeatherForecastXml],
111 xml_time_stamp :: String }
114 instance FromXml Message where
115 type Db Message = Weather
116 from_xml Message{..} =
118 db_sport = xml_sport,
119 db_title = xml_title }
121 instance XmlImport Message
124 data Weather_WeatherForecast =
125 Weather_WeatherForecast
127 (DefaultKey WeatherForecast)
129 data WeatherForecast_WeatherForecastListing =
130 WeatherForecast_WeatherForecastListing
131 (DefaultKey WeatherForecast)
132 (DefaultKey WeatherForecastListing)
134 mkPersist tsn_codegen_config [groundhog|
137 - entity: WeatherForecast
138 dbName: weather_forecasts
140 - entity: WeatherForecastListing
141 dbName: weather_forecast_listings
143 - entity: Weather_WeatherForecast
144 dbName: weather__weather_forecasts
146 - name: Weather_WeatherForecast
148 - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
150 - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
151 dbName: weather_forecasts_id
153 - entity: WeatherForecast_WeatherForecastListing
154 dbName: weather_forecasts__weather_forecast_listings
156 - name: WeatherForecast_WeatherForecastListing
158 # Default by mkNormalFieldName
159 - name: weatherForecast_WeatherForecastListing0
160 dbName: weather_forecasts_id
162 # Default by mkNormalFieldName
163 - name: weatherForecast_WeatherForecastListing1
164 dbName: weather_forecast_listings_id
168 instance DbImport Message where
171 migrate (undefined :: Weather)
172 migrate (undefined :: WeatherForecast)
173 migrate (undefined :: WeatherForecastListing)
174 migrate (undefined :: Weather_WeatherForecast)
175 migrate (undefined :: WeatherForecast_WeatherForecastListing)
178 weather_id <- insert_xml m
180 forM_ (xml_forecasts m) $ \forecast -> do
181 forecast_id <- insert_xml forecast
182 insert_ (Weather_WeatherForecast weather_id forecast_id)
183 forM_ (listings $ xml_league forecast) $ \listing -> do
184 listing_id <- insert_xml listing
185 insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
187 return ImportSucceeded
190 pickle_listing :: PU WeatherForecastListing
193 xpWrap (from_pair, to_pair) $
195 (xpElem "teams" xpText)
196 (xpElem "weather" xpText)
198 from_pair = uncurry WeatherForecastListing
199 to_pair WeatherForecastListing{..} = (db_teams, db_weather)
201 pickle_league :: PU WeatherLeague
204 xpWrap (from_pair, to_pair) $
206 (xpAttr "name" $ xpOption xpText)
207 (xpList pickle_listing)
209 from_pair = uncurry WeatherLeague
210 to_pair WeatherLeague{..} = (league_name, listings)
212 pickle_forecast :: PU WeatherForecastXml
215 xpWrap (from_pair, to_pair) $
217 (xpAttr "gamedate" xp_gamedate)
220 from_pair = uncurry WeatherForecastXml
221 to_pair WeatherForecastXml{..} = (xml_game_date,
224 pickle_message :: PU Message
227 xpWrap (from_tuple, to_tuple) $
229 (xpElem "XML_File_ID" xpInt)
230 (xpElem "heading" xpText)
231 (xpElem "category" xpText)
232 (xpElem "sport" xpText)
233 (xpElem "title" xpText)
234 (xpList pickle_forecast)
235 (xpElem "time_stamp" xpText)
237 from_tuple = uncurryN Message
238 to_tuple Message{..} = (xml_xml_file_id,
250 weather_tests :: TestTree
254 [ test_pickle_of_unpickle_is_identity,
255 test_unpickle_succeeds ]
258 -- | If we unpickle something and then pickle it, we should wind up
259 -- with the same thing we started with. WARNING: success of this
260 -- test does not mean that unpickling succeeded.
262 test_pickle_of_unpickle_is_identity :: TestTree
263 test_pickle_of_unpickle_is_identity =
264 testCase "pickle composed with unpickle is the identity" $ do
265 let path = "test/xml/weatherxml.xml"
266 (expected, actual) <- pickle_unpickle pickle_message path
270 -- | Make sure we can actually unpickle these things.
272 test_unpickle_succeeds :: TestTree
273 test_unpickle_succeeds =
274 testCase "unpickling succeeds" $ do
275 let path = "test/xml/weatherxml.xml"
276 actual <- unpickleable path pickle_message