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

{- |
   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     = 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          = forall s c. SysConfig -> IOStateArrow s c c
configSysVar forall a b. (a -> b) -> a -> b
$ 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            = forall s. (Int -> Int -> Int) -> IOStateArrow s Int Int
changeErrorStatus 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            = 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         = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform
                          ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
getErrorLevel forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> 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  = forall s c. SysConfig -> IOStateArrow s c c
configSysVar forall a b. (a -> b) -> a -> b
$ forall s a. Selector s a -> a -> s -> s
setS (Selector XIOSysState Bool
theErrorMsgCollect 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             = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform
                          ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree Int
getErrorLevel forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getErrorMsg
                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                            forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Int, String) -> String
formatErrorMsg
                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                            forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState (String -> IO ())
theErrorMsgHandler forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a 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" forall a. [a] -> [a] -> [a]
++ Int -> String
errClass Int
level forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg
    errClass :: Int -> String
errClass Int
l          = forall a. a -> Maybe a -> a
fromMaybe String
"fatal error" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
l 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          = 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         = forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
setErrorMsgHandler Bool
True (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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        = 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          = forall s b. Bool -> (String -> IO ()) -> IOStateArrow s b b
setErrorMsgHandler Bool
False (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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        = forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState XmlTrees
theErrorMsgList
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall s c. SysConfig -> IOStateArrow s c c
configSysVar (forall s a. Selector s a -> a -> s -> s
setS Selector XIOSysState XmlTrees
theErrorMsgList [])
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL forall a. [a] -> [a]
reverse

addToErrorMsgList       :: IOStateArrow s XmlTree XmlTree
addToErrorMsgList :: forall s. IOStateArrow s XmlTree XmlTree
addToErrorMsgList       = forall c b s.
Selector XIOSysState c -> (b -> c -> c) -> IOStateArrow s b b
chgSysVar
                          ( Selector XIOSysState Bool
theErrorMsgCollect 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 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          = ( forall s. IOStateArrow s XmlTree XmlTree
setErrMsgStatus
                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                            forall s. IOStateArrow s XmlTree XmlTree
sysErrorMsg
                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                            forall s. IOStateArrow s XmlTree XmlTree
addToErrorMsgList
                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                            forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                          )
                          forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                          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           = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
warn String
msg  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> 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            = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err String
msg   forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> 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          = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
fatal String
msg forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> 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              = ( forall s b. String -> IOStateArrow s b b
issueFatal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr  ((String
msg forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) )
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
    where
    msg :: String
msg | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
m        = String
"Exception: "
        | Bool
otherwise     = String
"Exception in " forall a. [a] -> [a] -> [a]
++ String
m 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
                        = ( forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
addAttrl ( forall (a :: * -> * -> *) n.
ArrowXml a =>
String -> String -> a n XmlTree
sattr String
a_status (forall a. Show a => a -> String
show Int
level)
                                       forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
                                       forall (a :: * -> * -> *) n.
ArrowXml a =>
String -> String -> a n XmlTree
sattr String
a_module String
msg
                                     )
                            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 forall a. Ord a => a -> a -> Bool
>= Int
c_err
                              then forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
[t b] -> a (t b) (t b)
setChildren []
                              else forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                            )
                          )
                      forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                      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
                                = forall {s}. Int -> IOSLA (XIOState s) XmlTree XmlTree
setStatus forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall s. IOStateArrow s XmlTree Int
getErrStatus
    where
    setStatus :: Int -> IOSLA (XIOState s) XmlTree XmlTree
setStatus Int
level
        | Int
level forall a. Ord a => a -> a -> Bool
<= Int
c_warn       = forall (a :: * -> * -> *) b. ArrowList a => a b b
this
        | Bool
otherwise             = 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        = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ( (forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
a_status
                             forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                             forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (\ String
v -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
v Bool -> Bool -> Bool
|| ((forall a. Read a => String -> a
read String
v)::Int) forall a. Ord a => a -> a -> Bool
<= Int
c_warn)
                            )
                            forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                            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

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