Weather.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
--   contains a bunch of forecasts, which each contain zero or more
--   leagues, which in turn (each) contain a bunch of listings.
--
module TSN.XML.Weather (
  dtd,
  is_type1,
  pickle_message,
  teams_are_normal,
  -- * Tests
  weather_tests,
  -- * WARNING: these are private but exported to silence warnings
  WeatherConstructor(..),
  WeatherDetailedWeatherListingItemConstructor(..),
  WeatherForecastConstructor(..),
  WeatherForecastListingConstructor(..) )
where

-- System imports.
import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
import Database.Groundhog (
  countAll,
  deleteAll,
  insert_,
  migrate )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import qualified GHC.Generics as GHC ( Generic )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  XmlTree,
  (/>),
  (>>>),
  addNav,
  descendantAxis,
  filterAxis,
  followingSiblingAxis,
  hasName,
  remNav,
  runLA,
  xp8Tuple,
  xp9Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpText,
  xpTriple,
  xpWrap )

-- Local imports.
import TSN.Codegen (
  tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
  Child(..),
  FromXml(..),
  FromXmlFk(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_read_invalid_document,
  unsafe_unpickle )



-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
dtd :: String
dtd = "weatherxml.dtd"


--
-- DB/XML Data types
--

-- * WeatherForecastListing/WeatherForecastListingXml

-- | XML representation of a weather forecast listing.
--
data WeatherForecastListingXml =
  WeatherForecastListingXml {
    xml_teams :: String,
    xml_weather :: Maybe String }
  deriving (Eq, GHC.Generic, Show)


-- | For 'H.convert'.
--
instance H.HVector WeatherForecastListingXml


-- | Database representation of a weather forecast listing. The
--   'db_league_name' field should come from the containing \<league\>
--   element which is not stored in the database.
--
data WeatherForecastListing =
  WeatherForecastListing {
    db_weather_forecasts_id :: DefaultKey WeatherForecast,
    db_league_name :: Maybe String,
    db_teams :: String,
    db_weather :: Maybe String }


-- | We don't make 'WeatherForecastListingXml' an instance of
--   'FromXmlFk' because it needs some additional information, namely
--   the league name from its containing \<league\> element.
--
--   When supplied with a forecast id and a league name, this will
--   turn an XML listing into a database one.
--
from_xml_fk_league :: DefaultKey WeatherForecast
                   -> (Maybe String)
                   -> WeatherForecastListingXml
                   -> WeatherForecastListing
from_xml_fk_league fk ln WeatherForecastListingXml{..} =
    WeatherForecastListing {
      db_weather_forecasts_id = fk,
      db_league_name = ln,
      db_teams = xml_teams,
      db_weather = xml_weather }


-- * WeatherLeague

-- | XML representation of a league, as they appear in the weather
--   documents. There is no associated database representation because
--   the league element really adds no information besides its own
--   (usually empty) name. The leagues contain listings, so we
--   associate the league name with each listing instead.
--
data WeatherLeague =
  WeatherLeague {
    league_name :: Maybe String,
    listings    :: [WeatherForecastListingXml] }
  deriving (Eq, Show)


-- * WeatherForecast/WeatherForecastXml

-- | Database representation of a weather forecast.
--
data WeatherForecast =
  WeatherForecast {
    db_weather_id :: DefaultKey Weather,
    db_game_date :: UTCTime }


-- | XML representation of a weather forecast.
--
data WeatherForecastXml =
  WeatherForecastXml {
    xml_game_date :: UTCTime,
    xml_leagues :: [WeatherLeague] }
  deriving (Eq, GHC.Generic, Show)


-- | For 'H.convert'.
--
instance H.HVector WeatherForecastXml


instance ToDb WeatherForecastXml where
  -- | The database representation of a 'WeatherForecastXml' is a
  --   'WeatherForecast'.
  --
  type Db WeatherForecastXml = WeatherForecast


instance Child WeatherForecastXml where
  -- | The database type containing a 'WeatherForecastXml' is
  --   'Weather'.
  type Parent WeatherForecastXml = Weather


instance FromXmlFk WeatherForecastXml where

  -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
  --   add the foreign key to the containing 'Weather', and copy the
  --   game date.
  --
  --   This is so short it's pointless to do it generically.
  --
  from_xml_fk fk WeatherForecastXml{..} =
    WeatherForecast {
      db_weather_id  = fk,
      db_game_date   = xml_game_date }


-- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
--   without first converting it to the database representation.
--
instance XmlImportFk WeatherForecastXml

-- * WeatherDetailedWeatherXml

-- | XML Representation of a \<Detailed_Weather\>, which just contains
--   a bunch iof \<DW_Listing\>s. There is no associated database type
--   since these don't really contain any information.
--
data WeatherDetailedWeatherXml =
  WeatherDetailedWeatherXml {
    xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
  deriving (Eq, Show)


-- * WeatherDetailedWeatherXml

-- | XML Representation of a \<DW_Listing\>. The sport and sport code
--   come as attributes, but then these just contain a bunch of
--   \<Item\>s. There is no associated database type since these don't
--   contain much information. The sport we already know from the
--   \<message\>, while the sport code is ignored since it's already
--   present in each \<Item\>s.
--
data WeatherDetailedWeatherListingXml =
  WeatherDetailedWeatherListingXml
    String -- xml_dtl_listing_sport, unused
    String -- xml_dtl_listing_sport_code, unused
    [WeatherDetailedWeatherListingItemXml] -- xml_items
  deriving (Eq, GHC.Generic, Show)


-- | Accessor for the third field of WeatherDetailedWeatherListingXml.
--   We don't use field names to avoid the unused field warnings that
--   we'd otherwise get for the first two fields.
--
xml_items :: WeatherDetailedWeatherListingXml
          -> [WeatherDetailedWeatherListingItemXml]
xml_items (WeatherDetailedWeatherListingXml _ _ items) = items


-- | For 'H.convert'.
--
instance H.HVector WeatherDetailedWeatherListingXml


-- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml

-- | Database representation of a detailed weather item. The away/home
--   teams don't use the representation in "TSN.Team" because all
--   we're given is a name, and a team id is required for "TSN.Team".
--
--   We also drop the sport name, because it's given in the parent
--   'Weather'.
--
--   The leading underscores prevent unused field warnings.
--
data WeatherDetailedWeatherListingItem =
  WeatherDetailedWeatherListingItem {
    _db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
                                             --   using \"dtl\" prefix.
    _db_sport_code :: String,
    _db_game_id :: Int,
    _db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
    _db_away_team :: String,
    _db_home_team :: String,
    _db_weather_type :: Int,
    _db_description :: Maybe String,
    _db_temp_adjust :: Maybe String,
    _db_temperature :: Int }
  deriving ( GHC.Generic )

-- | For 'H.cons' and 'H.convert'.
--
instance H.HVector WeatherDetailedWeatherListingItem


-- | XML representation of a detailed weather item. Same as the
--   database representation, only without the foreign key and the
--   sport name that comes from the containing listing.
--
--   The leading underscores prevent unused field warnings.
--
data WeatherDetailedWeatherListingItemXml =
  WeatherDetailedWeatherListingItemXml {
    _xml_sport_code :: String,
    _xml_game_id :: Int,
    _xml_dtl_game_date :: UTCTime,
    _xml_away_team :: String,
    _xml_home_team :: String,
    _xml_weather_type :: Int,
    _xml_description :: Maybe String,
    _xml_temp_adjust :: Maybe String,
    _xml_temperature :: Int }
  deriving (Eq, GHC.Generic, Show)


-- | For 'H.convert'.
--
instance H.HVector WeatherDetailedWeatherListingItemXml

instance ToDb WeatherDetailedWeatherListingItemXml where
  -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
  type Db WeatherDetailedWeatherListingItemXml =
    WeatherDetailedWeatherListingItem

instance Child WeatherDetailedWeatherListingItemXml where
  -- | We skip two levels of containers and say that the items belong
  --   to the top-level 'Weather'.
  type Parent WeatherDetailedWeatherListingItemXml = Weather

instance FromXmlFk WeatherDetailedWeatherListingItemXml where
  -- | To convert from the XML to database representation, we simply
  --   add the foreign key (to Weather) and copy the rest of the fields.
  from_xml_fk = H.cons

-- | This allows us to insert the XML representation directly without
--   having to do the manual XML -\> DB conversion.
--
instance XmlImportFk WeatherDetailedWeatherListingItemXml

-- * Weather/Message

-- | The database representation of a weather message. We don't
-- contain the forecasts or the detailed weather since those are
-- foreigned-keyed to us.
--
data Weather =
  Weather {
    db_xml_file_id :: Int,
    db_sport :: String,
    db_title :: String,
    db_time_stamp :: UTCTime }


-- | The XML representation of a weather message.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_forecasts :: [WeatherForecastXml],
    xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
    xml_time_stamp :: UTCTime }
  deriving (Eq, GHC.Generic, Show)


-- | For 'H.convert'.
--
instance H.HVector Message


instance ToDb Message where
  -- | The database representation of 'Message' is 'Weather'.
  --
  type Db Message = Weather

instance FromXml Message where
  -- | To get a 'Weather' from a 'Message', we drop a bunch of
  --   unwanted fields.
  --
  from_xml Message{..} =
    Weather {
      db_xml_file_id = xml_xml_file_id,
      db_sport = xml_sport,
      db_title = xml_title,
      db_time_stamp = xml_time_stamp }

-- | This allows us to insert the XML representation 'Message'
--   directly.
--
instance XmlImport Message


--
-- * Database stuff
--

mkPersist tsn_codegen_config [groundhog|
- entity: Weather
  constructors:
    - name: Weather
      uniques:
        - name: unique_weather
          type: constraint
          # Prevent multiple imports of the same message.
          fields: [db_xml_file_id]

- entity: WeatherForecast
  dbName: weather_forecasts
  constructors:
    - name: WeatherForecast
      fields:
        - name: db_weather_id
          reference:
            onDelete: cascade

- entity: WeatherForecastListing
  dbName: weather_forecast_listings
  constructors:
    - name: WeatherForecastListing
      fields:
        - name: db_weather_forecasts_id
          reference:
            onDelete: cascade

  # We rename the two fields that needed a "dtl" prefix to avoid a name
  # clash.
- entity: WeatherDetailedWeatherListingItem
  dbName: weather_detailed_items
  constructors:
    - name: WeatherDetailedWeatherListingItem
      fields:
        - name: _db_dtl_weather_id
          dbName: weather_id
          reference:
            onDelete: cascade
        - name: _db_dtl_game_date
          dbName: game_date

|]



-- | There are two different types of documents that claim to be
--   \"weatherxml.dtd\". The first, more common type has listings
--   within forecasts. The second type has forecasts within
--   listings. Clearly we can't parse both of these using the same
--   parser!
--
--   For now we're simply punting on the issue and refusing to parse
--   the second type. This will check the given @xmltree@ to see if
--   there are any forecasts contained within listings. If there are,
--   then it's the second type that we don't know what to do with.
--
is_type1 :: XmlTree -> Bool
is_type1 xmltree =
  case elements of
    [] -> True
    _  -> False
  where
    parse :: XmlTree -> [XmlTree]
    parse = runLA $  hasName "/"
                  /> hasName "message"
                  /> hasName "listing"
                  /> hasName "forecast"

    elements = parse xmltree


-- | Some weatherxml documents even have the Home/Away teams in the
--   wrong order. We can't parse that! This next bit of voodoo detects
--   whether or not there are any \<HomeTeam\> elements that are
--   directly followed by sibling \<AwayTeam\> elements. This is the
--   opposite of the usual order.
--
teams_are_normal :: XmlTree -> Bool
teams_are_normal xmltree =
  case elements of
    [] -> True
    _  -> False
  where
    parse :: XmlTree -> [XmlTree]
    parse = runLA $  hasName "/"
                  /> hasName "message"
                  /> hasName "Detailed_Weather"
                  /> hasName "DW_Listing"
                  /> hasName "Item"
                  >>> addNav
                  >>> descendantAxis
                  >>> filterAxis (hasName "HomeTeam")
                  >>> followingSiblingAxis
                  >>> remNav
                  >>> hasName "AwayTeam"

    elements = parse xmltree


instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: Weather)
      migrate (undefined :: WeatherForecast)
      migrate (undefined :: WeatherForecastListing)
      migrate (undefined :: WeatherDetailedWeatherListingItem)

  dbimport m = do
    -- First we insert the top-level weather record.
    weather_id <- insert_xml m

    -- Next insert all of the forecasts, one at a time.
    forM_ (xml_forecasts m) $ \forecast -> do
      forecast_id <- insert_xml_fk weather_id forecast

      -- With the forecast id in hand, loop through this forecast's
      -- leagues...
      forM_ (xml_leagues forecast) $ \league -> do
        -- Construct the function that converts an XML listing to a
        -- database one.
        let todb = from_xml_fk_league forecast_id (league_name league)

        -- Now use it to convert all of the XML listings.
        let db_listings = map todb (listings league)

        -- And finally, insert those DB listings.
        mapM_ insert_ db_listings

    -- Now we do the detailed weather items.
    case (xml_detailed_weather m) of
      Nothing -> return ()
      Just dw -> do
        let detailed_listings = xml_detailed_listings dw
        let items = concatMap xml_items detailed_listings
        mapM_ (insert_xml_fk_ weather_id) items

    return ImportSucceeded


--
-- * Pickling
--

-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
--
pickle_listing :: PU WeatherForecastListingXml
pickle_listing =
  xpElem "listing" $
    xpWrap (from_pair, H.convert) $
      xpPair
        (xpElem "teams" xpText)
        (xpElem "weather" (xpOption xpText))
  where
    from_pair = uncurry WeatherForecastListingXml



-- | Pickler to convert a 'WeatherLeague' to/from XML.
--
pickle_league :: PU WeatherLeague
pickle_league =
  xpElem "league" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpAttr "name" $ xpOption xpText)
        (xpList pickle_listing)
  where
    from_pair = uncurry WeatherLeague
    to_pair WeatherLeague{..} = (league_name, listings)


-- | Pickler to convert a 'WeatherForecastXml' to/from XML.
--
pickle_forecast :: PU WeatherForecastXml
pickle_forecast =
  xpElem "forecast" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpAttr "gamedate" xp_gamedate)
        (xpList pickle_league)
  where
    from_pair = uncurry WeatherForecastXml
    to_pair WeatherForecastXml{..} = (xml_game_date,
                                      xml_leagues)



-- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
--
pickle_item :: PU WeatherDetailedWeatherListingItemXml
pickle_item =
  xpElem "Item" $
    xpWrap (from_tuple, H.convert) $
    xp9Tuple (xpElem "Sportcode" xpText)
             (xpElem "GameID" xpInt)
             (xpElem "Gamedate" xp_datetime)
             (xpElem "AwayTeam" xpText)
             (xpElem "HomeTeam" xpText)
             (xpElem "WeatherType" xpInt)
             (xpElem "Description" (xpOption xpText))
             (xpElem "TempAdjust" (xpOption xpText))
             (xpElem "Temperature" xpInt)
  where
    from_tuple = uncurryN WeatherDetailedWeatherListingItemXml



-- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
--
pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
pickle_dw_listing =
  xpElem "DW_Listing" $
    xpWrap (from_tuple, H.convert) $
    xpTriple (xpAttr "SportCode" xpText)
             (xpAttr "Sport" xpText)
             (xpList pickle_item)
  where
    from_tuple = uncurryN WeatherDetailedWeatherListingXml


-- | (Un)pickle a 'WeatherDetailedWeatherXml'
--
pickle_detailed_weather :: PU WeatherDetailedWeatherXml
pickle_detailed_weather =
  xpElem "Detailed_Weather" $
    xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
    (xpList pickle_dw_listing)


-- | Pickler to convert a 'Message' to/from XML.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, H.convert) $
      xp8Tuple
        (xpElem "XML_File_ID" xpInt)
        (xpElem "heading" xpText)
        (xpElem "category" xpText)
        (xpElem "sport" xpText)
        (xpElem "title" xpText)
        (xpList pickle_forecast)
        (xpOption pickle_detailed_weather)
        (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message


--
-- * Tasty tests
--
weather_tests :: TestTree
weather_tests =
  testGroup
    "Weather tests"
    [ test_on_delete_cascade,
      test_pickle_of_unpickle_is_identity,
      test_unpickle_succeeds,
      test_types_detected_correctly,
      test_normal_teams_detected_correctly ]


-- | If we unpickle something and then pickle it, we should wind up
--   with the same thing we started with. WARNING: success of this
--   test does not mean that unpickling succeeded.
--
test_pickle_of_unpickle_is_identity :: TestTree
test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
  [ check "pickle composed with unpickle is the identity"
          "test/xml/weatherxml.xml",

    check "pickle composed with unpickle is the identity (detailed)"
          "test/xml/weatherxml-detailed.xml" ]
  where
    check desc path = testCase desc $ do
      (expected, actual) <- pickle_unpickle pickle_message path
      actual @?= expected


-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds = testGroup "unpickle tests"
  [ check "unpickling succeeds"
          "test/xml/weatherxml.xml",
    check "unpickling succeeds (detailed)"
          "test/xml/weatherxml-detailed.xml",
    check "unpickling succeeds (empty weather)"
          "test/xml/weatherxml-empty-weather.xml"]
  where
    check desc path = testCase desc $ do
      actual <- unpickleable path pickle_message
      let expected = True
      actual @?= expected


-- | Make sure everything gets deleted when we delete the top-level
--   record.
--
test_on_delete_cascade :: TestTree
test_on_delete_cascade = testGroup "cascading delete tests"
  [ check "deleting weather deletes its children"
          "test/xml/weatherxml.xml",
    check "deleting weather deletes its children (detailed)"
          "test/xml/weatherxml-detailed.xml",
    check "deleting weather deletes its children (empty weather)"
          "test/xml/weatherxml-empty-weather.xml"]
  where
    check desc path = testCase desc $ do
      weather <- unsafe_unpickle path pickle_message
      let a = undefined :: Weather
      let b = undefined :: WeatherForecast
      let c = undefined :: WeatherForecastListing
      let d = undefined :: WeatherDetailedWeatherListingItem
      actual <- withSqliteConn ":memory:" $ runDbConn $ do
                  runMigrationSilent $ do
                    migrate a
                    migrate b
                    migrate c
                    migrate d
                  _ <- dbimport weather
                  deleteAll a
                  count_a <- countAll a
                  count_b <- countAll b
                  count_c <- countAll c
                  count_d <- countAll d
                  return $ count_a + count_b + count_c + count_d
      let expected = 0
      actual @?= expected


-- | We want to make sure type1 documents are detected as type1, and
--   type2 documents detected as type2..
--
test_types_detected_correctly :: TestTree
test_types_detected_correctly =
  testGroup "weatherxml types detected correctly"
    [ check "test/xml/weatherxml.xml"
            "first type detected correctly"
            True,
      check "test/xml/weatherxml-detailed.xml"
            "first type detected correctly (detailed)"
            True,
      check "test/xml/weatherxml-empty-weather.xml"
            "first type detected correctly (empty weather)"
            True,
      check "test/xml/weatherxml-type2.xml"
            "second type detected correctly"
            False ]
  where
    check path desc expected = testCase desc $ do
      xmltree <- unsafe_read_invalid_document path
      let actual = is_type1 xmltree
      actual @?= expected


-- | We want to make sure normal teams are detected as normal, and the
--   backwards ones are flagged as backwards.
--
test_normal_teams_detected_correctly :: TestTree
test_normal_teams_detected_correctly =
  testGroup "team order is detected correctly" [

    check "normal teams are detected correctly"
          "test/xml/weatherxml.xml"
          True,

    check "backwards teams are detected correctly"
          "test/xml/weatherxml-backwards-teams.xml"
          False ]
  where
    check desc path expected = testCase desc $ do
      xmltree <- unsafe_read_invalid_document path
      let actual = teams_are_normal xmltree
      actual @?= expected