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   WeatherConstructor(..),
  18   WeatherForecastConstructor(..),
  19   WeatherListingConstructor(..) )
  20 where
  21
  22 -- System imports.
  23 import Data.Tuple.Curry ( uncurryN )
  24 --import Database.Groundhog (
  25 --  insert_,
  26 --  migrate )
  27 --import Database.Groundhog.Core ( DefaultKey )
  28 import Database.Groundhog.TH (
  29   groundhog,
  30   mkPersist )
  31 import Test.Tasty ( TestTree, testGroup )
  32 import Test.Tasty.HUnit ( (@?=), testCase )
  33 import Text.XML.HXT.Core (
  34   PU,
  35   xp7Tuple,
  36   xpAttr,
  37   xpElem,
  38   xpInt,
  39   xpList,
  40   xpOption,
  41   xpPair,
  42   xpText,
  43   xpWrap )
  44
  45 -- Local imports.
  46 import TSN.Codegen (
  47   tsn_codegen_config )
  48 import TSN.DbImport ( DbImport(..) )
  49 import TSN.XmlImport ( XmlImport(..) )
  50 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  51
  52
  53 data WeatherListing =
  54   WeatherListing {
  55     db_teams :: String,
  56     db_weather :: String }
  57   deriving (Eq, Show)
  58
  59 instance FromXml WeatherListing where
  60   type Db WeatherListing = WeatherListing
  61   from_xml = id
  62
  63 instance XmlImport WeatherListing
  64
  65
  66 data WeatherLeague =
  67   WeatherLeague {
  68     league_name     :: Maybe String,
  69     listings :: [WeatherListing] }
  70   deriving (Eq, Show)
  71
  72 data WeatherForecast =
  73   WeatherForecast {
  74     db_game_date :: String, -- ^ This is a 'String' instead of 'UTCTime'
  75                             --   because they don't use a standard
  76                             --   time format for the day of the month.
  77     db_league_name :: Maybe String }
  78
  79 data WeatherForecastXml =
  80   WeatherForecastXml {
  81     xml_game_date :: String,  -- ^ This is a 'String' instead of 'UTCTime'
  82                               --   because they don't use a standard
  83                               --   time format for the day of the month.
  84     xml_league :: WeatherLeague }
  85   deriving (Eq, Show)
  86
  87
  88 instance FromXml WeatherForecastXml where
  89   type Db WeatherForecastXml = WeatherForecast
  90   from_xml WeatherForecastXml{..} =
  91     WeatherForecast { db_game_date   = xml_game_date,
  92                       db_league_name = (league_name xml_league) }
  93
  94 instance XmlImport WeatherForecastXml
  95
  96
  97 data Weather =
  98   Weather {
  99     db_sport :: String,
 100     db_title :: String }
 101
 102 data Message =
 103   Message {
 104     xml_xml_file_id :: Int,
 105     xml_heading :: String,
 106     xml_category :: String,
 107     xml_sport :: String,
 108     xml_title :: String,
 109     xml_forecasts :: [WeatherForecastXml],
 110     xml_time_stamp :: String }
 111   deriving (Eq, Show)
 112
 113 instance FromXml Message where
 114   type Db Message = Weather
 115   from_xml Message{..} =
 116     Weather {
 117       db_sport = xml_sport,
 118       db_title = xml_title }
 119
 120 instance XmlImport Message
 121
 122
 123 mkPersist tsn_codegen_config [groundhog|
 124 - entity: Weather
 125
 126 - entity: WeatherListing
 127   dbName: weather_listings
 128
 129 - entity: WeatherForecast
 130   dbName: weather_forecasts
 131
 132 |]
 133
 134
 135 instance DbImport Message where
 136   dbmigrate = undefined
 137   dbimport  = undefined
 138
 139
 140 pickle_listing :: PU WeatherListing
 141 pickle_listing =
 142   xpElem "listing" $
 143     xpWrap (from_pair, to_pair) $
 144       xpPair
 145         (xpElem "teams" xpText)
 146         (xpElem "weather" xpText)
 147   where
 148     from_pair = uncurry WeatherListing
 149     to_pair WeatherListing{..} = (db_teams, db_weather)
 150
 151 pickle_league :: PU WeatherLeague
 152 pickle_league =
 153   xpElem "league" $
 154     xpWrap (from_pair, to_pair) $
 155       xpPair
 156         (xpAttr "name" $ xpOption xpText)
 157         (xpList pickle_listing)
 158   where
 159     from_pair = uncurry WeatherLeague
 160     to_pair WeatherLeague{..} = (league_name, listings)
 161
 162 pickle_forecast :: PU WeatherForecastXml
 163 pickle_forecast =
 164   xpElem "forecast" $
 165     xpWrap (from_pair, to_pair) $
 166       xpPair
 167         (xpAttr "gamedate" xpText)
 168         pickle_league
 169   where
 170     from_pair = uncurry WeatherForecastXml
 171     to_pair WeatherForecastXml{..} = (xml_game_date,
 172                                       xml_league)
 173
 174 pickle_message :: PU Message
 175 pickle_message =
 176   xpElem "message" $
 177     xpWrap (from_tuple, to_tuple) $
 178       xp7Tuple
 179         (xpElem "XML_File_ID" xpInt)
 180         (xpElem "heading" xpText)
 181         (xpElem "category" xpText)
 182         (xpElem "sport" xpText)
 183         (xpElem "title" xpText)
 184         (xpList pickle_forecast)
 185         (xpElem "time_stamp" xpText)
 186   where
 187     from_tuple = uncurryN Message
 188     to_tuple Message{..} = (xml_xml_file_id,
 189                             xml_heading,
 190                             xml_category,
 191                             xml_sport,
 192                             xml_title,
 193                             xml_forecasts,
 194                             xml_time_stamp)
 195
 196 --
 197 -- Tasty tests
 198 --
 199
 200 weather_tests :: TestTree
 201 weather_tests =
 202   testGroup
 203     "Weather tests"
 204     [ test_pickle_of_unpickle_is_identity,
 205       test_unpickle_succeeds ]
 206
 207
 208 -- | If we unpickle something and then pickle it, we should wind up
 209 --   with the same thing we started with. WARNING: success of this
 210 --   test does not mean that unpickling succeeded.
 211 --
 212 test_pickle_of_unpickle_is_identity :: TestTree
 213 test_pickle_of_unpickle_is_identity =
 214   testCase "pickle composed with unpickle is the identity" $ do
 215     let path = "test/xml/weatherxml.xml"
 216     (expected, actual) <- pickle_unpickle pickle_message path
 217     actual @?= expected
 218
 219
 220 -- | Make sure we can actually unpickle these things.
 221 --
 222 test_unpickle_succeeds :: TestTree
 223 test_unpickle_succeeds =
 224   testCase "unpickling succeeds" $ do
 225   let path = "test/xml/weatherxml.xml"
 226   actual <- unpickleable path pickle_message
 227   let expected = True
 228   actual @?= expected