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

    {- |
       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 :: (Int -> Int -> Int) -> IOStateArrow s Int Int
    changeErrorStatus f :: Int -> Int -> Int
    f     = Selector XIOSysState Int
    -> (Int -> Int -> Int) -> IOStateArrow s Int Int
    forall c b s.
    Selector XIOSysState c -> (b -> c -> c) -> IOStateArrow s b b
    chgSysVar Selector XIOSysState Int
    theErrorStatus Int -> Int -> Int
    f

    -- | reset global error variable

    clearErrStatus          :: IOStateArrow s b b
    clearErrStatus :: IOStateArrow s b b
    clearErrStatus          = SysConfig -> IOStateArrow s b b
    forall s c. SysConfig -> IOStateArrow s c c
    configSysVar (SysConfig -> IOStateArrow s b b)
    -> SysConfig -> IOStateArrow s b b
    forall a b. (a -> b) -> a -> b
    $ Selector XIOSysState Int -> Int -> SysConfig
    forall s a. Selector s a -> a -> s -> s
    setS Selector XIOSysState Int
    theErrorStatus 0

    -- | set global error variable

    setErrStatus            :: IOStateArrow s Int Int
    setErrStatus :: IOStateArrow s Int Int
    setErrStatus            = (Int -> Int -> Int) -> IOStateArrow s Int Int
    forall s. (Int -> Int -> Int) -> IOStateArrow s Int Int
    changeErrorStatus Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max

    -- | read current global error status

    getErrStatus            :: IOStateArrow s XmlTree Int
    getErrStatus :: IOStateArrow s XmlTree Int
    getErrStatus            = Selector XIOSysState Int -> IOStateArrow s XmlTree Int
    forall c s b. Selector XIOSysState c -> IOStateArrow s b c
    getSysVar Selector XIOSysState Int
    theErrorStatus

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

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

    setErrMsgStatus         :: IOStateArrow s XmlTree XmlTree
    setErrMsgStatus :: IOStateArrow s XmlTree XmlTree
    setErrMsgStatus         = IOSLA (XIOState s) XmlTree Int -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
    perform
                              ( IOSLA (XIOState s) XmlTree Int
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
    getErrorLevel IOSLA (XIOState s) XmlTree Int
    -> IOSLA (XIOState s) Int Int -> IOSLA (XIOState s) XmlTree Int
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> IOSLA (XIOState s) Int Int
    forall s. IOStateArrow s Int Int
    setErrStatus )

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

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

    -- | error message handler for output to stderr

    sysErrorMsg             :: IOStateArrow s XmlTree XmlTree
    sysErrorMsg :: IOStateArrow s XmlTree XmlTree
    sysErrorMsg             = IOSLA (XIOState s) XmlTree () -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
    perform
                              ( IOSLA (XIOState s) XmlTree Int
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
    getErrorLevel IOSLA (XIOState s) XmlTree Int
    -> IOSLA (XIOState s) XmlTree String
    -> IOSLA (XIOState s) XmlTree (Int, String)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& IOSLA (XIOState s) XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getErrorMsg
                                IOSLA (XIOState s) XmlTree (Int, String)
    -> IOSLA (XIOState s) (Int, String) ()
    -> IOSLA (XIOState s) XmlTree ()
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                ((Int, String) -> String)
    -> IOSLA (XIOState s) (Int, String) String
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (Int, String) -> String
    formatErrorMsg
                                IOSLA (XIOState s) (Int, String) String
    -> IOSLA (XIOState s) String ()
    -> IOSLA (XIOState s) (Int, String) ()
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                Selector XIOSysState (String -> IO ())
    -> IOStateArrow s String (String -> IO ())
    forall c s b. Selector XIOSysState c -> IOStateArrow s b c
    getSysVar Selector XIOSysState (String -> IO ())
    theErrorMsgHandler IOStateArrow s String (String -> IO ())
    -> IOSLA (XIOState s) String String
    -> IOSLA (XIOState s) String (String -> IO (), String)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& IOSLA (XIOState s) String String
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
                                IOSLA (XIOState s) String (String -> IO (), String)
    -> IOSLA (XIOState s) (String -> IO (), String) ()
    -> IOSLA (XIOState s) String ()
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                ((String -> IO (), String) -> IO ())
    -> IOSLA (XIOState s) (String -> IO (), String) ()
    forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
    arrIO (\ (h :: String -> IO ()
    h, msg :: String
    msg) -> String -> IO ()
    h String
    msg)
                              )
        where
        formatErrorMsg :: (Int, String) -> String
    formatErrorMsg (level :: Int
    level, msg :: String
    msg) = "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    errClass Int
    level String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg
        errClass :: Int -> String
    errClass l :: Int
    l          = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe "fatal error" (Maybe String -> String)
    -> ([(Int, String)] -> Maybe String) -> [(Int, String)] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> [(Int, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Int
    l ([(Int, String)] -> String) -> [(Int, String)] -> String
    forall a b. (a -> b) -> a -> b
    $ [(Int, String)]
    msgList
            where
            msgList :: [(Int, String)]
    msgList         = [ (Int
    c_ok,      "no error")
                              , (Int
    c_warn,    "warning")
                              , (Int
    c_err,     "error")
                              , (Int
    c_fatal,   "fatal error")
                              ]

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

    errorMsgStderr          :: IOStateArrow s b b
    errorMsgStderr :: IOStateArrow s b b
    errorMsgStderr          = Bool -> (String -> IO ()) -> IOStateArrow s b b
    forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
    setErrorMsgHandler Bool
    False (\ x :: String
    x ->
                                                        do Handle -> String -> IO ()
    hPutStrLn Handle
    stderr String
    x
                                                           Handle -> IO ()
    hFlush    Handle
    stderr
                                                       )

    -- | error message handler for collecting errors

    errorMsgCollect         :: IOStateArrow s b b
    errorMsgCollect :: IOStateArrow s b b
    errorMsgCollect         = Bool -> (String -> IO ()) -> IOStateArrow s b b
    forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
    setErrorMsgHandler Bool
    True (IO () -> String -> IO ()
    forall a b. a -> b -> a
    const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

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

    errorMsgStderrAndCollect        :: IOStateArrow s b b
    errorMsgStderrAndCollect :: IOStateArrow s b b
    errorMsgStderrAndCollect        = Bool -> (String -> IO ()) -> IOStateArrow s b b
    forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
    setErrorMsgHandler Bool
    True (Handle -> String -> IO ()
    hPutStrLn Handle
    stderr)

    -- | error message handler for ignoring errors

    errorMsgIgnore          :: IOStateArrow s b b
    errorMsgIgnore :: IOStateArrow s b b
    errorMsgIgnore          = Bool -> (String -> IO ()) -> IOStateArrow s b b
    forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
    setErrorMsgHandler Bool
    False (IO () -> String -> IO ()
    forall a b. a -> b -> a
    const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    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 :: IOStateArrow s b XmlTree
    getErrorMessages        = Selector XIOSysState XmlTrees -> IOStateArrow s b XmlTrees
    forall c s b. Selector XIOSysState c -> IOStateArrow s b c
    getSysVar Selector XIOSysState XmlTrees
    theErrorMsgList
                              IOStateArrow s b XmlTrees
    -> IOSLA (XIOState s) XmlTrees XmlTree -> IOStateArrow s b XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                              SysConfig -> IOStateArrow s XmlTrees XmlTrees
    forall s c. SysConfig -> IOStateArrow s c c
    configSysVar (Selector XIOSysState XmlTrees -> XmlTrees -> SysConfig
    forall s a. Selector s a -> a -> s -> s
    setS Selector XIOSysState XmlTrees
    theErrorMsgList [])
                              IOStateArrow s XmlTrees XmlTrees
    -> IOSLA (XIOState s) XmlTrees XmlTree
    -> IOSLA (XIOState s) XmlTrees XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                              (XmlTrees -> XmlTrees) -> IOSLA (XIOState s) XmlTrees XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
    arrL XmlTrees -> XmlTrees
    forall a. [a] -> [a]
    reverse

    addToErrorMsgList       :: IOStateArrow s XmlTree XmlTree
    addToErrorMsgList :: IOStateArrow s XmlTree XmlTree
    addToErrorMsgList       = Selector XIOSysState (Bool, XmlTrees)
    -> (XmlTree -> (Bool, XmlTrees) -> (Bool, XmlTrees))
    -> IOStateArrow s XmlTree XmlTree
    forall c b s.
    Selector XIOSysState c -> (b -> c -> c) -> IOStateArrow s b b
    chgSysVar
                              ( Selector XIOSysState Bool
    theErrorMsgCollect Selector XIOSysState Bool
    -> Selector XIOSysState XmlTrees
    -> Selector XIOSysState (Bool, XmlTrees)
    forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
    .&&&. Selector XIOSysState XmlTrees
    theErrorMsgList )
                              ( \ e :: XmlTree
    e (cs :: Bool
    cs, es :: XmlTrees
    es) -> (Bool
    cs, if Bool
    cs then XmlTree
    e XmlTree -> XmlTrees -> XmlTrees
    forall a. a -> [a] -> [a]
    : XmlTrees
    es else XmlTrees
    es) )

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

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

    filterErrorMsg          :: IOStateArrow s XmlTree XmlTree
    filterErrorMsg :: IOStateArrow s XmlTree XmlTree
    filterErrorMsg          = ( IOStateArrow s XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    setErrMsgStatus
                                IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                IOStateArrow s XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    sysErrorMsg
                                IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                IOStateArrow s XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    addToErrorMsgList
                                IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
                              )
                              IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when`
                              IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isError

    -- | generate a warnig message

    issueWarn               :: String -> IOStateArrow s b b
    issueWarn :: String -> IOStateArrow s b b
    issueWarn msg :: String
    msg           = IOSLA (XIOState s) b XmlTree -> IOStateArrow s b b
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
    perform (String -> IOSLA (XIOState s) b XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    warn String
    msg  IOSLA (XIOState s) b XmlTree
    -> IOSLA (XIOState s) XmlTree XmlTree
    -> IOSLA (XIOState s) b XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> IOSLA (XIOState s) XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    filterErrorMsg)

    -- | generate an error message
    issueErr                :: String -> IOStateArrow s b b
    issueErr :: String -> IOStateArrow s b b
    issueErr msg :: String
    msg            = IOSLA (XIOState s) b XmlTree -> IOStateArrow s b b
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
    perform (String -> IOSLA (XIOState s) b XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err String
    msg   IOSLA (XIOState s) b XmlTree
    -> IOSLA (XIOState s) XmlTree XmlTree
    -> IOSLA (XIOState s) b XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> IOSLA (XIOState s) XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    filterErrorMsg)

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

    issueFatal              :: String -> IOStateArrow s b b
    issueFatal :: String -> IOStateArrow s b b
    issueFatal msg :: String
    msg          = IOSLA (XIOState s) b XmlTree -> IOStateArrow s b b
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
    perform (String -> IOSLA (XIOState s) b XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    fatal String
    msg IOSLA (XIOState s) b XmlTree
    -> IOSLA (XIOState s) XmlTree XmlTree
    -> IOSLA (XIOState s) b XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> IOSLA (XIOState s) XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    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 :: String -> IOStateArrow s SomeException b
    issueExc m :: String
    m              = ( String -> IOStateArrow s SomeException SomeException
    forall s b. String -> IOStateArrow s b b
    issueFatal (String -> IOStateArrow s SomeException SomeException)
    -> IOSLA (XIOState s) SomeException String
    -> IOStateArrow s SomeException SomeException
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< (SomeException -> String)
    -> IOSLA (XIOState s) SomeException String
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr  ((String
    msg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) (String -> String)
    -> (SomeException -> String) -> SomeException -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SomeException -> String
    forall a. Show a => a -> String
    show) )
                              IOStateArrow s SomeException SomeException
    -> IOStateArrow s SomeException b -> IOStateArrow s SomeException b
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                              IOStateArrow s SomeException b
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
        where
        msg :: String
    msg | String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    m        = "Exception: "
            | Bool
    otherwise     = "Exception in " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    m String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ": "

    -- |
    -- 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 :: Int -> String -> IOStateArrow s XmlTree XmlTree
    setDocumentStatus level :: Int
    level msg :: String
    msg
                            = ( IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *).
    ArrowXml a =>
    a XmlTree XmlTree -> a XmlTree XmlTree
    addAttrl ( String -> String -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    String -> String -> a n XmlTree
    sattr String
    a_status (Int -> String
    forall a. Show a => a -> String
    show Int
    level)
                                           IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b c.
    ArrowPlus a =>
    a b c -> a b c -> a b c
    <+>
                                           String -> String -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    String -> String -> a n XmlTree
    sattr String
    a_module String
    msg
                                         )
                                IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                ( if Int
    level Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    c_err
                                  then XmlTrees -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    [t b] -> a (t b) (t b)
    setChildren []
                                  else IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
                                )
                              )
                          IOStateArrow s XmlTree XmlTree
    -> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when`
                          IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    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 :: String -> IOStateArrow s XmlTree XmlTree
    setDocumentStatusFromSystemState msg :: String
    msg
                                    = Int -> IOStateArrow s XmlTree XmlTree
    forall s. Int -> IOSLA (XIOState s) XmlTree XmlTree
    setStatus (Int -> IOStateArrow s XmlTree XmlTree)
    -> IOSLA (XIOState s) XmlTree Int -> IOStateArrow s XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< IOSLA (XIOState s) XmlTree Int
    forall s. IOStateArrow s XmlTree Int
    getErrStatus
        where
        setStatus :: Int -> IOSLA (XIOState s) XmlTree XmlTree
    setStatus level :: Int
    level
            | Int
    level Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    c_warn       = IOSLA (XIOState s) XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
            | Bool
    otherwise             = Int -> String -> IOSLA (XIOState s) XmlTree XmlTree
    forall s. Int -> String -> IOStateArrow s XmlTree XmlTree
    setDocumentStatus Int
    level String
    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 :: a XmlTree XmlTree
    documentStatusOk        = a XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRoot
                              a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                              ( (String -> a XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
    getAttrValue String
    a_status
                                 a XmlTree String -> a String String -> a XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                 (String -> Bool) -> a String String
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (\ v :: String
    v -> String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    v Bool -> Bool -> Bool
    || ((String -> Int
    forall a. Read a => String -> a
    read String
    v)::Int) Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    c_warn)
                                )
                                a XmlTree String -> a XmlTree XmlTree -> a XmlTree XmlTree
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d
    `guards`
                                a XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
                              )

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

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

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