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

-- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
--   document contains a root element \<message\> that in turn
--   contains zero or more \<Listing\>s (note: capitalization). The
--   \<Listing\>s contain \<PlayerListing\>s then contain the real
--   meat; everything contained in the parent \<Listing\> can also be
--   found within the \<PlayerListing\>s.
--
--   The player listings will be mapped to a database table called
--   \"injuries_detail_player_listings\" automatically. The root
--   \"message\" and \"listing\" are not retained.
--
module TSN.XML.InjuriesDetail (
  pickle_message,
  -- * Tests
  injuries_detail_tests,
  -- * WARNING: these are private but exported to silence warnings
  PlayerListingConstructor(..) )
where

-- System imports.
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
  migrate )
import Database.Groundhog.TH (
  defaultCodegenConfig,
  groundhog,
  mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  xpTriple,
  xp6Tuple,
  xp10Tuple,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPrim,
  xpText,
  xpWrap )

-- Local imports.
import TSN.Picklers( xp_date )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.XmlImport ( XmlImport(..) )
import Xml ( FromXml(..), pickle_unpickle, unpickleable )


-- | Database representation of a \<PlayerListing\>, the main type of
--   element contains in Injuries_Detail_XML messages.
--
data PlayerListing =
  PlayerListing {
    team_id   :: String, -- ^ TeamIDs are (apparently) three
                         --   characters long and not necessarily
                         --   numeric. Postgres imposes no performance
                         --   penalty on a lengthless text field,
                         --   so we ignore the likely upper bound of
                         --   three characters.
    player_id :: Int,
    date      :: UTCTime,
    pos       :: String,
    name      :: String,
    injury    :: String,
    status    :: String,
    fantasy   :: Maybe String, -- ^ Nobody knows what this is.
    injured     :: Bool,
    injury_type :: String -- ^ "type" is a reserved keyword so we can't use it
    }
  deriving (Eq, Show)


instance FromXml PlayerListing where
  -- | The DB analogue of a 'PlayerListing' is... itself!
  type Db PlayerListing = PlayerListing

  -- | To convert between a 'PlayerListing' and a 'PlayerListing',
  --   we do nothing.
  from_xml = id

-- | This lets us call 'insert_xml' on a 'PlayerListing' without
--   having to explicitly convert it to its database analogue first.
--
instance XmlImport PlayerListing


-- | XML incarnation of a \<Listing\> element. We don't store these;
--   the data type is used only for parsing.
--
data Listing =
  Listing {
    listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id.
                              --   TeamIDs are (apparently) three characters
                              --   long and not necessarily numeric.
    , full_name :: String, -- ^ Team full name
    player_listings :: [PlayerListing] }
  deriving (Eq, Show)


-- | XML representation of the top-level \<message\> element. These
--   are not stored; the data type is used only for parsing.
--
data Message =
  Message {
    xml_file_id :: Int,
    heading :: String,
    category :: String,
    sport :: String,
    listings :: [Listing],
    time_stamp :: String }
  deriving (Eq, Show)

instance DbImport Message where
  -- | To import a 'Message', we import all of its 'PlayerListing's,
  --   which we have to dig out of its 'Listing's.
  dbimport msg = do
    mapM_ insert_xml (concatMap player_listings $ listings msg)
    return ImportSucceeded

  dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing)


mkPersist defaultCodegenConfig [groundhog|
- entity: PlayerListing
  dbName: injuries_detail_player_listings
|]


-- | Convert 'PlayerListing's to/from XML.
--
pickle_player_listing :: PU PlayerListing
pickle_player_listing =
  xpElem "PlayerListing" $
    xpWrap (from_tuple, to_tuple) $
    xp10Tuple (xpElem "TeamID" xpText)
              (xpElem "PlayerID" xpInt)
              (xpElem "Date" xp_date)
              (xpElem "Pos" xpText)
              (xpElem "Name" xpText)
              (xpElem "Injury" xpText)
              (xpElem "Status" xpText)
              (xpElem "Fantasy" $ xpOption xpText)
              (xpElem "Injured" xpPrim)
              (xpElem "Type" xpText)
  where
    from_tuple = uncurryN PlayerListing
    to_tuple pl = (team_id pl,
                   player_id pl,
                   date pl,
                   pos pl,
                   name pl,
                   injury pl,
                   status pl,
                   fantasy pl,
                   injured pl,
                   injury_type pl)


-- | Convert 'Listing's to/from XML.
--
pickle_listing :: PU Listing
pickle_listing =
  xpElem "Listing" $
    xpWrap (from_tuple, to_tuple) $
    xpTriple (xpElem "TeamID" xpText)
             (xpElem "FullName" xpText)
             (xpList pickle_player_listing)
  where
    from_tuple = uncurryN Listing
    to_tuple l = (listing_team_id l, full_name l, player_listings l)


-- | Convert 'Message's to/from XML.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, to_tuple) $
    xp6Tuple (xpElem "XML_File_ID" xpInt)
             (xpElem "heading" xpText)
             (xpElem "category" xpText)
             (xpElem "sport" xpText)
             (xpList pickle_listing)
             (xpElem "time_stamp" xpText)
  where
    from_tuple = uncurryN Message
    to_tuple m = (xml_file_id m,
                  heading m,
                  category m,
                  sport m,
                  listings m,
                  time_stamp m)


--
-- Tasty Tests
--

-- | A list of all tests for this module.
--
injuries_detail_tests :: TestTree
injuries_detail_tests =
  testGroup
    "InjuriesDetail 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 = testGroup "pickle-unpickle tests"
  [ check "pickle composed with unpickle is the identity"
          "test/xml/Injuries_Detail_XML.xml",

    check "pickle composed with unpickle is the identity (non-int team_id)"
          "test/xml/Injuries_Detail_XML-noninteger-team-id.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/Injuries_Detail_XML.xml",

    check "unpickling succeeds (non-int team_id)"
          "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
  where
    check desc path = testCase desc $ do
      actual <- unpickleable path pickle_message
      let expected = True
      actual @?= expected