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

module TSN.XML.EarlyLine (
  dtd,
  pickle_message,
  -- * Tests
  early_line_tests,
  -- * WARNING: these are private but exported to silence warnings
  EarlyLineConstructor(..),
  EarlyLineGameConstructor(..) )
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,
  xp4Tuple,
  xp7Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpText,
  xpTriple,
  xpWrap )

-- Local imports.
import TSN.Codegen ( tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers (
  xp_ambiguous_time,
  xp_early_line_date,
  xp_time_stamp )
import TSN.XmlImport ( XmlImport(..) )
import Xml (
  FromXml(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_unpickle )


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

--
-- DB/XML data types
--

-- * EarlyLine/Message

-- | Database representation of a 'Message'. It lacks the \<date\>
--   elements since they're really properties of the games that they
--   contain.
--
data EarlyLine =
  EarlyLine {
    db_xml_file_id :: Int,
    db_heading :: String,
    db_category :: String,
    db_sport :: String,
    db_title :: String,
    db_time_stamp :: UTCTime }
  deriving (Eq, Show)



-- | XML Representation of an 'EarlyLine'. It has the same
--   fields, but in addition contains the 'xml_dates'.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_dates :: [EarlyLineDateXml],
    xml_time_stamp :: UTCTime }
  deriving (Eq, Show)


instance ToDb Message where
  -- | The database analogue of a 'Message' is an 'EarlyLine'.
  --
  type Db Message = EarlyLine


-- | The 'FromXml' instance for 'Message' is required for the
--   'XmlImport' instance.
--
instance FromXml Message where
  -- | To convert a 'Message' to an 'EarlyLine', we just drop
  --   the 'xml_dates'.
  --
  from_xml Message{..} =
    EarlyLine {
      db_xml_file_id = xml_xml_file_id,
      db_heading = xml_heading,
      db_category = xml_category,
      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



-- * EarlyLineDateXml

-- | XML representation of a \<date\>. It has a \"value\" attribute
--   containing the actual date string. As children it contains a
--   (non-optional) note, and a game. The note and date value are
--   properties of the game as far as I can tell.
--
data EarlyLineDateXml =
  EarlyLineDateXml {
    xml_date_value :: UTCTime,
    xml_note :: String,
    xml_game :: EarlyLineGameXml }
  deriving (Eq, Show)



-- * EarlyLineGame / EarlyLineGameXml

data EarlyLineGame =
  EarlyLineGame {
    db_early_lines_id :: DefaultKey EarlyLine,
    db_game_time :: UTCTime, -- ^ Combined date/time
    db_note :: String, -- ^ Taken from the parent \<date\>
    db_away_team :: EarlyLineGameTeam,
    db_home_team :: EarlyLineGameTeam,
    db_over_under :: String }

data EarlyLineGameXml =
  EarlyLineGameXml {
    xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
    xml_away_team :: EarlyLineGameTeam,
    xml_home_team :: EarlyLineGameTeam,
    xml_over_under :: String }
  deriving (Eq, Show)


-- | XML representation of an earlyline team. It doubles as an
--   embedded type within the DB representation 'EarlyLineGame'.
--
data EarlyLineGameTeam =
  EarlyLineGameTeam {
    db_rotation_number :: Int,
    db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
    db_team_name :: String }
  deriving (Eq, Show)


date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDateXml -> EarlyLineGame
date_to_game fk date =
  EarlyLineGame {
    db_early_lines_id = fk,
    db_game_time = combined_date_time,
    db_note = (xml_note date),
    db_away_team = xml_away_team (xml_game date),
    db_home_team = xml_home_team (xml_game date),
    db_over_under = xml_over_under (xml_game date) }
  where
    date_part = xml_date_value date
    time_part = xml_game_time (xml_game date)
    combined_date_time = UTCTime (utctDay date_part) (utctDayTime time_part)

--
-- * Database stuff
--

instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: EarlyLine)
      migrate (undefined :: EarlyLineGame)

  dbimport m = do
    -- Insert the message and obtain its ID.
    msg_id <- insert_xml m

    -- Now loop through the message's <date>s.
    forM_ (xml_dates m) $ \date -> do
      -- Each date only contains one game, so we convert the date to a
      -- game and then insert the game (keyed to the message).
      let game = date_to_game msg_id date
      insert_ game

    return ImportSucceeded


mkPersist tsn_codegen_config [groundhog|

- entity: EarlyLine
  dbName: early_lines
  constructors:
    - name: EarlyLine
      uniques:
        - name: unique_early_lines
          type: constraint
          # Prevent multiple imports of the same message.
          fields: [db_xml_file_id]


- entity: EarlyLineGame
  dbName: early_lines_games
  constructors:
    - name: EarlyLineGame
      fields:
        - name: db_early_lines_id
          reference:
            onDelete: cascade
        - name: db_away_team
          embeddedType:
            - {name: rotation_number, dbName: away_team_rotation_number}
            - {name: line, dbName: away_team_line}
            - {name: team_name, dbName: away_team_name}
        - name: db_home_team
          embeddedType:
            - {name: rotation_number, dbName: home_team_rotation_number}
            - {name: line, dbName: home_team_line}
            - {name: team_name, dbName: home_team_name}

- embedded: EarlyLineGameTeam
  fields:
    - name: db_rotation_number
      dbName: rotation_number
    - name: db_line
      dbName: line
    - name: db_team_name
      dbName: team_name

|]



--
-- * Pickling
--
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_date)
             (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message
    to_tuple m = (xml_xml_file_id m,
                  xml_heading m,
                  xml_category m,
                  xml_sport m,
                  xml_title m,
                  xml_dates m,
                  xml_time_stamp m)

pickle_date :: PU EarlyLineDateXml
pickle_date =
  xpElem "date" $
    xpWrap (from_tuple, to_tuple) $
    xpTriple (xpAttr "value" xp_early_line_date)
             (xpElem "note" xpText)
             pickle_game
  where
    from_tuple = uncurryN EarlyLineDateXml
    to_tuple m = (xml_date_value m, xml_note m, xml_game m)


pickle_game :: PU EarlyLineGameXml
pickle_game =
  xpElem "game" $
    xpWrap (from_tuple, to_tuple) $
    xp4Tuple (xpElem "time" xp_ambiguous_time)
             pickle_away_team
             pickle_home_team
             (xpElem "over_under" xpText)
  where
    from_tuple = uncurryN EarlyLineGameXml
    to_tuple m = (xml_game_time m,
                  xml_away_team m,
                  xml_home_team m,
                  xml_over_under m)



pickle_away_team :: PU EarlyLineGameTeam
pickle_away_team = xpElem "teamA" pickle_team

pickle_home_team :: PU EarlyLineGameTeam
pickle_home_team = xpElem "teamH" pickle_team

pickle_team :: PU EarlyLineGameTeam
pickle_team =
  xpWrap (from_tuple, to_tuple) $
  xpTriple (xpAttr "rotation" xpInt)
           (xpAttr "line" (xpOption xpText))
           xpText
  where
    from_tuple = uncurryN EarlyLineGameTeam
    to_tuple m = (db_rotation_number m, db_line m, db_team_name m)



--
-- * Tasty Tests
--

-- | A list of all tests for this module.
--
early_line_tests :: TestTree
early_line_tests =
  testGroup
    "EarlyLine 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 =
  testCase "pickle composed with unpickle is the identity" $ do
    let path = "test/xml/earlylineXML.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/earlylineXML.xml"
    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 =
  testCase "deleting early_lines deletes its children" $ do
    let path = "test/xml/earlylineXML.xml"
    results <- unsafe_unpickle path pickle_message
    let a = undefined :: EarlyLine
    let b = undefined :: EarlyLineGame

    actual <- withSqliteConn ":memory:" $ runDbConn $ do
                runMigration silentMigrationLogger $ do
                  migrate a
                  migrate b
                _ <- dbimport results
                deleteAll a
                count_a <- countAll a
                count_b <- countAll b
                return $ sum [count_a, count_b]
    let expected = 0
    actual @?= expected