module Text.XML.HXT.Arrow.XmlState.ErrorHandling
where
import Control.Arrow
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
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
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
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
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 )
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)
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")
]
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
)
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 ())
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)
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 ())
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) )
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
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)
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)
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)
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
": "
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
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
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