{-# 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 )



-- | Database/XML representation of a weather forecast listing.
--
data WeatherForecastListing =
  WeatherForecastListing {
    db_teams :: String,
    db_weather :: String }
  deriving (Eq, Show)

-- | This is needed to define the XmlImport instance for
-- 'WeatherForecastListing'; it basically says that the DB
-- representation is the same as the XML representation.
--
instance FromXml WeatherForecastListing where
  type Db WeatherForecastListing = WeatherForecastListing
  from_xml = id

-- | Allows us to call 'insert_xml' on the XML representation of
--   WeatherForecastListing.
--
instance XmlImport WeatherForecastListing


-- | 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. Since there's exactly one league per
--   forecast, we just store the league_name in the database
--   representation of a forecast.
--
data WeatherLeague =
  WeatherLeague {
    league_name     :: Maybe String,
    listings :: [WeatherForecastListing] }
  deriving (Eq, Show)


-- | Database representation of a weather forecast.
--
data WeatherForecast =
  WeatherForecast {
    db_game_date :: UTCTime,
    db_league_name :: Maybe String }

-- | XML representation of a weather forecast. It would have been
--   cleaner to omit the 'WeatherLeague' middleman, but having it
--   simplifies parsing.
--
data WeatherForecastXml =
  WeatherForecastXml {
    xml_game_date :: UTCTime,
    xml_league :: WeatherLeague }
  deriving (Eq, Show)


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

  -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
  --   replace the 'WeatherLeague' with its name.
  --
  from_xml WeatherForecastXml{..} =
    WeatherForecast { db_game_date   = xml_game_date,
                      db_league_name = (league_name xml_league) }

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


-- | The database representation of a weather message.
--
data Weather =
  Weather {
    db_sport :: String,
    db_title :: String }


-- | 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_time_stamp :: String }
  deriving (Eq, Show)


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

  -- | To get a 'Weather' from a 'Message', we drop a bunch of
  --   unwanted fields.
  --
  from_xml Message{..} =
    Weather {
      db_sport = xml_sport,
      db_title = xml_title }

-- | This allows us to call 'insert_xml' on a 'Message' without first
--   converting it to the database representation.
--
instance XmlImport Message


-- | A mapping between 'Weather' objects and their children
--   'WeatherForecast's.
--
data Weather_WeatherForecast =
  Weather_WeatherForecast
    (DefaultKey Weather)
    (DefaultKey WeatherForecast)

-- | A mapping between 'WeatherForecast' objects and their children
--   'WeatherForecastListing's.
--
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
    -- The weather database schema has a nice linear structure. 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 forecast

      -- Map this forecast to its parent weather record.
      insert_ (Weather_WeatherForecast weather_id forecast_id)

      -- Insert all of this forecast's listings.
      forM_ (listings $ xml_league forecast) $ \listing -> do
        listing_id <- insert_xml listing

        -- Map this listing to its parent forecast.
        insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id

    return ImportSucceeded



-- | Pickler to convert a 'WeatherForecastListing' to/from XML.
--
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)


-- | 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)
        pickle_league
  where
    from_pair = uncurry WeatherForecastXml
    to_pair WeatherForecastXml{..} = (xml_game_date,
                                      xml_league)



-- | Pickler to convert a 'Message' to/from XML.
--
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