hxt-9.0.0: src/Text/XML/HXT/Arrow/XmlState/ErrorHandling.hs
-- ------------------------------------------------------------
{- |
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
-- ------------------------------------------------------------