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

{- |
   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 :: forall s. (Int -> Int -> Int) -> IOStateArrow s Int Int
changeErrorStatus 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 :: forall s b. 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 Int
0

-- | set global error variable

setErrStatus            :: IOStateArrow s Int Int
setErrStatus :: forall s. 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 :: forall s. 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 :: forall s. IOStateArrow s XmlTree XmlTree
setErrMsgStatus         = IOSLA (XIOState s) XmlTree Int
-> IOSLA (XIOState s) XmlTree XmlTree
forall b c. IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
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 :: forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
setErrorMsgHandler Bool
c 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 :: forall s. IOStateArrow s XmlTree XmlTree
sysErrorMsg             = IOSLA (XIOState s) XmlTree () -> IOSLA (XIOState s) XmlTree XmlTree
forall b c. IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
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 b c c'.
IOSLA (XIOState s) b c
-> IOSLA (XIOState s) b c' -> IOSLA (XIOState s) b (c, c')
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 b c. (b -> c) -> IOSLA (XIOState s) b c
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 b c c'.
IOSLA (XIOState s) b c
-> IOSLA (XIOState s) b c' -> IOSLA (XIOState s) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& IOSLA (XIOState s) String String
forall b. IOSLA (XIOState s) b b
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 b c. (b -> IO c) -> IOSLA (XIOState s) b c
forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO (\ (String -> IO ()
h, String
msg) -> String -> IO ()
h String
msg)
                          )
    where
    formatErrorMsg :: (Int, String) -> String
formatErrorMsg (Int
level, String
msg) = String
"\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 -> String
forall a. [a] -> [a] -> [a]
++ String
msg
    errClass :: Int -> String
errClass Int
l          = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"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,      String
"no error")
                          , (Int
c_warn,    String
"warning")
                          , (Int
c_err,     String
"error")
                          , (Int
c_fatal,   String
"fatal error")
                          ]


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

errorMsgStderr          :: IOStateArrow s b b
errorMsgStderr :: forall s b. 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 (\ 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 :: forall s b. 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

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

errorMsgStderrAndCollect        :: IOStateArrow s b b
errorMsgStderrAndCollect :: forall s b. 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 :: forall s b. 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 a. a -> IO a
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 :: forall s b. 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
-> 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
>>>
                          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 b c. (b -> [c]) -> IOSLA (XIOState s) b c
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 :: forall s. 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 )
                          ( \ XmlTree
e (Bool
cs, 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 :: forall s. 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 b c. IOSLA (XIOState s) b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                          )
                          IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall b c.
IOSLA (XIOState s) b b
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
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 :: forall s b. String -> IOStateArrow s b b
issueWarn String
msg           = IOSLA (XIOState s) b XmlTree -> IOSLA (XIOState s) b b
forall b c. IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (String -> IOSLA (XIOState s) b XmlTree
forall n. String -> IOSLA (XIOState s) n 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 :: forall s b. String -> IOStateArrow s b b
issueErr String
msg            = IOSLA (XIOState s) b XmlTree -> IOSLA (XIOState s) b b
forall b c. IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (String -> IOSLA (XIOState s) b XmlTree
forall n. String -> IOSLA (XIOState s) n 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 :: forall s b. String -> IOStateArrow s b b
issueFatal String
msg          = IOSLA (XIOState s) b XmlTree -> IOSLA (XIOState s) b b
forall b c. IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (String -> IOSLA (XIOState s) b XmlTree
forall n. String -> IOSLA (XIOState s) n 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 :: forall s b. String -> IOStateArrow s SomeException b
issueExc 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 c b d.
(c -> IOSLA (XIOState s) b d)
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b d
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 b c. (b -> c) -> IOSLA (XIOState s) b c
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
-> IOSLA (XIOState s) SomeException b
-> IOSLA (XIOState 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
>>>
                          IOSLA (XIOState s) SomeException b
forall b c. IOSLA (XIOState s) b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
    where
    msg :: String
msg | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
m        = String
"Exception: "
        | Bool
otherwise     = String
"Exception in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "

-- |
-- 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 :: forall s. Int -> String -> IOStateArrow s XmlTree XmlTree
setDocumentStatus Int
level String
msg
                        = ( IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
addAttrl ( String -> String -> IOSLA (XIOState s) XmlTree XmlTree
forall n. String -> String -> IOSLA (XIOState s) n 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)
                                       IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall b c.
IOSLA (XIOState s) b c
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
                                       String -> String -> IOSLA (XIOState s) XmlTree XmlTree
forall n. String -> String -> IOSLA (XIOState s) n XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
String -> String -> a n XmlTree
sattr String
a_module String
msg
                                     )
                            IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState 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 -> IOSLA (XIOState s) XmlTree XmlTree
forall (t :: * -> *) b.
Tree t =>
[t b] -> IOSLA (XIOState s) (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
[t b] -> a (t b) (t b)
setChildren []
                              else IOSLA (XIOState s) XmlTree XmlTree
forall b. IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                            )
                          )
                      IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
-> IOSLA (XIOState s) XmlTree XmlTree
forall b c.
IOSLA (XIOState s) b b
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                      IOSLA (XIOState 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 :: forall s. String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState String
msg
                                = Int -> IOSLA (XIOState s) XmlTree XmlTree
forall {s}. Int -> IOSLA (XIOState s) XmlTree XmlTree
setStatus (Int -> IOSLA (XIOState s) XmlTree XmlTree)
-> IOSLA (XIOState s) XmlTree Int
-> IOSLA (XIOState s) XmlTree XmlTree
forall c b d.
(c -> IOSLA (XIOState s) b d)
-> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b d
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 Int
level
        | Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c_warn       = IOSLA (XIOState s) XmlTree XmlTree
forall b. IOSLA (XIOState s) b b
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 :: forall (a :: * -> * -> *). ArrowXml a => 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 b. (b -> Bool) -> a b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (\ String
v -> String -> Bool
forall a. [a] -> 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 b c d. a b c -> a b d -> a b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                            a XmlTree XmlTree
forall b. a b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                          )

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

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

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