content: -- ------------------------------------------------------------
  
  {- |
     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
  
  -- ----------------------------------------------------------
  
  