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

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

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