-- |
-- 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.31 2004/03/24 11:42:46 hxml Exp $

module XmlState
    ( module XmlState
    )
where

import XmlTree

import qualified 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, ofthen only strings are used as values, so a set of access
-- functions with string values is available

type SysState			= 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 "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

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

-- |
-- 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 (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 (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 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 [] 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

-- |
-- the name of the system parameter for the error level

errorLevel	:: String
errorLevel	= "errorLevel"

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

clearErrorLevel	:: XmlStateFilter state
clearErrorLevel t
    = do
      setSysParamInt errorLevel c_ok
      thisM t

-- |
-- report an error message.
--
--    - returns : if the input tree n represents an error, @res = []@
--		  and the error is written to stderr
--		  else @res = [n]@
--
-- see also : 'issueErr'

issueError	:: XmlStateFilter state
issueError
    = (performAction issue .>> noneM)
      `whenM`
      isXError
      where
      issue (NTree (XError level str) _cs)
	  = do
	    io $ hPutStrLn stderr ("\n" ++ errClass level ++ ": " ++ str)
	    errLevel <- getSysParamInt errorLevel 0
	    setSysParamInt errorLevel (max errLevel level)
      issue _
	  = error "issueError called with illegal argument"

errClass	:: Int -> String
errClass l
    = fromMaybe "fatal error" . lookup l $ msgList
      where
      msgList	= [ (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 "in 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_message' 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
           io $ hPutStrLn stderr ("\n" ++ errClass status ++ "s detected " ++ msg)
	   noneM t
	else
           thisM t
    where
    status = intValueOf a_status  t
    msg    =    valueOf a_message t

-- |
-- add the error level and the module where the error occured
-- to the attributes of a document root node and remove the children

setStatus	:: Int -> String -> XmlFilter
setStatus level msg
    = ( addAttrInt a_status level
	.>
	addAttr a_message msg
	.>
	replaceChildren []
      )
      `when` isRoot

-- |
-- 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 errorLevel 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

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