{-# 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 Data.List.Utils ( join, split )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog()
import Database.Groundhog.TH
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  XmlPickler(..),
  xp12Tuple,
  xpAttr,
  xpElem,
  xpList,
  xpPair,
  xpPrim,
  xpText,
  xpText0,
  xpTriple,
  xpWrap )


import Xml ( pickle_unpickle )


-- Can't use a newtype with groundhog.
data NewsTeam =
  NewsTeam { team_name :: String }
  deriving (Eq, Show)

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

data NewsLocation =
  NewsLocation {
    city :: String,
    state :: String,
    country :: String }
  deriving (Eq, Show)

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

- 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

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
    to_tuple l = (city l, state l, country l)

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



-- * 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