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