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

-- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
--   root element \<message\> that contains an entire news item.
--
module TSN.News (
  Message,
  news_tests )
where

import Control.Monad.IO.Class ( MonadIO, liftIO )
import Data.Int ( Int64 )
import Data.List.Utils ( join, split )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
  defaultMigrationLogger,
  insert,
  migrate,
  runMigration )
import Database.Groundhog.Core ( DefaultKey, PersistBackend )
import Database.Groundhog.TH (
  defaultCodegenConfig,
  groundhog,
  mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  XmlPickler(..),
  XmlTree,
  unpickleDoc,
  xp12Tuple,
  xpAttr,
  xpElem,
  xpList,
  xpPair,
  xpPrim,
  xpText,
  xpText0,
  xpTriple,
  xpWrap )
import Unsafe.Coerce ( unsafeCoerce )

import Network.Services.TSN.Report ( report_error )
import TSN.DbImport ( DbImport(..) )
import Xml ( pickle_unpickle )


-- Can't use a newtype with Groundhog.
data NewsTeam =
  NewsTeam {
    nt_news_id :: Int64, -- Foreign key.
    team_name  :: String }
deriving instance Eq NewsTeam
deriving instance Show NewsTeam

data MsgId =
  MsgId {
    msg_id       :: Int,
    event_id     :: String } -- TODO: make optional
  deriving (Eq, Show)

data NewsLocation =
  NewsLocation {
    loc_news_id  :: Int64, -- Foreign key.
    city :: String,
    state :: String,
    country :: String }
deriving instance Eq NewsLocation
deriving instance Show NewsLocation

data Message =
  Message {
    xml_file_id :: Int,
    heading :: String,
    mid :: MsgId,
    category :: String,
    sport :: String,
    url :: String,
    teams :: [NewsTeam],
    locations :: [NewsLocation],
    sms :: String,
    text :: String,
    continue :: String,
    time_stamp :: String }
  deriving (Eq, Show)


mkPersist defaultCodegenConfig [groundhog|
- entity: NewsTeam
  dbName: news_teams
  constructors:
    - name: NewsTeam
      fields:
        - name: nt_news_id
          reference:
            - table: news
            - columns: [id]

- entity: NewsLocation
  dbName: news_locations

- entity: Message
  dbName: news
  constructors:
    - name: Message
      fields:
        - name: mid
          embeddedType:
            - {name: msg_id, dbName: msg_id}
            - {name: event_id, dbName: event_id}

- embedded: MsgId
  fields:
    - name: msg_id
    - name: event_id
|]


pickle_news_team :: PU NewsTeam
pickle_news_team =
  xpElem "team" $
    xpWrap (from_string, to_string) xpText
  where
    to_string :: NewsTeam -> String
    to_string = team_name

    from_string :: String -> NewsTeam
    from_string = NewsTeam 0

instance XmlPickler NewsTeam where
  xpickle = pickle_news_team

pickle_msg_id :: PU MsgId
pickle_msg_id =
  xpElem "msg_id" $
    xpWrap (from_tuple, to_tuple) $
    xpPair xpPrim (xpAttr "EventId" xpText0)
  where
    from_tuple = uncurryN MsgId
    to_tuple m = (msg_id m, event_id m)

instance XmlPickler MsgId where
  xpickle = pickle_msg_id

pickle_location :: PU NewsLocation
pickle_location =
  xpElem "location" $
    xpWrap (from_tuple, to_tuple) $
    xpTriple (xpElem "city" xpText)
             (xpElem "state" xpText)
             (xpElem "country" xpText)
  where
    from_tuple =
      uncurryN (NewsLocation 0)
    to_tuple l = (city l, state l, country l) -- Don't pickle the PK

instance XmlPickler NewsLocation where
  xpickle = pickle_location


pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, to_tuple) $
    xp12Tuple (xpElem "XML_File_ID" xpPrim)
              (xpElem "heading" xpText)
              pickle_msg_id
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
              (xpElem "url" xpText)
              (xpList $ pickle_news_team)
              (xpList $ pickle_location)
              (xpElem "SMS" xpText)
              (xpElem "text" xpText)
              pickle_continue
              (xpElem "time_stamp" xpText)
  where
    from_tuple = uncurryN Message
    to_tuple m = (xml_file_id m,
                  heading m,
                  mid m,
                  category m,
                  sport m,
                  url m,
                  teams m,
                  locations m,
                  sms m,
                  text m,
                  continue m,
                  time_stamp m)

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

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

instance XmlPickler Message where
  xpickle = pickle_message



instance DbImport Message where
  dbimport _ xml = do
    runMigration defaultMigrationLogger $ do
      migrate (undefined :: Message)
      migrate (undefined :: NewsTeam)
      migrate (undefined :: NewsLocation)
    let root_element = unpickleDoc xpickle xml
    case root_element of
      Nothing -> do
        let errmsg = "Could not unpickle document in import_news."
        liftIO $ report_error errmsg
        return Nothing
      Just message  -> do
        news_id <- insert message

        let insert_news_team nt = insert (nt { nt_news_id = unsafeCoerce news_id })
        nt_ids <- mapM insert_news_team (teams message)

        let insert_news_location loc = insert (loc { loc_news_id = unsafeCoerce news_id })
        loc_ids <- mapM insert_news_location (locations message)

        return $ Just (1 + (length nt_ids) + (length loc_ids))


-- * Tasty Tests
news_tests :: TestTree
news_tests =
  testGroup
    "News tests"
    [ test_pickle_of_unpickle_is_identity ]


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