-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.XmlState.ErrorHandling
   Copyright  : Copyright (C) 2010 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   the basic state arrows for XML processing

   A state is needed for global processing options,
   like encoding options, document base URI, trace levels
   and error message handling

   The state is separated into a user defined state
   and a system state. The system state contains variables
   for error message handling, for tracing, for the document base
   for accessing XML documents with relative references, e.g. DTDs,
   and a global key value store. This assoc list has strings as keys
   and lists of XmlTrees as values. It is used to store arbitrary
   XML and text values, e.g. user defined global options.

   The user defined part of the store is in the default case empty, defined as ().
   It can be extended with an arbitray data type

-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.XmlState.ErrorHandling
where

import Control.Arrow                            -- arrow classes
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowIO

import Control.Exception                ( SomeException )

import Data.Maybe

import Text.XML.HXT.DOM.Interface

import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState.TypeDefs

import System.IO                        ( hPutStrLn
                                        , hFlush
                                        , stderr
                                        )

-- ------------------------------------------------------------

changeErrorStatus       :: (Int -> Int -> Int) -> IOStateArrow s Int Int
changeErrorStatus f     = chgSysVar theErrorStatus f

-- | reset global error variable

clearErrStatus          :: IOStateArrow s b b
clearErrStatus          = configSysVar $ setS theErrorStatus 0

-- | set global error variable

setErrStatus            :: IOStateArrow s Int Int
setErrStatus            = changeErrorStatus max

-- | read current global error status

getErrStatus            :: IOStateArrow s XmlTree Int
getErrStatus            = getSysVar theErrorStatus

-- ------------------------------------------------------------

-- | raise the global error status level to that of the input tree

setErrMsgStatus         :: IOStateArrow s XmlTree XmlTree
setErrMsgStatus         = perform
                          ( getErrorLevel >>> setErrStatus )

-- | set the error message handler and the flag for collecting the errors

setErrorMsgHandler      :: Bool -> (String -> IO ()) -> IOStateArrow s b b
setErrorMsgHandler c f  = configSysVar $ setS (theErrorMsgCollect .&&&. theErrorMsgHandler) (c, f)

-- | error message handler for output to stderr

sysErrorMsg             :: IOStateArrow s XmlTree XmlTree
sysErrorMsg             = perform
                          ( getErrorLevel &&& getErrorMsg
                            >>>
                            arr formatErrorMsg
                            >>>
                            getSysVar theErrorMsgHandler &&& this
                            >>>
                            arrIO (\ (h, msg) -> h msg)
                          )
    where
    formatErrorMsg (level, msg) = "\n" ++ errClass level ++ ": " ++ msg
    errClass l          = fromMaybe "fatal error" . lookup l $ msgList
        where
        msgList         = [ (c_ok,      "no error")
                          , (c_warn,    "warning")
                          , (c_err,     "error")
                          , (c_fatal,   "fatal error")
                          ]


-- | the default error message handler: error output to stderr

errorMsgStderr          :: IOStateArrow s b b
errorMsgStderr          = setErrorMsgHandler False (\ x ->
                                                    do hPutStrLn stderr x
                                                       hFlush    stderr
                                                   )

-- | error message handler for collecting errors

errorMsgCollect         :: IOStateArrow s b b
errorMsgCollect         = setErrorMsgHandler True (const $ return ())

-- | error message handler for output to stderr and collecting

errorMsgStderrAndCollect        :: IOStateArrow s b b
errorMsgStderrAndCollect        = setErrorMsgHandler True (hPutStrLn stderr)

-- | error message handler for ignoring errors

errorMsgIgnore          :: IOStateArrow s b b
errorMsgIgnore          = setErrorMsgHandler False (const $ return ())

-- |
-- if error messages are collected by the error handler for
-- processing these messages by the calling application,
-- this arrow reads the stored messages and clears the error message store

getErrorMessages        :: IOStateArrow s b XmlTree
getErrorMessages        = getSysVar theErrorMsgList
                          >>>
                          configSysVar (setS theErrorMsgList [])
                          >>>
                          arrL reverse

addToErrorMsgList       :: IOStateArrow s XmlTree XmlTree
addToErrorMsgList       = chgSysVar
                          ( theErrorMsgCollect .&&&. theErrorMsgList )
                          ( \ e (cs, es) -> (cs, if cs then e : es else es) )

-- ------------------------------------------------------------

-- |
-- filter error messages from input trees and issue errors

filterErrorMsg          :: IOStateArrow s XmlTree XmlTree
filterErrorMsg          = ( setErrMsgStatus
                            >>>
                            sysErrorMsg
                            >>>
                            addToErrorMsgList
                            >>>
                            none
                          )
                          `when`
                          isError

-- | generate a warnig message

issueWarn               :: String -> IOStateArrow s b b
issueWarn msg           = perform (warn msg  >>> filterErrorMsg)

-- | generate an error message
issueErr                :: String -> IOStateArrow s b b
issueErr msg            = perform (err msg   >>> filterErrorMsg)

-- | generate a fatal error message, e.g. document not found

issueFatal              :: String -> IOStateArrow s b b
issueFatal msg          = perform (fatal msg >>> filterErrorMsg)

-- | Default exception handler: issue a fatal error message and fail.
--
-- The parameter can be used to specify where the error occured

issueExc                :: String -> IOStateArrow s SomeException b
issueExc m              = ( issueFatal $< arr  ((msg ++) . show) )
                          >>>
                          none
    where
    msg | null m        = "Exception: "
        | otherwise     = "Exception in " ++ m ++ ": "

-- |
-- add the error level and the module where the error occured
-- to the attributes of a document root node and remove the children when level is greater or equal to 'c_err'.
-- called by 'setDocumentStatusFromSystemState' when the system state indicates an error

setDocumentStatus       :: Int -> String -> IOStateArrow s XmlTree XmlTree
setDocumentStatus level msg
                        = ( addAttrl ( sattr a_status (show level)
                                       <+>
                                       sattr a_module msg
                                     )
                            >>>
                            ( if level >= c_err
                              then setChildren []
                              else this
                            )
                          )
                      `when`
                      isRoot

-- |
-- check whether the error level attribute in the system state
-- is set to error, in this case the children of the document root are
-- removed and the module name where the error occured and the error level are added as attributes with 'setDocumentStatus'
-- else nothing is changed

setDocumentStatusFromSystemState        :: String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState msg
                                = setStatus $< getErrStatus
    where
    setStatus level
        | level <= c_warn       = this
        | otherwise             = setDocumentStatus level msg


-- |
-- check whether tree is a document root and the status attribute has a value less than 'c_err'

documentStatusOk        :: ArrowXml a => a XmlTree XmlTree
documentStatusOk        = isRoot
                          >>>
                          ( (getAttrValue a_status
                             >>>
                             isA (\ v -> null v || ((read v)::Int) <= c_warn)
                            )
                            `guards`
                            this
                          )

-- ------------------------------------------------------------

errorOutputToStderr     :: String -> IO ()
errorOutputToStderr msg
                        = do
                          hPutStrLn stderr msg
                          hFlush stderr

-- ------------------------------------------------------------