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

-- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
--   contains a root element \<message\> that in turn contains zero or
--   more \<listing\>s.
--
--   The listings will be mapped to a database table called "injuries"
--   automatically. The root message is not retained.
--
module TSN.XML.Injuries (
  Message,
  injuries_tests )
where

import Data.Data ( Data )
import Data.Typeable ( Typeable )
import Database.Groundhog (
  migrate )
import Database.Groundhog.TH (
  defaultCodegenConfig,
  groundhog,
  mkPersist )
import Data.Tuple.Curry ( uncurryN )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  XmlPickler(..),
  xp4Tuple,
  xp6Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpPrim,
  xpText,
  xpWrap )


import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.XmlImport ( XmlImport(..) )
import Xml ( FromXml(..), pickle_unpickle, unpickleable )

data InjuriesTeam =
  InjuriesTeam {
    team_name :: String,
    team_league :: Maybe String }
  deriving (Data, Eq, Show, Typeable)

data Listing =
  Listing {
    team :: InjuriesTeam,
    teamno :: Maybe Int,
    injuries :: String,
    updated :: Maybe Bool }
  deriving (Eq, Show)

instance FromXml Listing where
  type Db Listing = Listing
  from_xml = id

instance XmlImport Listing

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
  dbimport msg = mapM_ insert_xml (listings msg) >> return ImportSucceeded

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

mkPersist defaultCodegenConfig [groundhog|
- entity: Listing
  dbName: injuries
  constructors:
    - name: Listing
      fields:
        - name: team
          embeddedType:
            - {name: team_name, dbName: team_name}
            - {name: team_league, dbName: team_league}
- embedded: InjuriesTeam
  fields:
    - name: team_name
    - name: team_league
|]


pickle_injuries_team :: PU InjuriesTeam
pickle_injuries_team =
  xpElem "team" $
    xpWrap (from_tuple, to_tuple) $
    xpPair xpText (xpOption $ xpAttr "league" xpText)
  where
    from_tuple = uncurryN InjuriesTeam
    to_tuple m = (team_name m, team_league m)

instance XmlPickler InjuriesTeam where
  xpickle = pickle_injuries_team

pickle_listing :: PU Listing
pickle_listing =
  xpElem "listing" $
    xpWrap (from_tuple, to_tuple) $
    xp4Tuple pickle_injuries_team
             (xpOption $ xpElem "teamno" xpInt)
             (xpElem "injuries" xpText)
             (xpOption $ xpElem "updated" xpPrim)
  where
    from_tuple = uncurryN Listing
    to_tuple l = (team l, teamno l, injuries l, updated l)

instance XmlPickler Listing where
  xpickle = pickle_listing


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)

instance XmlPickler Message where
  xpickle = pickle_message



-- * Tasty Tests
injuries_tests :: TestTree
injuries_tests =
  testGroup
    "Injuries 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/injuriesxml.xml"
    (expected :: [Message], actual) <- pickle_unpickle "message" path
    actual @?= expected


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