XmlState.hs

-- |
-- This module provides a Monad for an internal state and IO commands.
-- The state consists of two parts, the user state and the system state
-- user state ist a type parameter, the system state is a list
-- name-value pair. If the user state is not needed, the type parameter
-- can be instantiated with @()@.
--
-- Furthermore there are types for Xml filter working on this monad
-- and functions for manipulating the state components
-- and for lifting i\/o commands and XmlFilter to monad filters.
--
-- Error reporting functions are also located in this module.
--
-- Version : $Id: XmlState.hs,v 1.3 2005/05/27 13:15:23 hxml Exp $

module Text.XML.HXT.DOM.XmlState
    ( module Text.XML.HXT.DOM.XmlState
    )
where

import Text.XML.HXT.DOM.XmlTree

import qualified Control.Monad.MonadStateIO as MonadStateIO

import System.IO
import Data.Maybe

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

-- |
-- The internal system state consists of a list of name-value pairs
-- of type @(String, XmlTrees)@, so arbitrary lists of trees can be stored.
-- For options, often only strings are used as values, so a set of access
-- functions with string values is available
-- The error handling method can be controlled by an error handler filter,
-- the default filter issues the errors on stderr

data SysState			= SysState { sysStateAttrs		:: ! SysStateAttrs
					   , sysStateErrorHandler	:: ! (XmlStateFilter ())
					   }

type SysStateAttrs		= AssocList String XmlTrees

-- |
-- The State has a system and a user part
-- the user state is a type parameter

data XmlState state		= XmlState { sysState	:: ! SysState
					   , userState	:: ! state
					   }

-- |
-- The monad type for commands. It is an instance of "StateIO" from the
-- general module "Control.Monad.MonadStateIO".

type XState state res		= MonadStateIO.StateIO (XmlState state) res

-- |
-- The "XmlFilter" type for filters working on a state

type XmlStateFilter state	= XmlTree -> XState state XmlTrees

-- ------------------------------------------------------------
--
-- user defined state
-- access functions

-- |
-- change the user state
--
--    * 1.parameter fct :  the user state change function
--
--    - returns : the new state

changeState	:: (state -> state) -> XState state state
changeState f
    = do
      ns <- MonadStateIO.changeState f'
      return (userState ns)
      where
      f' s = s { userState = f (userState s) }

-- |
-- set the user state.
--
--    * 1.parameter s :  the new state
--
--    - returns : the new state

setState	:: state -> XState state state
setState s
    = changeState ( \_ -> s )

-- |
-- read the user state
--
--    - returns : the current state

getState	:: XState state state
getState
    = changeState id

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

-- |
-- change the system part of the state.
--
-- see also : 'changeState'

changeSysState	:: (SysState -> SysState) -> XState state SysState
changeSysState f
    = do
      ns <- MonadStateIO.changeState f'
      return (sysState ns)
      where
      f' s = s { sysState = f (sysState s) }

-- |
-- set the system part of the state.
--
-- see also : 'setState'

setSysState		:: SysState -> XState state SysState
setSysState s
    = changeSysState ( \_ -> s )

-- |
-- read the system part of the state.
--
-- see also : 'getState'

getSysState		:: XState state SysState
getSysState
    = changeSysState id

-- |
-- the initial system state
--
-- an empty list of attribute value pairs

initialSysState		:: SysState
initialSysState
    = SysState { sysStateAttrs        = []
	       , sysStateErrorHandler = errorMsgToStderr
	       }

-- |
-- change the attributes in the system state

changeSysStateAttrs		:: (SysStateAttrs -> SysStateAttrs) -> (SysState -> SysState)
changeSysStateAttrs cf sstate
    = sstate { sysStateAttrs = cf (sysStateAttrs sstate) }


-- |
-- set the error message handler

setSysErrorHandler		:: XmlStateFilter () -> XState state ()
setSysErrorHandler ehf
    = do
      changeSysState (\ s -> s { sysStateErrorHandler = ehf })
      return ()

-- |
-- get the error handler

getSysErrorHandler		:: XState state (XmlStateFilter ())
getSysErrorHandler
    = do
      s <- getSysState
      return (sysStateErrorHandler s)

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

-- |
-- set or change a single system parameter.
--
--    * 1.parameter name :  the name of the parameter
--
--    - 2.parameter value :  the list of associated trees
--
--    - returns : nothing
--
-- see also : 'setSysParam', 'setSysParamInt'

setSysParamTree		:: String -> XmlTrees -> XState state ()
setSysParamTree name val
    = do
      changeSysState (changeSysStateAttrs (addEntry name val))
      return ()

-- |
-- set or change a single system parameter of type string.
--
--    * 1.parameter name :  the name of the parameter
--
--    - 2.parameter value :  the (new) string value
--
--    - returns : nothing
--
-- see also : 'setSysParamTree', setSysParamInt

setSysParam		:: String -> String -> XState state ()
setSysParam name val
    = setSysParamTree name (xtext val)

-- |
-- set or change a single integer type system parameter
--
-- see also : 'setSysParam'

setSysParamInt		:: String -> Int -> XState state ()
setSysParamInt name val	= setSysParam name (show val)

-- |
-- add (or change) all attributes of the document root to the system state
--     - returns : this

setSystemParams	:: XmlStateFilter state
setSystemParams t
    = do
      changeSysState (changeSysStateAttrs (addEntries (toTreel . getAttrl $ t)))
      thisM t

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

-- |
-- read a system parameter
--
--    * 1.parameter name :  the name of the parameter
--
--    - returns : the list of tres associated with the key, or the empty list for unknown parameters

getSysParamTree		:: String -> XState state XmlTrees
getSysParamTree name
    = do
      s <- getSysState
      return (lookup1 name (sysStateAttrs s))

-- |
-- read a system string parameter
--
--    * 1.parameter name :  the name of the parameter
--
--    - returns : the value, or the empty string for unknown parameters

getSysParam		:: String -> XState state String
getSysParam name
    = do
      ts <- getSysParamTree name
      return (xshow ts)

-- |
-- read a system parameter or return a default value
--
--    * 1.parameter name :  the name of the parameter
--
--    - 2.parameter default :  the default value
--
--    - returns : the value if found, else the default

getSysParamWithDefault	:: String -> String -> XState state String
getSysParamWithDefault name def
    = do
      val <- getSysParam name
      return ( if null val
	       then def
	       else val
	     )

-- |
-- read an integer system parameter
--
--    * 1.parameter name : 
--
--    - 2.parameter default : 
--
-- see also : 'getSysParamWithDefault'

getSysParamInt	:: String -> Int -> XState state Int
getSysParamInt var def
    = do
      val <- getSysParamWithDefault var (show def)
      return (read val)

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

-- |
-- exec a XState command with initial state.
--
--    * 1.parameter initalState :  the inital user state
--
--    - 2.parameter cmd :  the command
--
--    - returns : the i\/o command with result and user state

run0		:: XmlState state -> XState state res -> IO (res, XmlState state)
run0 initialState (MonadStateIO.STIO cmd)
    = do
      (res, finalState) <- cmd initialState
      return (res, finalState)

-- |
-- exec a XState command with initial user state.
-- ignore final user state.
-- like run0, but ignore the resulting user state

run		:: state -> XState state res -> IO res
run initialUserState cmd
    = do
      (res, _finalState) <- run0 (XmlState initialSysState initialUserState) cmd
      return res

-- |
-- exec a XState command in th IO monad.
-- like run with the empty state ().

run'		:: XState () res -> IO res
run'		= run ()

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

-- |
-- run a command in a new user state.
-- chain the system state part,
-- init new system state with the current one, run the command and
-- update the old system state with the resulting new system state
--
--    * 1.parameter initialUserState :  the initial user state
--
--    - 2.parameter cmd :  the command
--
--    - returns : the result of executing cmd and the final state

chain'		:: state1 -> XState state1 res -> XState state0 (res, state1)
chain' initialUserState1 cmd1
    = do
      sysState0 <- getSysState
      (res, finalState1) <- io $ run0 (XmlState sysState0 initialUserState1) cmd1
      setSysState (sysState finalState1)
      return (res, (userState finalState1))

-- |
-- like chain' but forget the final user state
--
--    * 1.parameter initialUserState :  the initial user state
--
--    - 2.parameter cmd :  the command
--
--    - returns : only the result of executing cmd

chain		:: state1 -> XState state1 res -> XState state0 res
chain initialUserState1 cmd1
    = do
      (res, _) <- chain' initialUserState1 cmd1
      return res

-- ------------------------------------------------------------
--
-- lift functions

-- |
-- lift a XmlFilter to a XmlStateFilter filter
-- issue all error nodes as error messages
-- and remove the error nodes from the result
--
--    * 1.parameter f :  the filter
--
--    - returns : the filter running in the state monad
--
--		  all errors are filtered from the result and issued on stderr

liftF		:: XmlFilter -> XmlStateFilter state
liftF f		= liftMf f .>> issueError

-- |
-- lift an I\/O command
--
--    * 1.parameter cmd :  the i\/o command
--
--    - returns : the i\/o command lifted to the XML state monad

io		:: IO a -> XState state a
io		= MonadStateIO.io

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

-- |
-- set the trace level.
--
-- convention:
--
-- 0: no trace output (default)
--
-- 1: trace important computation steps, e.g. accessing a document
--
-- 2: trace small computation steps
--
-- 3: output an intermediate result XmlTree in XML source format
--
-- 4: output an intermediate result XmlTree in tree representation
--
--    * 1.parameter level :  the trace level
--
--    - returns : nothing

setTraceLevel	:: Int -> XState state ()
setTraceLevel l	= setSysParamInt a_trace l

-- |
-- get the current trace level.
--
--    - returns : the current trace level

getTraceLevel	:: XState state Int
getTraceLevel	= getSysParamInt a_trace 0

-- |
-- trace output for arbitray commands.
--
--    * 1.parameter level :  the trace level,
--			  for which the command will be execuded
--			  if level \<= current trace level
--
--    - 2.parameter cmd :  the command to be executed
--
--    - returns : nothing

traceCmd	:: Int -> XState state a -> XState state ()
traceCmd level cmd
    = do
      trcLevel <- getTraceLevel
      if level <= trcLevel
        then do
	     _ <- cmd
	     return ()
        else return ()

-- |
-- trace output function for simple text.
--
--    * 1.parameter level :  like in traceCmd
--
--    - 2.parameter str :  the test
--
--    - returns : nothing

trace		:: Int -> String -> XState state ()
trace level str
    = traceCmd level
      $ do
	io $ hPutStrLn stderr ("-- (" ++ show level ++ ") " ++ str)

-- |
-- trace output of the user part of the program state.
--
--    * 1.parameter level :  like in traceCmd
--
--    - 2.parameter showFct :  the toString function
--
--    - returns : nothing

traceState	:: Int -> (state -> String) -> XState state ()
traceState level fct
    = traceCmd level
      $ do
	s <- getState
	io $ hPutStrLn stderr (fct s)

-- ------------------------------------------------------------
--
-- error functions

-- |
-- filter to reset the state attribute 'a_status'
--    - returns : this

clearStatus	:: XmlStateFilter state
clearStatus t
    = do
      setSysParamInt a_status c_ok
      thisM t

-- |
-- report an error message.
--
--    - returns : if the input tree n represents an error, @res = []@
--		  and the error is processed by the errror handler filter (default: error is issued on stderr)
--		  else @res = [n]@
--
-- see also : 'issueErr'

issueError	:: XmlStateFilter state
issueError
    = (setErrorMsgLevel .>> errorMsgHandler .>> noneM)
      `whenM`
      isXError

errorMsgHandler	:: XmlStateFilter state
errorMsgHandler
    = performAction
      ( \ t -> chain' () ( do
			   ehf <- getSysErrorHandler
			   ehf t
			   return ()
			 )
      )

-- |
-- set the error level in system state

setErrorMsgLevel	:: XmlStateFilter state
setErrorMsgLevel
    = performAction
      ( \ (NTree (XError level _str) _cs) ->
	do
	errLevel <- getSysParamInt a_status 0
	setSysParamInt a_status (max errLevel level)
      )

-- |
-- default error handler for writing errors to stderr

errorMsgToStderr	:: XmlStateFilter state
errorMsgToStderr
    = performAction
      ( \ (NTree (XError level str) _cs) ->
	io $ hPutStrLn stderr ("\n" ++ errClass level ++ ": " ++ str)
      )

-- |
-- error message handler for collecting all error messages
-- all messages are stored under attribute 'a_error_log'
-- they can be read with @getSysParamTree a_error_log@ or by
-- applying the filter 'getErrorMsg' to the root node

errorMsgLogging		:: XmlStateFilter state
errorMsgLogging
    = performAction
      ( \ t ->
	do
	errLog <- getSysParamTree a_error_log
	setSysParamTree a_error_log (t : errLog)
      )

errorMsgLoggingAndToStderr      :: XmlStateFilter state
errorMsgLoggingAndToStderr	= errorMsgLogging.>> errorMsgToStderr

-- |
-- the filter for reading all collected error mesages
--
-- result is the list of error messages, the input tree is ignored

getErrorMsg	:: XmlStateFilter state
getErrorMsg _t
    = do
      el <- getSysParamTree a_error_log
      setSysParamTree a_error_log []
      return (reverse el)

-- |
-- error level translation
-- 'c_warn' (1) : warning,
-- 'c_err' (2): error (e.g. parse error, validation error, ...),
-- 'c_fatal' (3) : fatal error (document access error, internal error, ...)

errClass	:: Int -> String
errClass l
    = fromMaybe "fatal error" . lookup l $ msgList
      where
      msgList	= [ (c_ok,	"no error")
		  , (c_warn,	"warning")
		  , (c_err,	"error")
		  , (c_fatal,	"fatal error")
		  ]

-- |
-- short cut for issuing a warning
--
-- see also : 'issueError', 'issueErr'

issueWarn	:: String -> XmlStateFilter state
issueWarn msg	= liftMf (warn msg) .>> issueError

-- |
-- short cut for issuing an error
--
-- see also : 'issueError'

issueErr	:: String -> XmlStateFilter state
issueErr msg	= liftMf (err msg) .>> issueError

-- |
-- short cut for issuing a fatal error
--
-- see also : 'issueError', 'issueErr'

issueFatal	:: String -> XmlStateFilter state
issueFatal msg	= liftMf (fatal msg) .>> issueError


-- ------------------------------------------------------------
--
-- issue an error, add the error to the document root tree
-- and return the tree

addFatal	:: String -> XmlStateFilter state
addFatal msg
    = liftF ( fatal msg
	      +++
	      setStatus c_fatal "accessing documents"
	    )

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

-- |
-- checks the value of the attribute 'a_status' in a document root.
-- if it contains a value greater or equal to 'c_err', an error with error message
-- stored in attribute 'a_module' is issued and the filter acts as the 'noneM' filter
-- else its the 'thisM' filter

checkStatus	:: XmlStateFilter state
checkStatus t
    = if status >= c_err
      then do
	   errorMsgHandler (mkXErrorTree c_warn (errClass status ++ "s detected in " ++ msg) [])
	   noneM t
	else
           thisM t
    where
    status = intValueOf a_status t
    msg    =    valueOf a_module t

-- |
-- add the error level and the module where the error occured
-- to the attributes of a document root node and remove the children when level is greater or equal to 'c_err'

setStatus	:: Int -> String -> XmlFilter
setStatus level msg
    = ( addAttrInt a_status level
	.>
	addAttr a_module msg
	.>
	( if level >= c_err
	  then replaceChildren []
	  else this
	)
      )
      `when` isRoot

-- |
-- check whether tree is a document root and the status attribute has a value less than 'c_err'

statusOk	:: XmlFilter
statusOk
    = isRoot
      .>
      isOf (\ t -> not (intValueOf a_status t >= c_err))
-- |
-- check whether the error level attribute in the system state
-- is set to error, in this case the children of the document root are
-- removed and error info is added as attributes with 'setStatus'
-- else nothing is changed

checkResult	:: String -> XmlStateFilter state
checkResult msg t
    = do
      level <- getSysParamInt a_status 0
      ( if level <= c_warn
	then thisM
	else liftMf ( setStatus level msg )
        ) t

-- |
-- monadic filter for processing the attribute list of a tag.
-- for other trees this filter acts like 'noneM'
--
-- see also : 'processAttr', 'processAttrl'

processAttrM				:: XmlStateFilter a -> XmlStateFilter a
processAttrM f t
    = do
      res <- f $$< al
      return $ replaceAttrl res t
    where
    al = getAttrl t

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