TraceHandling.hs

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

{- |
   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 l         = configSysVar $ withTrace l

-- | read the global trace level

getTraceLevel           :: IOStateArrow s b Int
getTraceLevel           = getSysVar theTraceLevel

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

setTraceCmd             :: (Int -> String -> IO ()) -> IOStateArrow s b b
setTraceCmd c           = configSysVar $ setS theTraceCmd c

-- | acces the command for trace output

getTraceCmd             :: IOStateArrow a b (Int -> String -> IO ())
getTraceCmd             = getSysVar 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 level f  = localSysEnv $ setTraceLevel level >>> f

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

trace                   :: Int -> IOStateArrow s b String -> IOStateArrow s b b
trace level trc         = perform ( trc
                                    >>>
                                    ( getTraceCmd &&& this )
                                    >>>
                                    arrIO (\ (cmd, msg) -> cmd level msg)
                                  )
                          `when` ( getTraceLevel
                                   >>>
                                   isA (>= 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 level trc    = trace level (arr $ (('-' : "- (" ++ show level ++ ") ") ++) . trc)

-- | an old alias for 'traceValue'

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

-- | issue a string message as trace

traceMsg                :: Int -> String -> IOStateArrow s b b
traceMsg level msg      = traceValue level (const 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             = trace 3 $
                          xshow $
                          choiceA [ isRoot :-> ( indentDoc
                                                 >>>
                                                 getChildren
                                               )
                                  , isElem :-> ( root [] [this]
                                                 >>> indentDoc
                                                 >>> getChildren
                                                 >>> isElem
                                               )
                                  , this   :-> this
                                  ]

-- | issue the tree representation of a document if trace level >= 4
traceTree               :: IOStateArrow s XmlTree XmlTree
traceTree               = trace 4 $
                          xshow $
                          treeRepOfXmlDoc
                          >>>
                          addHeadlineToXmlDoc
                          >>>
                          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 msg            = traceMsg 1 msg
                          >>>
                          traceSource
                          >>>
                          traceTree

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

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

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