{-# 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
  Weather_WeatherForecastConstructor(..),
  WeatherConstructor(..),
  WeatherForecast_WeatherForecastListingConstructor(..),
  WeatherForecastConstructor(..),
  WeatherForecastListingConstructor(..) )
where

-- System imports.
import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
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(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_gamedate )
import TSN.XmlImport ( XmlImport(..) )
import Xml ( FromXml(..), pickle_unpickle, unpickleable )


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

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

instance XmlImport WeatherForecastListing


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

data WeatherForecast =
  WeatherForecast {
    db_game_date :: UTCTime,
    db_league_name :: Maybe String }

data WeatherForecastXml =
  WeatherForecastXml {
    xml_game_date :: UTCTime,
    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


data Weather_WeatherForecast =
  Weather_WeatherForecast
    (DefaultKey Weather)
    (DefaultKey WeatherForecast)

data WeatherForecast_WeatherForecastListing =
  WeatherForecast_WeatherForecastListing
    (DefaultKey WeatherForecast)
    (DefaultKey WeatherForecastListing)

mkPersist tsn_codegen_config [groundhog|
- entity: Weather

- entity: WeatherForecast
  dbName: weather_forecasts

- entity: WeatherForecastListing
  dbName: weather_forecast_listings

- entity: Weather_WeatherForecast
  dbName: weather__weather_forecasts
  constructors:
    - name: Weather_WeatherForecast
      fields:
        - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
          dbName: weather_id
        - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
          dbName: weather_forecasts_id

- entity: WeatherForecast_WeatherForecastListing
  dbName: weather_forecasts__weather_forecast_listings
  constructors:
    - name: WeatherForecast_WeatherForecastListing
      fields:
        # Default by mkNormalFieldName
        - name: weatherForecast_WeatherForecastListing0
          dbName: weather_forecasts_id

         # Default by mkNormalFieldName
        - name: weatherForecast_WeatherForecastListing1
          dbName: weather_forecast_listings_id
|]


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

  dbimport m = do
    weather_id <- insert_xml m

    forM_ (xml_forecasts m) $ \forecast -> do
      forecast_id <- insert_xml forecast
      insert_ (Weather_WeatherForecast weather_id forecast_id)
      forM_ (listings $ xml_league forecast) $ \listing -> do
        listing_id <- insert_xml listing
        insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id

    return ImportSucceeded


pickle_listing :: PU WeatherForecastListing
pickle_listing =
  xpElem "listing" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpElem "teams" xpText)
        (xpElem "weather" xpText)
  where
    from_pair = uncurry WeatherForecastListing
    to_pair WeatherForecastListing{..} = (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" xp_gamedate)
        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