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 data WeatherForecastListing =
  59   WeatherForecastListing {
  60     db_teams :: String,
  61     db_weather :: String }
  62   deriving (Eq, Show)
  63
  64 instance FromXml WeatherForecastListing where
  65   type Db WeatherForecastListing = WeatherForecastListing
  66   from_xml = id
  67
  68 instance XmlImport WeatherForecastListing
  69
  70
  71 data WeatherLeague =
  72   WeatherLeague {
  73     league_name     :: Maybe String,
  74     listings :: [WeatherForecastListing] }
  75   deriving (Eq, Show)
  76
  77 data WeatherForecast =
  78   WeatherForecast {
  79     db_game_date :: UTCTime,
  80     db_league_name :: Maybe String }
  81
  82 data WeatherForecastXml =
  83   WeatherForecastXml {
  84     xml_game_date :: UTCTime,
  85     xml_league :: WeatherLeague }
  86   deriving (Eq, Show)
  87
  88
  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) }
  94
  95 instance XmlImport WeatherForecastXml
  96
  97
  98 data Weather =
  99   Weather {
 100     db_sport :: String,
 101     db_title :: String }
 102
 103 data Message =
 104   Message {
 105     xml_xml_file_id :: Int,
 106     xml_heading :: String,
 107     xml_category :: String,
 108     xml_sport :: String,
 109     xml_title :: String,
 110     xml_forecasts :: [WeatherForecastXml],
 111     xml_time_stamp :: String }
 112   deriving (Eq, Show)
 113
 114 instance FromXml Message where
 115   type Db Message = Weather
 116   from_xml Message{..} =
 117     Weather {
 118       db_sport = xml_sport,
 119       db_title = xml_title }
 120
 121 instance XmlImport Message
 122
 123
 124 data Weather_WeatherForecast =
 125   Weather_WeatherForecast
 126     (DefaultKey Weather)
 127     (DefaultKey WeatherForecast)
 128
 129 data WeatherForecast_WeatherForecastListing =
 130   WeatherForecast_WeatherForecastListing
 131     (DefaultKey WeatherForecast)
 132     (DefaultKey WeatherForecastListing)
 133
 134 mkPersist tsn_codegen_config [groundhog|
 135 - entity: Weather
 136
 137 - entity: WeatherForecast
 138   dbName: weather_forecasts
 139
 140 - entity: WeatherForecastListing
 141   dbName: weather_forecast_listings
 142
 143 - entity: Weather_WeatherForecast
 144   dbName: weather__weather_forecasts
 145   constructors:
 146     - name: Weather_WeatherForecast
 147       fields:
 148         - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
 149           dbName: weather_id
 150         - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
 151           dbName: weather_forecasts_id
 152
 153 - entity: WeatherForecast_WeatherForecastListing
 154   dbName: weather_forecasts__weather_forecast_listings
 155   constructors:
 156     - name: WeatherForecast_WeatherForecastListing
 157       fields:
 158         # Default by mkNormalFieldName
 159         - name: weatherForecast_WeatherForecastListing0
 160           dbName: weather_forecasts_id
 161
 162          # Default by mkNormalFieldName
 163         - name: weatherForecast_WeatherForecastListing1
 164           dbName: weather_forecast_listings_id
 165 |]
 166
 167
 168 instance DbImport Message where
 169   dbmigrate _ =
 170     run_dbmigrate $ do
 171       migrate (undefined :: Weather)
 172       migrate (undefined :: WeatherForecast)
 173       migrate (undefined :: WeatherForecastListing)
 174       migrate (undefined :: Weather_WeatherForecast)
 175       migrate (undefined :: WeatherForecast_WeatherForecastListing)
 176
 177   dbimport m = do
 178     weather_id <- insert_xml m
 179
 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
 186
 187     return ImportSucceeded
 188
 189
 190 pickle_listing :: PU WeatherForecastListing
 191 pickle_listing =
 192   xpElem "listing" $
 193     xpWrap (from_pair, to_pair) $
 194       xpPair
 195         (xpElem "teams" xpText)
 196         (xpElem "weather" xpText)
 197   where
 198     from_pair = uncurry WeatherForecastListing
 199     to_pair WeatherForecastListing{..} = (db_teams, db_weather)
 200
 201 pickle_league :: PU WeatherLeague
 202 pickle_league =
 203   xpElem "league" $
 204     xpWrap (from_pair, to_pair) $
 205       xpPair
 206         (xpAttr "name" $ xpOption xpText)
 207         (xpList pickle_listing)
 208   where
 209     from_pair = uncurry WeatherLeague
 210     to_pair WeatherLeague{..} = (league_name, listings)
 211
 212 pickle_forecast :: PU WeatherForecastXml
 213 pickle_forecast =
 214   xpElem "forecast" $
 215     xpWrap (from_pair, to_pair) $
 216       xpPair
 217         (xpAttr "gamedate" xp_gamedate)
 218         pickle_league
 219   where
 220     from_pair = uncurry WeatherForecastXml
 221     to_pair WeatherForecastXml{..} = (xml_game_date,
 222                                       xml_league)
 223
 224 pickle_message :: PU Message
 225 pickle_message =
 226   xpElem "message" $
 227     xpWrap (from_tuple, to_tuple) $
 228       xp7Tuple
 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)
 236   where
 237     from_tuple = uncurryN Message
 238     to_tuple Message{..} = (xml_xml_file_id,
 239                             xml_heading,
 240                             xml_category,
 241                             xml_sport,
 242                             xml_title,
 243                             xml_forecasts,
 244                             xml_time_stamp)
 245
 246 --
 247 -- Tasty tests
 248 --
 249
 250 weather_tests :: TestTree
 251 weather_tests =
 252   testGroup
 253     "Weather tests"
 254     [ test_pickle_of_unpickle_is_identity,
 255       test_unpickle_succeeds ]
 256
 257
 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.
 261 --
 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
 267     actual @?= expected
 268
 269
 270 -- | Make sure we can actually unpickle these things.
 271 --
 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
 277   let expected = True
 278   actual @?= expected