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

{- |
   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 :: forall s b. Int -> IOStateArrow s b b
setTraceLevel Int
l         = forall s c. SysConfig -> IOStateArrow s c c
configSysVar forall a b. (a -> b) -> a -> b
$ Int -> SysConfig
withTrace Int
l

-- | read the global trace level

getTraceLevel           :: IOStateArrow s b Int
getTraceLevel :: forall s b. IOStateArrow s b Int
getTraceLevel           = 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 :: forall s b. (Int -> String -> IO ()) -> IOStateArrow s b b
setTraceCmd Int -> String -> IO ()
c           = 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 -> String -> IO ())
theTraceCmd Int -> String -> IO ()
c

-- | acces the command for trace output

getTraceCmd             :: IOStateArrow a b (Int -> String -> IO ())
getTraceCmd :: forall a b. IOStateArrow a b (Int -> String -> IO ())
getTraceCmd             = 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 :: forall s b c. Int -> IOStateArrow s b c -> IOStateArrow s b c
withTraceLevel Int
level IOStateArrow s b c
f  = forall s a b. IOStateArrow s a b -> IOStateArrow s a b
localSysEnv forall a b. (a -> b) -> a -> b
$ forall s b. Int -> IOStateArrow s b b
setTraceLevel Int
level 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 :: forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
level IOStateArrow s b String
trc         = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( IOStateArrow s b String
trc
                                    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. IOStateArrow a b (Int -> String -> IO ())
getTraceCmd 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 (\ (Int -> String -> IO ()
cmd, String
msg) -> Int -> String -> IO ()
cmd Int
level String
msg)
                                  )
                          forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` ( forall s b. IOStateArrow s b Int
getTraceLevel
                                   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 (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 :: forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
level b -> String
trc    = forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
level (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ ((Char
'-' forall a. a -> [a] -> [a]
: String
"- (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
level forall a. [a] -> [a] -> [a]
++ String
") ") forall a. [a] -> [a] -> [a]
++) 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 :: forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceString             = 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 :: forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
level String
msg      = forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
level (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 :: forall s. IOStateArrow s XmlTree XmlTree
traceSource             = forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
3 forall a b. (a -> b) -> a -> b
$
                          forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow forall a b. (a -> b) -> a -> b
$
                          forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot forall a b. a -> b -> IfThen a b
:-> ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc
                                                 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                                                 forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                                               )
                                  , forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall a b. a -> b -> IfThen a b
:-> ( forall (a :: * -> * -> *) n.
ArrowXml a =>
[a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root [] [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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
indentDoc
                                                 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                                                 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 => a XmlTree XmlTree
isElem
                                               )
                                  , forall (a :: * -> * -> *) b. ArrowList a => a b b
this   forall a b. a -> b -> IfThen a b
:-> 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 :: forall s. IOStateArrow s XmlTree XmlTree
traceTree               = forall s b. Int -> IOStateArrow s b String -> IOStateArrow s b b
trace Int
4 forall a b. (a -> b) -> a -> b
$
                          forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow forall a b. (a -> b) -> a -> b
$
                          forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
treeRepOfXmlDoc
                          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 => a XmlTree XmlTree
addHeadlineToXmlDoc
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          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 :: forall s. String -> IOStateArrow s XmlTree XmlTree
traceDoc String
msg            = forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
1 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
traceSource
                          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
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

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