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

{- |
   Module     : Text.XML.HXT.Arrow.XmlState.TraceHandling
   Copyright  : Copyright (C) 2010 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   the trace arrows

-}

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

module Text.XML.HXT.Arrow.XmlState.TraceHandling
where

import Control.Arrow                            -- arrow classes
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowIO

import System.IO                        ( hPutStrLn
                                        , hFlush
                                        , stderr
                                        )

import Text.XML.HXT.DOM.Interface

import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.Arrow.XmlState.SystemConfig

import Text.XML.HXT.Arrow.Edit          ( addHeadlineToXmlDoc
                                        , treeRepOfXmlDoc
                                        , indentDoc
                                        )

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

-- | set the global trace level

setTraceLevel           :: Int -> IOStateArrow s b b
setTraceLevel :: Int -> IOStateArrow s b b
setTraceLevel Int
l         = 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
$ Int -> SysConfig
withTrace Int
l

-- | read the global trace level

getTraceLevel           :: IOStateArrow s b Int
getTraceLevel :: IOStateArrow s b Int
getTraceLevel           = Selector XIOSysState Int -> IOStateArrow s b Int
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState Int
theTraceLevel

-- | set the global trace command. This command does the trace output

setTraceCmd             :: (Int -> String -> IO ()) -> IOStateArrow s b b
setTraceCmd :: (Int -> String -> IO ()) -> IOStateArrow s b b
setTraceCmd Int -> String -> IO ()
c           = 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 -> String -> IO ())
-> (Int -> String -> IO ()) -> SysConfig
forall s a. Selector s a -> a -> s -> s
setS Selector XIOSysState (Int -> String -> IO ())
theTraceCmd Int -> String -> IO ()
c

-- | acces the command for trace output

getTraceCmd             :: IOStateArrow a b (Int -> String -> IO ())
getTraceCmd :: IOStateArrow a b (Int -> String -> IO ())
getTraceCmd             = Selector XIOSysState (Int -> String -> IO ())
-> IOStateArrow a b (Int -> String -> IO ())
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState (Int -> String -> IO ())
theTraceCmd

-- | run an arrow with a given trace level, the old trace level is restored after the arrow execution

withTraceLevel          :: Int -> IOStateArrow s b c -> IOStateArrow s b c
withTraceLevel :: Int -> IOStateArrow s b c -> IOStateArrow s b c
withTraceLevel Int
level IOStateArrow s b c
f  = IOStateArrow s b c -> IOStateArrow s b c
forall s a b. IOStateArrow s a b -> IOStateArrow s a b
localSysEnv (IOStateArrow s b c -> IOStateArrow s b c)
-> IOStateArrow s b c -> IOStateArrow s b c
forall a b. (a -> b) -> a -> b
$ Int -> IOStateArrow s b b
forall s b. Int -> IOStateArrow s b b
setTraceLevel Int
level IOStateArrow s b b -> IOStateArrow s b c -> IOStateArrow s b c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IOStateArrow s b c
f

-- | apply a trace arrow and issue message to stderr

trace                   :: Int -> IOStateArrow s b String -> IOStateArrow s b b
trace :: Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
level IOStateArrow s b String
trc         = IOSLA (XIOState s) b () -> IOStateArrow s b b
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( IOStateArrow s b String
trc
                                    IOStateArrow s b String
-> IOSLA (XIOState s) String () -> IOSLA (XIOState s) 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 String (Int -> String -> IO ())
forall a b. IOStateArrow a b (Int -> String -> IO ())
getTraceCmd IOStateArrow s String (Int -> String -> IO ())
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String (Int -> 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 (Int -> String -> IO (), String)
-> IOSLA (XIOState s) (Int -> 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
>>>
                                    ((Int -> String -> IO (), String) -> IO ())
-> IOSLA (XIOState s) (Int -> String -> IO (), String) ()
forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO (\ (Int -> String -> IO ()
cmd, String
msg) -> Int -> String -> IO ()
cmd Int
level String
msg)
                                  )
                          IOStateArrow s b b
-> IOSLA (XIOState s) b Int -> IOStateArrow s b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` ( IOSLA (XIOState s) b Int
forall s b. IOStateArrow s b Int
getTraceLevel
                                   IOSLA (XIOState s) b Int
-> IOSLA (XIOState s) Int Int -> IOSLA (XIOState s) b Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                                   (Int -> Bool) -> IOSLA (XIOState s) Int Int
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
level)
                                 )

-- | trace the current value transfered in a sequence of arrows.
--
-- The value is formated by a string conversion function. This is a substitute for
-- the old and less general traceString function

traceValue              :: Int -> (b -> String) -> IOStateArrow s b b
traceValue :: Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
level b -> String
trc    = Int -> IOStateArrow s b String -> IOStateArrow s b b
forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
level ((b -> String) -> IOStateArrow s b String
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b -> String) -> IOStateArrow s b String)
-> (b -> String) -> IOStateArrow s b String
forall a b. (a -> b) -> a -> b
$ ((Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: String
"- (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
level String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (b -> String) -> b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
trc)

-- | an old alias for 'traceValue'

traceString             :: Int -> (b -> String) -> IOStateArrow s b b
traceString :: Int -> (b -> String) -> IOStateArrow s b b
traceString             = Int -> (b -> String) -> IOStateArrow s b b
forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue

-- | issue a string message as trace

traceMsg                :: Int -> String -> IOStateArrow s b b
traceMsg :: Int -> String -> IOStateArrow s b b
traceMsg Int
level String
msg      = Int -> (b -> String) -> IOStateArrow s b b
forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
level (String -> b -> String
forall a b. a -> b -> a
const String
msg)

-- | issue the source representation of a document if trace level >= 3
--
-- for better readability the source is formated with indentDoc

traceSource             :: IOStateArrow s XmlTree XmlTree
traceSource :: IOStateArrow s XmlTree XmlTree
traceSource             = Int
-> IOStateArrow s XmlTree String -> IOStateArrow s XmlTree XmlTree
forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
3 (IOStateArrow s XmlTree String -> IOStateArrow s XmlTree XmlTree)
-> IOStateArrow s XmlTree String -> IOStateArrow s XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                          IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow (IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree String)
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree String
forall a b. (a -> b) -> a -> b
$
                          [IfThen
   (IOStateArrow s XmlTree XmlTree) (IOStateArrow s XmlTree XmlTree)]
-> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree
-> IfThen
     (IOStateArrow s XmlTree XmlTree) (IOStateArrow s XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> ( IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc
                                                 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 :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                                               )
                                  , IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree
-> IfThen
     (IOStateArrow s XmlTree XmlTree) (IOStateArrow s XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> ( [IOStateArrow s XmlTree XmlTree]
-> [IOStateArrow s XmlTree XmlTree]
-> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
[a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root [] [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 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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc
                                                 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 :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                                                 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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
                                               )
                                  , IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this   IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree
-> IfThen
     (IOStateArrow s XmlTree XmlTree) (IOStateArrow s XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                                  ]

-- | issue the tree representation of a document if trace level >= 4
traceTree               :: IOStateArrow s XmlTree XmlTree
traceTree :: IOStateArrow s XmlTree XmlTree
traceTree               = Int
-> IOStateArrow s XmlTree String -> IOStateArrow s XmlTree XmlTree
forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
4 (IOStateArrow s XmlTree String -> IOStateArrow s XmlTree XmlTree)
-> IOStateArrow s XmlTree String -> IOStateArrow s XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                          IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow (IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree String)
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree String
forall a b. (a -> b) -> a -> b
$
                          IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc
                          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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
addHeadlineToXmlDoc
                          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 :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren

-- | trace a main computation step
-- issue a message when trace level >= 1, issue document source if level >= 3, issue tree when level is >= 4

traceDoc                :: String -> IOStateArrow s XmlTree XmlTree
traceDoc :: String -> IOStateArrow s XmlTree XmlTree
traceDoc String
msg            = Int -> String -> IOStateArrow s XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
1 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
>>>
                          IOStateArrow s XmlTree XmlTree
forall s. IOStateArrow s XmlTree XmlTree
traceSource
                          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
traceTree

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

traceOutputToStderr     :: Int -> String -> IO ()
traceOutputToStderr :: Int -> String -> IO ()
traceOutputToStderr Int
_level String
msg
                        = do
                          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
                          Handle -> IO ()
hFlush Handle
stderr

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