src/TSN/XML/Weather.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   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.
  11 --
  12 module TSN.XML.Weather (
  13   pickle_message,
  14   -- * Tests
  15   weather_tests,
  16   -- * WARNING: these are private but exported to silence warnings
  17   Weather_WeatherForecastConstructor(..),
  18   WeatherConstructor(..),
  19   WeatherForecast_WeatherForecastListingConstructor(..),
  20   WeatherForecastConstructor(..),
  21   WeatherForecastListingConstructor(..) )
  22 where
  23
  24 -- System imports.
  25 import Control.Monad ( forM_ )
  26 import Data.Time ( UTCTime )
  27 import Data.Tuple.Curry ( uncurryN )
  28 import Database.Groundhog (
  29   insert_,
  30   migrate )
  31 import Database.Groundhog.Core ( DefaultKey )
  32 import Database.Groundhog.TH (
  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   xp7Tuple,
  40   xpAttr,
  41   xpElem,
  42   xpInt,
  43   xpList,
  44   xpOption,
  45   xpPair,
  46   xpText,
  47   xpWrap )
  48
  49 -- Local imports.
  50 import TSN.Codegen (
  51   tsn_codegen_config )
  52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  53 import TSN.Picklers ( xp_gamedate )
  54 import TSN.XmlImport ( XmlImport(..) )
  55 import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
  56
  57
  58
  59 -- | Database/XML representation of a weather forecast listing.
  60 --
  61 data WeatherForecastListing =
  62   WeatherForecastListing {
  63     db_teams :: String,
  64     db_weather :: String }
  65   deriving (Eq, Show)
  66
  67 -- | The database analogue of a 'WeatherForecastListing' is itself.
  68 instance ToDb WeatherForecastListing where
  69   type Db WeatherForecastListing = WeatherForecastListing
  70
  71 -- | This is needed to define the XmlImport instance for
  72 -- 'WeatherForecastListing'.
  73 --
  74 instance FromXml WeatherForecastListing where
  75   from_xml = id
  76
  77 -- | Allows us to call 'insert_xml' on the XML representation of
  78 --   WeatherForecastListing.
  79 --
  80 instance XmlImport WeatherForecastListing
  81
  82
  83 -- | XML representation of a league, as they appear in the weather
  84 --   documents. There is no associated database representation because
  85 --   the league element really adds no information besides its own
  86 --   (usually empty) name. Since there's exactly one league per
  87 --   forecast, we just store the league_name in the database
  88 --   representation of a forecast.
  89 --
  90 data WeatherLeague =
  91   WeatherLeague {
  92     league_name     :: Maybe String,
  93     listings :: [WeatherForecastListing] }
  94   deriving (Eq, Show)
  95
  96
  97 -- | Database representation of a weather forecast.
  98 --
  99 data WeatherForecast =
 100   WeatherForecast {
 101     db_game_date :: UTCTime,
 102     db_league_name :: Maybe String }
 103
 104 -- | XML representation of a weather forecast. It would have been
 105 --   cleaner to omit the 'WeatherLeague' middleman, but having it
 106 --   simplifies parsing.
 107 --
 108 data WeatherForecastXml =
 109   WeatherForecastXml {
 110     xml_game_date :: UTCTime,
 111     xml_league :: WeatherLeague }
 112   deriving (Eq, Show)
 113
 114
 115 instance ToDb WeatherForecastXml where
 116   -- | The database representation of a 'WeatherForecastXml' is a
 117   --   'WeatherForecast'.
 118   --
 119   type Db WeatherForecastXml = WeatherForecast
 120
 121 instance FromXml WeatherForecastXml where
 122   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
 123   --   replace the 'WeatherLeague' with its name.
 124   --
 125   from_xml WeatherForecastXml{..} =
 126     WeatherForecast { db_game_date   = xml_game_date,
 127                       db_league_name = (league_name xml_league) }
 128
 129 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 130 --   without first converting it to the database representation.
 131 --
 132 instance XmlImport WeatherForecastXml
 133
 134
 135 -- | The database representation of a weather message.
 136 --
 137 data Weather =
 138   Weather {
 139     db_sport :: String,
 140     db_title :: String }
 141
 142
 143 -- | The XML representation of a weather message.
 144 --
 145 data Message =
 146   Message {
 147     xml_xml_file_id :: Int,
 148     xml_heading :: String,
 149     xml_category :: String,
 150     xml_sport :: String,
 151     xml_title :: String,
 152     xml_forecasts :: [WeatherForecastXml],
 153     xml_time_stamp :: String }
 154   deriving (Eq, Show)
 155
 156
 157 instance ToDb Message where
 158   -- | The database representation of 'Message' is 'Weather'.
 159   --
 160   type Db Message = Weather
 161
 162 instance FromXml Message where
 163   -- | To get a 'Weather' from a 'Message', we drop a bunch of
 164   --   unwanted fields.
 165   --
 166   from_xml Message{..} =
 167     Weather {
 168       db_sport = xml_sport,
 169       db_title = xml_title }
 170
 171 -- | This allows us to call 'insert_xml' on a 'Message' without first
 172 --   converting it to the database representation.
 173 --
 174 instance XmlImport Message
 175
 176
 177 -- | A mapping between 'Weather' objects and their children
 178 --   'WeatherForecast's.
 179 --
 180 data Weather_WeatherForecast =
 181   Weather_WeatherForecast
 182     (DefaultKey Weather)
 183     (DefaultKey WeatherForecast)
 184
 185 -- | A mapping between 'WeatherForecast' objects and their children
 186 --   'WeatherForecastListing's.
 187 --
 188 data WeatherForecast_WeatherForecastListing =
 189   WeatherForecast_WeatherForecastListing
 190     (DefaultKey WeatherForecast)
 191     (DefaultKey WeatherForecastListing)
 192
 193 mkPersist tsn_codegen_config [groundhog|
 194 - entity: Weather
 195
 196 - entity: WeatherForecast
 197   dbName: weather_forecasts
 198
 199 - entity: WeatherForecastListing
 200   dbName: weather_forecast_listings
 201
 202 - entity: Weather_WeatherForecast
 203   dbName: weather__weather_forecasts
 204   constructors:
 205     - name: Weather_WeatherForecast
 206       fields:
 207         - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
 208           dbName: weather_id
 209         - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
 210           dbName: weather_forecasts_id
 211
 212 - entity: WeatherForecast_WeatherForecastListing
 213   dbName: weather_forecasts__weather_forecast_listings
 214   constructors:
 215     - name: WeatherForecast_WeatherForecastListing
 216       fields:
 217         # Default by mkNormalFieldName
 218         - name: weatherForecast_WeatherForecastListing0
 219           dbName: weather_forecasts_id
 220
 221          # Default by mkNormalFieldName
 222         - name: weatherForecast_WeatherForecastListing1
 223           dbName: weather_forecast_listings_id
 224 |]
 225
 226
 227 instance DbImport Message where
 228   dbmigrate _ =
 229     run_dbmigrate $ do
 230       migrate (undefined :: Weather)
 231       migrate (undefined :: WeatherForecast)
 232       migrate (undefined :: WeatherForecastListing)
 233       migrate (undefined :: Weather_WeatherForecast)
 234       migrate (undefined :: WeatherForecast_WeatherForecastListing)
 235
 236   dbimport m = do
 237     -- The weather database schema has a nice linear structure. First
 238     -- we insert the top-level weather record.
 239     weather_id <- insert_xml m
 240
 241     -- Next insert all of the forecasts, one at a time.
 242     forM_ (xml_forecasts m) $ \forecast -> do
 243       forecast_id <- insert_xml forecast
 244
 245       -- Map this forecast to its parent weather record.
 246       insert_ (Weather_WeatherForecast weather_id forecast_id)
 247
 248       -- Insert all of this forecast's listings.
 249       forM_ (listings $ xml_league forecast) $ \listing -> do
 250         listing_id <- insert_xml listing
 251
 252         -- Map this listing to its parent forecast.
 253         insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
 254
 255     return ImportSucceeded
 256
 257
 258
 259 -- | Pickler to convert a 'WeatherForecastListing' to/from XML.
 260 --
 261 pickle_listing :: PU WeatherForecastListing
 262 pickle_listing =
 263   xpElem "listing" $
 264     xpWrap (from_pair, to_pair) $
 265       xpPair
 266         (xpElem "teams" xpText)
 267         (xpElem "weather" xpText)
 268   where
 269     from_pair = uncurry WeatherForecastListing
 270     to_pair WeatherForecastListing{..} = (db_teams, db_weather)
 271
 272
 273 -- | Pickler to convert a 'WeatherLeague' to/from XML.
 274 --
 275 pickle_league :: PU WeatherLeague
 276 pickle_league =
 277   xpElem "league" $
 278     xpWrap (from_pair, to_pair) $
 279       xpPair
 280         (xpAttr "name" $ xpOption xpText)
 281         (xpList pickle_listing)
 282   where
 283     from_pair = uncurry WeatherLeague
 284     to_pair WeatherLeague{..} = (league_name, listings)
 285
 286
 287 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
 288 --
 289 pickle_forecast :: PU WeatherForecastXml
 290 pickle_forecast =
 291   xpElem "forecast" $
 292     xpWrap (from_pair, to_pair) $
 293       xpPair
 294         (xpAttr "gamedate" xp_gamedate)
 295         pickle_league
 296   where
 297     from_pair = uncurry WeatherForecastXml
 298     to_pair WeatherForecastXml{..} = (xml_game_date,
 299                                       xml_league)
 300
 301
 302
 303 -- | Pickler to convert a 'Message' to/from XML.
 304 --
 305 pickle_message :: PU Message
 306 pickle_message =
 307   xpElem "message" $
 308     xpWrap (from_tuple, to_tuple) $
 309       xp7Tuple
 310         (xpElem "XML_File_ID" xpInt)
 311         (xpElem "heading" xpText)
 312         (xpElem "category" xpText)
 313         (xpElem "sport" xpText)
 314         (xpElem "title" xpText)
 315         (xpList pickle_forecast)
 316         (xpElem "time_stamp" xpText)
 317   where
 318     from_tuple = uncurryN Message
 319     to_tuple Message{..} = (xml_xml_file_id,
 320                             xml_heading,
 321                             xml_category,
 322                             xml_sport,
 323                             xml_title,
 324                             xml_forecasts,
 325                             xml_time_stamp)
 326
 327 --
 328 -- Tasty tests
 329 --
 330
 331 weather_tests :: TestTree
 332 weather_tests =
 333   testGroup
 334     "Weather tests"
 335     [ test_pickle_of_unpickle_is_identity,
 336       test_unpickle_succeeds ]
 337
 338
 339 -- | If we unpickle something and then pickle it, we should wind up
 340 --   with the same thing we started with. WARNING: success of this
 341 --   test does not mean that unpickling succeeded.
 342 --
 343 test_pickle_of_unpickle_is_identity :: TestTree
 344 test_pickle_of_unpickle_is_identity =
 345   testCase "pickle composed with unpickle is the identity" $ do
 346     let path = "test/xml/weatherxml.xml"
 347     (expected, actual) <- pickle_unpickle pickle_message path
 348     actual @?= expected
 349
 350
 351 -- | Make sure we can actually unpickle these things.
 352 --
 353 test_unpickle_succeeds :: TestTree
 354 test_unpickle_succeeds =
 355   testCase "unpickling succeeds" $ do
 356   let path = "test/xml/weatherxml.xml"
 357   actual <- unpickleable path pickle_message
 358   let expected = True
 359   actual @?= expected