{-# 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,
  pickle_message,
  -- * 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 Database.Groundhog (
  countAll,
  deleteAll,
  insert_,
  migrate,
  runMigration,
  silentMigrationLogger )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.Generic ( runDbConn )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  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_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 :: String }
  deriving (Eq, Show)


-- | 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 :: 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, Show)


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
  --   just copy everything verbatim.
  --
  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 {
    xml_dtl_listing_sport :: String,
    xml_dtl_listing_sport_code :: String,
    xml_items :: [WeatherDetailedWeatherListingItemXml] }
  deriving (Eq, Show)

-- * 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'.
--
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 :: String,
    db_temp_adjust :: String,
    db_temperature :: Int }


-- | 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.
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 :: String,
    xml_temp_adjust :: String,
    xml_temperature :: Int }
  deriving (Eq, Show)


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 fk WeatherDetailedWeatherListingItemXml{..} =
    WeatherDetailedWeatherListingItem {
      db_dtl_weather_id = fk,
      db_sport_code = xml_sport_code,
      db_game_id = xml_game_id,
      db_dtl_game_date = xml_dtl_game_date,
      db_away_team = xml_away_team,
      db_home_team = xml_home_team,
      db_weather_type = xml_weather_type,
      db_description = xml_description,
      db_temp_adjust = xml_temp_adjust,
      db_temperature = xml_temperature }

-- | 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, Show)

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

|]


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

    return ImportSucceeded


--
-- * Pickling
--

-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
--
pickle_listing :: PU WeatherForecastListingXml
pickle_listing =
  xpElem "listing" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpElem "teams" xpText)
        (xpElem "weather" xpText)
  where
    from_pair = uncurry WeatherForecastListingXml
    to_pair WeatherForecastListingXml{..} = (xml_teams, xml_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)
        (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, to_tuple) $
    xp9Tuple (xpElem "Sportcode" xpText)
             (xpElem "GameID" xpInt)
             (xpElem "Gamedate" xp_datetime)
             (xpElem "AwayTeam" xpText)
             (xpElem "HomeTeam" xpText)
             (xpElem "WeatherType" xpInt)
             (xpElem "Description" xpText)
             (xpElem "TempAdjust" xpText)
             (xpElem "Temperature" xpInt)
  where
    from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
    to_tuple w = (xml_sport_code w,
                  xml_game_id w,
                  xml_dtl_game_date w,
                  xml_away_team w,
                  xml_home_team w,
                  xml_weather_type w,
                  xml_description w,
                  xml_temp_adjust w,
                  xml_temperature w)


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


-- | (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, to_tuple) $
      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
    to_tuple Message{..} = (xml_xml_file_id,
                            xml_heading,
                            xml_category,
                            xml_sport,
                            xml_title,
                            xml_forecasts,
                            xml_detailed_weather,
                            xml_time_stamp)


--
-- * Tasty tests
--
weather_tests :: TestTree
weather_tests =
  testGroup
    "Weather tests"
    [ test_on_delete_cascade,
      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 = 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" ]
  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" ]
  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
                  runMigration silentMigrationLogger $ 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