{-# 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 one league, and
--   that league contains a bunch of listings.
--
module TSN.XML.Weather (
  pickle_message,
  -- * Tests
  weather_tests,
  -- * WARNING: these are private but exported to silence warnings
  WeatherConstructor(..),
  WeatherForecastConstructor(..),
  WeatherListingConstructor(..) )
where

-- System imports.
import Data.Tuple.Curry ( uncurryN )
--import Database.Groundhog (
--  insert_,
--  migrate )
--import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  xp7Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpText,
  xpWrap )

-- Local imports.
import TSN.Codegen (
  tsn_codegen_config )
import TSN.DbImport ( DbImport(..) )
import TSN.XmlImport ( XmlImport(..) )
import Xml ( FromXml(..), pickle_unpickle, unpickleable )


data WeatherListing =
  WeatherListing {
    db_teams :: String,
    db_weather :: String }
  deriving (Eq, Show)

instance FromXml WeatherListing where
  type Db WeatherListing = WeatherListing
  from_xml = id

instance XmlImport WeatherListing


data WeatherLeague =
  WeatherLeague {
    league_name     :: Maybe String,
    listings :: [WeatherListing] }
  deriving (Eq, Show)

data WeatherForecast =
  WeatherForecast {
    db_game_date :: String, -- ^ This is a 'String' instead of 'UTCTime'
                            --   because they don't use a standard
                            --   time format for the day of the month.
    db_league_name :: Maybe String }

data WeatherForecastXml =
  WeatherForecastXml {
    xml_game_date :: String,  -- ^ This is a 'String' instead of 'UTCTime'
                              --   because they don't use a standard
                              --   time format for the day of the month.
    xml_league :: WeatherLeague }
  deriving (Eq, Show)


instance FromXml WeatherForecastXml where
  type Db WeatherForecastXml = WeatherForecast
  from_xml WeatherForecastXml{..} =
    WeatherForecast { db_game_date   = xml_game_date,
                      db_league_name = (league_name xml_league) }

instance XmlImport WeatherForecastXml


data Weather =
  Weather {
    db_sport :: String,
    db_title :: String }

data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_forecasts :: [WeatherForecastXml],
    xml_time_stamp :: String }
  deriving (Eq, Show)

instance FromXml Message where
  type Db Message = Weather
  from_xml Message{..} =
    Weather {
      db_sport = xml_sport,
      db_title = xml_title }

instance XmlImport Message


mkPersist tsn_codegen_config [groundhog|
- entity: Weather

- entity: WeatherListing
  dbName: weather_listings

- entity: WeatherForecast
  dbName: weather_forecasts

|]


instance DbImport Message where
  dbmigrate = undefined
  dbimport  = undefined


pickle_listing :: PU WeatherListing
pickle_listing =
  xpElem "listing" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpElem "teams" xpText)
        (xpElem "weather" xpText)
  where
    from_pair = uncurry WeatherListing
    to_pair WeatherListing{..} = (db_teams, db_weather)

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)

pickle_forecast :: PU WeatherForecastXml
pickle_forecast =
  xpElem "forecast" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpAttr "gamedate" xpText)
        pickle_league
  where
    from_pair = uncurry WeatherForecastXml
    to_pair WeatherForecastXml{..} = (xml_game_date,
                                      xml_league)

pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, to_tuple) $
      xp7Tuple
        (xpElem "XML_File_ID" xpInt)
        (xpElem "heading" xpText)
        (xpElem "category" xpText)
        (xpElem "sport" xpText)
        (xpElem "title" xpText)
        (xpList pickle_forecast)
        (xpElem "time_stamp" xpText)
  where
    from_tuple = uncurryN Message
    to_tuple Message{..} = (xml_xml_file_id,
                            xml_heading,
                            xml_category,
                            xml_sport,
                            xml_title,
                            xml_forecasts,
                            xml_time_stamp)

--
-- Tasty tests
--

weather_tests :: TestTree
weather_tests =
  testGroup
    "Weather tests"
    [ test_pickle_of_unpickle_is_identity,
      test_unpickle_succeeds ]


-- | 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 =
  testCase "pickle composed with unpickle is the identity" $ do
    let path = "test/xml/weatherxml.xml"
    (expected, actual) <- pickle_unpickle pickle_message path
    actual @?= expected


-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds =
  testCase "unpickling succeeds" $ do
  let path = "test/xml/weatherxml.xml"
  actual <- unpickleable path pickle_message
  let expected = True
  actual @?= expected