{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module TSN.XML.Odds (
  Message,
  odds_tests )
where


-- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
--   a root element \<message\> that contains a bunch of other
--   unorganized crap.
--

import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
import Data.List.Utils ( join, split )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
import Database.Groundhog (
  defaultMigrationLogger,
  insert,
  migrate,
  runMigration )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import System.Console.CmdArgs.Default ( Default(..) )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  XmlPickler(..),
  unpickleDoc,
  xp5Tuple,
  xp6Tuple,
  xp11Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpPrim,
  xpText,
  xpText0,
  xpTriple,
  xpWrap )

import TSN.Codegen (
  tsn_codegen_config,
  tsn_db_field_namer )
import TSN.DbImport ( DbImport(..), ImportResult(..) )
import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )



data OddsCasino =
  OddsCasino {
    xml_casino_client_id :: Int,
    xml_casino_name      :: String,
    xml_casino_line      :: Maybe Float }
  deriving (Eq, Show)

data OddsHomeTeam =
  OddsHomeTeam {
    xml_home_team_id         :: Int,
    xml_home_rotation_number :: Int,
    xml_home_abbr            :: String,
    xml_home_team_name       :: String,
    xml_home_casinos         :: [OddsCasino] }
  deriving (Eq, Show)

data OddsAwayTeam =
  OddsAwayTeam {
    xml_away_team_id         :: Int,
    xml_away_rotation_number :: Int,
    xml_away_abbr            :: String,
    xml_away_team_name       :: String,
    xml_away_casinos         :: [OddsCasino] }
  deriving (Eq, Show)

-- | Can't use a newtype with Groundhog.
data OddsOverUnder =
  OddsOverUnder [OddsCasino]
  deriving (Eq, Show)

data OddsGame =
  OddsGame {
    xml_game_id         :: Int,
    xml_game_date       :: String, -- TODO
    xml_game_time       :: String, -- TODO
    xml_game_away_team  :: OddsAwayTeam,
    xml_game_home_team  :: OddsHomeTeam,
    xml_game_over_under :: OddsOverUnder }
  deriving (Eq, Show)

data Message =
  Message {
    db_sport :: String,
    db_title :: String,
    db_line_time :: String,
    db_notes1 :: String,
    db_notes2 :: String }

data MessageXml =
  MessageXml {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_line_time :: String, -- The DTD goes crazy here.
    xml_notes1 :: String,
    xml_games1 :: [OddsGame],
    xml_notes2 :: String,
    xml_games2 :: [OddsGame],
    xml_time_stamp :: String }
  deriving (Eq, Show)


instance ToFromXml Message where
  type Xml Message = MessageXml
  type Container Message = ()

  -- Use a record wildcard here so GHC doesn't complain that we never
  -- used our named fields.
  to_xml (Message {..}) =
    MessageXml
      def
      def
      def
      db_sport
      db_title
      db_line_time
      db_notes1
      def
      db_notes2
      def
      def

  -- We don't need the key argument (from_xml_fk) since the XML type
  -- contains more information in this case.
  from_xml (MessageXml _ _ _ d e f g _ i _ _) =
    Message d e f g i


pickle_casino :: PU OddsCasino
pickle_casino =
  xpElem "Casino" $
  xpWrap (from_tuple, to_tuple) $
  xpTriple
    (xpAttr "ClientID" xpInt)
    (xpAttr "Name" xpText)
    (xpOption xpPrim)
  where
    from_tuple = uncurryN OddsCasino
    to_tuple (OddsCasino x y z) = (x, y, z)

instance XmlPickler OddsCasino where
  xpickle = pickle_casino


pickle_home_team :: PU OddsHomeTeam
pickle_home_team =
  xpElem "HomeTeam" $
  xpWrap (from_tuple, to_tuple) $
  xp5Tuple
    (xpElem "HomeTeamID" xpPrim)
    (xpElem "HomeRotationNumber" xpPrim)
    (xpElem "HomeAbbr" xpText)
    (xpElem "HomeTeamName" xpText)
    (xpList pickle_casino)
  where
    from_tuple = uncurryN OddsHomeTeam
    to_tuple (OddsHomeTeam v w x y z) = (v, w, x, y, z)


instance XmlPickler OddsHomeTeam where
  xpickle = pickle_home_team


pickle_away_team :: PU OddsAwayTeam
pickle_away_team =
  xpElem "AwayTeam" $
  xpWrap (from_tuple, to_tuple) $
  xp5Tuple
    (xpElem "AwayTeamID" xpPrim)
    (xpElem "AwayRotationNumber" xpPrim)
    (xpElem "AwayAbbr" xpText)
    (xpElem "AwayTeamName" xpText)
    (xpList pickle_casino)
  where
    from_tuple = uncurryN OddsAwayTeam
    to_tuple (OddsAwayTeam v w x y z) = (v, w, x, y, z)


instance XmlPickler OddsAwayTeam where
  xpickle = pickle_away_team


pickle_over_under :: PU OddsOverUnder
pickle_over_under =
  xpElem "Over_Under" $
  xpWrap (to_newtype, from_newtype) $
    xpList pickle_casino
  where
    from_newtype (OddsOverUnder cs) = cs
    to_newtype = OddsOverUnder

instance XmlPickler OddsOverUnder where
  xpickle = pickle_over_under


pickle_game :: PU OddsGame
pickle_game =
  xpElem "Game" $
  xpWrap (from_tuple, to_tuple) $
  xp6Tuple
    (xpElem "GameID" xpPrim)
    (xpElem "Game_Date" xpText)
    (xpElem "Game_Time" xpText)
    pickle_away_team
    pickle_home_team
    pickle_over_under
  where
    from_tuple = uncurryN OddsGame
    to_tuple (OddsGame u v w x y z) = (u,v,w,x,y,z)

instance XmlPickler OddsGame where
  xpickle = pickle_game


pickle_message :: PU MessageXml
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, to_tuple) $
    xp11Tuple (xpElem "XML_File_ID" xpPrim)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
              (xpElem "Title" xpText)
              (xpElem "Line_Time" xpText)
              pickle_notes
              (xpList $ pickle_game)
              pickle_notes
              (xpList $ pickle_game)
              (xpElem "time_stamp" xpText)
  where
    from_tuple = uncurryN MessageXml
    to_tuple m = (xml_xml_file_id m,
                  xml_heading m,
                  xml_category m,
                  xml_sport m,
                  xml_title m,
                  xml_line_time m,
                  xml_notes1 m,
                  xml_games1 m,
                  xml_notes2 m,
                  xml_games2 m,
                  xml_time_stamp m)

    pickle_notes :: PU String
    pickle_notes =
      xpWrap (to_string, from_string) $
          (xpList $ xpElem "Notes" xpText)
      where
        from_string :: String -> [String]
        from_string = split "\n"

        to_string :: [String] -> String
        to_string = join "\n"

instance XmlPickler MessageXml where
  xpickle = pickle_message






-- * Tasty Tests
odds_tests :: TestTree
odds_tests =
  testGroup
    "Odds tests"
    [ test_pickle_of_unpickle_is_identity,
      test_unpickle_succeeds ]


-- | Warning, succeess 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/Odds_XML.xml"
    (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
    actual @?= expected


test_unpickle_succeeds :: TestTree
test_unpickle_succeeds =
  testCase "unpickling succeeds" $ do
  let path = "test/xml/Odds_XML.xml"
  actual <- unpickleable path pickle_message
  let expected = True
  actual @?= expected