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