-- ------------------------------------------------------------ {- | Module : Text.XML.HXT.Arrow.XmlState.TypeDefs Copyright : Copyright (C) 2010 Uwe Schmidt License : MIT Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : stable Portability: portable the basic state arrows for XML processing A state is needed for global processing options, like encoding options, document base URI, trace levels and error message handling The state is separated into a user defined state and a system state. The system state contains variables for error message handling, for tracing, for the document base for accessing XML documents with relative references, e.g. DTDs, and a global key value store. This assoc list has strings as keys and lists of XmlTrees as values. It is used to store arbitrary XML and text values, e.g. user defined global options. The user defined part of the store is in the default case empty, defined as (). It can be extended with an arbitray data type -} -- ------------------------------------------------------------ module Text.XML.HXT.Arrow.XmlState.TypeDefs ( module Text.XML.HXT.Arrow.XmlState.TypeDefs , Selector(..) , chgS , idS , (.&&&.) ) where import Control.Arrow -- arrow classes import Control.Arrow.ArrowList import Control.Arrow.IOStateListArrow import Control.DeepSeq import Data.ByteString.Lazy ( ByteString ) import Data.Char ( isDigit ) import Data.Function.Selector ( Selector(..) , chgS , idS , (.&&&.) ) import Text.XML.HXT.DOM.Interface -- ------------------------------------------------------------ {- datatypes -} -- | -- state datatype consists of a system state and a user state -- the user state is not fixed data XIOState us = XIOState { xioSysState :: ! XIOSysState , xioUserState :: ! us } instance (NFData us) => NFData (XIOState us) where rnf (XIOState sys usr) = rnf sys `seq` rnf usr -- | -- The arrow type for stateful arrows type IOStateArrow s b c = IOSLA (XIOState s) b c -- | -- The arrow for stateful arrows with no user defined state type IOSArrow b c = IOStateArrow () b c -- ------------------------------------------------------------ -- user state functions -- | read the user defined part of the state getUserState :: IOStateArrow s b s getUserState = IOSLA $ \ s _ -> return (s, [xioUserState s]) -- | change the user defined part of the state changeUserState :: (b -> s -> s) -> IOStateArrow s b b changeUserState cf = IOSLA $ \ s v -> let s' = s { xioUserState = cf v (xioUserState s) } in return (s', [v]) -- | set the user defined part of the state setUserState :: IOStateArrow s s s setUserState = changeUserState const -- | extend user state -- -- Run an arrow with an extended user state component, The old component -- is stored together with a new one in a pair, the arrow is executed with this -- extended state, and the augmented state component is removed form the state -- when the arrow has finished its execution withExtendedUserState :: s1 -> IOStateArrow (s1, s0) b c -> IOStateArrow s0 b c withExtendedUserState initS1 f = IOSLA $ \ s0 x -> do ~(finalS, res) <- runIOSLA f ( XIOState { xioSysState = xioSysState s0 , xioUserState = (initS1, xioUserState s0) } ) x return ( XIOState { xioSysState = xioSysState finalS , xioUserState = snd (xioUserState finalS) } , res ) -- | change the type of user state -- -- This conversion is useful, when running a state arrow with another -- structure of the user state, e.g. with () when executing some IO arrows withOtherUserState :: s1 -> IOStateArrow s1 b c -> IOStateArrow s0 b c withOtherUserState s1 f = IOSLA $ \ s x -> do (s', res) <- runIOSLA f ( XIOState { xioSysState = xioSysState s , xioUserState = s1 } ) x return ( XIOState { xioSysState = xioSysState s' , xioUserState = xioUserState s } , res ) withoutUserState :: IOSArrow b c -> IOStateArrow s0 b c withoutUserState = withOtherUserState () -- ------------------------------------------------------------ -- system state structure and acces functions -- | -- predefined system state data type with all components for the -- system functions, like trace, error handling, ... data XIOSysState = XIOSys { xioSysWriter :: ! XIOSysWriter , xioSysEnv :: ! XIOSysEnv } instance NFData XIOSysState -- all fields of interest are strict data XIOSysWriter = XIOwrt { xioErrorStatus :: ! Int , xioErrorMsgList :: ! XmlTrees , xioExpatErrors :: IOSArrow XmlTree XmlTree , xioRelaxNoOfErrors :: ! Int , xioRelaxDefineId :: ! Int , xioRelaxAttrList :: AssocList String XmlTrees } data XIOSysEnv = XIOEnv { xioTraceLevel :: ! Int , xioTraceCmd :: Int -> String -> IO () , xioErrorMsgHandler :: String -> IO () , xioErrorMsgCollect :: ! Bool , xioBaseURI :: ! String , xioDefaultBaseURI :: ! String , xioAttrList :: ! Attributes , xioInputConfig :: ! XIOInputConfig , xioParseConfig :: ! XIOParseConfig , xioOutputConfig :: ! XIOOutputConfig , xioRelaxConfig :: ! XIORelaxConfig , xioCacheConfig :: ! XIOCacheConfig } data XIOInputConfig = XIOIcgf { xioStrictInput :: ! Bool , xioEncodingErrors :: ! Bool , xioInputEncoding :: String , xioHttpHandler :: IOSArrow XmlTree XmlTree , xioInputOptions :: ! Attributes , xioRedirect :: ! Bool , xioProxy :: String } data XIOParseConfig = XIOPcfg { xioMimeTypes :: MimeTypeTable , xioMimeTypeFile :: String , xioAcceptedMimeTypes :: [String] , xioFileMimeType :: String , xioWarnings :: ! Bool , xioRemoveWS :: ! Bool , xioParseByMimeType :: ! Bool , xioParseHTML :: ! Bool , xioLowerCaseNames :: ! Bool , xioPreserveComment :: ! Bool , xioValidate :: ! Bool , xioSubstDTDEntities :: ! Bool , xioSubstHTMLEntities :: ! Bool , xioCheckNamespaces :: ! Bool , xioCanonicalize :: ! Bool , xioIgnoreNoneXmlContents :: ! Bool , xioTagSoup :: ! Bool , xioTagSoupParser :: IOSArrow XmlTree XmlTree , xioExpat :: ! Bool , xioExpatParser :: IOSArrow XmlTree XmlTree } data XIOOutputConfig = XIOOcfg { xioIndent :: ! Bool , xioOutputEncoding :: ! String , xioOutputFmt :: ! XIOXoutConfig , xioXmlPi :: ! Bool , xioNoEmptyElemFor :: ! [String] , xioAddDefaultDTD :: ! Bool , xioTextMode :: ! Bool , xioShowTree :: ! Bool , xioShowHaskell :: ! Bool } data XIOXoutConfig = XMLoutput | XHTMLoutput | HTMLoutput | PLAINoutput deriving (Eq) data XIORelaxConfig = XIORxc { xioRelaxValidate :: ! Bool , xioRelaxSchema :: String , xioRelaxCheckRestr :: ! Bool , xioRelaxValidateExtRef :: ! Bool , xioRelaxValidateInclude :: ! Bool , xioRelaxCollectErrors :: ! Bool , xioRelaxValidator :: IOSArrow XmlTree XmlTree } data XIOCacheConfig = XIOCch { xioBinaryCompression :: CompressionFct , xioBinaryDeCompression :: DeCompressionFct , xioWithCache :: ! Bool , xioCacheDir :: ! String , xioDocumentAge :: ! Int , xioCache404Err :: ! Bool , xioCacheRead :: String -> IOSArrow XmlTree XmlTree , xioStrictDeserialize :: ! Bool } type CompressionFct = ByteString -> ByteString type DeCompressionFct = ByteString -> ByteString type SysConfig = XIOSysState -> XIOSysState type SysConfigList = [SysConfig] -- ---------------------------------------- theSysState :: Selector (XIOState us) XIOSysState theSysState = S { getS = xioSysState , setS = \ x s -> s { xioSysState = x} } theUserState :: Selector (XIOState us) us theUserState = S { getS = xioUserState , setS = \ x s -> s { xioUserState = x} } -- ---------------------------------------- theSysWriter :: Selector XIOSysState XIOSysWriter theSysWriter = S { getS = xioSysWriter , setS = \ x s -> s { xioSysWriter = x} } theErrorStatus :: Selector XIOSysState Int theErrorStatus = theSysWriter >>> S { getS = xioErrorStatus , setS = \ x s -> s { xioErrorStatus = x } } theErrorMsgList :: Selector XIOSysState XmlTrees theErrorMsgList = theSysWriter >>> S { getS = xioErrorMsgList , setS = \ x s -> s { xioErrorMsgList = x } } theRelaxNoOfErrors :: Selector XIOSysState Int theRelaxNoOfErrors = theSysWriter >>> S { getS = xioRelaxNoOfErrors , setS = \ x s -> s { xioRelaxNoOfErrors = x} } theRelaxDefineId :: Selector XIOSysState Int theRelaxDefineId = theSysWriter >>> S { getS = xioRelaxDefineId , setS = \ x s -> s { xioRelaxDefineId = x} } theRelaxAttrList :: Selector XIOSysState (AssocList String XmlTrees) theRelaxAttrList = theSysWriter >>> S { getS = xioRelaxAttrList , setS = \ x s -> s { xioRelaxAttrList = x} } -- ---------------------------------------- theSysEnv :: Selector XIOSysState XIOSysEnv theSysEnv = S { getS = xioSysEnv , setS = \ x s -> s { xioSysEnv = x} } theInputConfig :: Selector XIOSysState XIOInputConfig theInputConfig = theSysEnv >>> S { getS = xioInputConfig , setS = \ x s -> s { xioInputConfig = x} } theStrictInput :: Selector XIOSysState Bool theStrictInput = theInputConfig >>> S { getS = xioStrictInput , setS = \ x s -> s { xioStrictInput = x} } theEncodingErrors :: Selector XIOSysState Bool theEncodingErrors = theInputConfig >>> S { getS = xioEncodingErrors , setS = \ x s -> s { xioEncodingErrors = x} } theInputEncoding :: Selector XIOSysState String theInputEncoding = theInputConfig >>> S { getS = xioInputEncoding , setS = \ x s -> s { xioInputEncoding = x} } theHttpHandler :: Selector XIOSysState (IOSArrow XmlTree XmlTree) theHttpHandler = theInputConfig >>> S { getS = xioHttpHandler , setS = \ x s -> s { xioHttpHandler = x} } theInputOptions :: Selector XIOSysState Attributes theInputOptions = theInputConfig >>> S { getS = xioInputOptions , setS = \ x s -> s { xioInputOptions = x} } theRedirect :: Selector XIOSysState Bool theRedirect = theInputConfig >>> S { getS = xioRedirect , setS = \ x s -> s { xioRedirect = x} } theProxy :: Selector XIOSysState String theProxy = theInputConfig >>> S { getS = xioProxy , setS = \ x s -> s { xioProxy = x} } -- ---------------------------------------- theOutputConfig :: Selector XIOSysState XIOOutputConfig theOutputConfig = theSysEnv >>> S { getS = xioOutputConfig , setS = \ x s -> s { xioOutputConfig = x} } theIndent :: Selector XIOSysState Bool theIndent = theOutputConfig >>> S { getS = xioIndent , setS = \ x s -> s { xioIndent = x} } theOutputEncoding :: Selector XIOSysState String theOutputEncoding = theOutputConfig >>> S { getS = xioOutputEncoding , setS = \ x s -> s { xioOutputEncoding = x} } theOutputFmt :: Selector XIOSysState XIOXoutConfig theOutputFmt = theOutputConfig >>> S { getS = xioOutputFmt , setS = \ x s -> s { xioOutputFmt = x} } theXmlPi :: Selector XIOSysState Bool theXmlPi = theOutputConfig >>> S { getS = xioXmlPi , setS = \ x s -> s { xioXmlPi = x} } theNoEmptyElemFor :: Selector XIOSysState [String] theNoEmptyElemFor = theOutputConfig >>> S { getS = xioNoEmptyElemFor , setS = \ x s -> s { xioNoEmptyElemFor = x} } theAddDefaultDTD :: Selector XIOSysState Bool theAddDefaultDTD = theOutputConfig >>> S { getS = xioAddDefaultDTD , setS = \ x s -> s { xioAddDefaultDTD = x} } theTextMode :: Selector XIOSysState Bool theTextMode = theOutputConfig >>> S { getS = xioTextMode , setS = \ x s -> s { xioTextMode = x} } theShowTree :: Selector XIOSysState Bool theShowTree = theOutputConfig >>> S { getS = xioShowTree , setS = \ x s -> s { xioShowTree = x} } theShowHaskell :: Selector XIOSysState Bool theShowHaskell = theOutputConfig >>> S { getS = xioShowHaskell , setS = \ x s -> s { xioShowHaskell = x} } -- ---------------------------------------- theRelaxConfig :: Selector XIOSysState XIORelaxConfig theRelaxConfig = theSysEnv >>> S { getS = xioRelaxConfig , setS = \ x s -> s { xioRelaxConfig = x} } theRelaxValidate :: Selector XIOSysState Bool theRelaxValidate = theRelaxConfig >>> S { getS = xioRelaxValidate , setS = \ x s -> s { xioRelaxValidate = x} } theRelaxSchema :: Selector XIOSysState String theRelaxSchema = theRelaxConfig >>> S { getS = xioRelaxSchema , setS = \ x s -> s { xioRelaxSchema = x} } theRelaxCheckRestr :: Selector XIOSysState Bool theRelaxCheckRestr = theRelaxConfig >>> S { getS = xioRelaxCheckRestr , setS = \ x s -> s { xioRelaxCheckRestr = x} } theRelaxValidateExtRef :: Selector XIOSysState Bool theRelaxValidateExtRef = theRelaxConfig >>> S { getS = xioRelaxValidateExtRef , setS = \ x s -> s { xioRelaxValidateExtRef = x} } theRelaxValidateInclude :: Selector XIOSysState Bool theRelaxValidateInclude = theRelaxConfig >>> S { getS = xioRelaxValidateInclude , setS = \ x s -> s { xioRelaxValidateInclude = x} } theRelaxCollectErrors :: Selector XIOSysState Bool theRelaxCollectErrors = theRelaxConfig >>> S { getS = xioRelaxCollectErrors , setS = \ x s -> s { xioRelaxCollectErrors = x} } theRelaxValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree) theRelaxValidator = theRelaxConfig >>> S { getS = xioRelaxValidator , setS = \ x s -> s { xioRelaxValidator = x} } -- ---------------------------------------- theParseConfig :: Selector XIOSysState XIOParseConfig theParseConfig = theSysEnv >>> S { getS = xioParseConfig , setS = \ x s -> s { xioParseConfig = x} } theErrorMsgHandler :: Selector XIOSysState (String -> IO ()) theErrorMsgHandler = theSysEnv >>> S { getS = xioErrorMsgHandler , setS = \ x s -> s { xioErrorMsgHandler = x } } theErrorMsgCollect :: Selector XIOSysState Bool theErrorMsgCollect = theSysEnv >>> S { getS = xioErrorMsgCollect , setS = \ x s -> s { xioErrorMsgCollect = x } } theBaseURI :: Selector XIOSysState String theBaseURI = theSysEnv >>> S { getS = xioBaseURI , setS = \ x s -> s { xioBaseURI = x } } theDefaultBaseURI :: Selector XIOSysState String theDefaultBaseURI = theSysEnv >>> S { getS = xioDefaultBaseURI , setS = \ x s -> s { xioDefaultBaseURI = x } } theTraceLevel :: Selector XIOSysState Int theTraceLevel = theSysEnv >>> S { getS = xioTraceLevel , setS = \ x s -> s { xioTraceLevel = x } } theTraceCmd :: Selector XIOSysState (Int -> String -> IO ()) theTraceCmd = theSysEnv >>> S { getS = xioTraceCmd , setS = \ x s -> s { xioTraceCmd = x } } theTrace :: Selector XIOSysState (Int, Int -> String -> IO ()) theTrace = theTraceLevel .&&&. theTraceCmd theAttrList :: Selector XIOSysState Attributes theAttrList = theSysEnv >>> S { getS = xioAttrList , setS = \ x s -> s { xioAttrList = x } } theMimeTypes :: Selector XIOSysState MimeTypeTable theMimeTypes = theParseConfig >>> S { getS = xioMimeTypes , setS = \ x s -> s { xioMimeTypes = x } } theMimeTypeFile :: Selector XIOSysState String theMimeTypeFile = theParseConfig >>> S { getS = xioMimeTypeFile , setS = \ x s -> s { xioMimeTypeFile = x } } theAcceptedMimeTypes :: Selector XIOSysState [String] theAcceptedMimeTypes = theParseConfig >>> S { getS = xioAcceptedMimeTypes , setS = \ x s -> s { xioAcceptedMimeTypes = x } } theFileMimeType :: Selector XIOSysState String theFileMimeType = theParseConfig >>> S { getS = xioFileMimeType , setS = \ x s -> s { xioFileMimeType = x } } theWarnings :: Selector XIOSysState Bool theWarnings = theParseConfig >>> S { getS = xioWarnings , setS = \ x s -> s { xioWarnings = x } } theRemoveWS :: Selector XIOSysState Bool theRemoveWS = theParseConfig >>> S { getS = xioRemoveWS , setS = \ x s -> s { xioRemoveWS = x } } thePreserveComment :: Selector XIOSysState Bool thePreserveComment = theParseConfig >>> S { getS = xioPreserveComment , setS = \ x s -> s { xioPreserveComment = x } } theParseByMimeType :: Selector XIOSysState Bool theParseByMimeType = theParseConfig >>> S { getS = xioParseByMimeType , setS = \ x s -> s { xioParseByMimeType = x } } theParseHTML :: Selector XIOSysState Bool theParseHTML = theParseConfig >>> S { getS = xioParseHTML , setS = \ x s -> s { xioParseHTML = x } } theLowerCaseNames :: Selector XIOSysState Bool theLowerCaseNames = theParseConfig >>> S { getS = xioLowerCaseNames , setS = \ x s -> s { xioLowerCaseNames = x } } theValidate :: Selector XIOSysState Bool theValidate = theParseConfig >>> S { getS = xioValidate , setS = \ x s -> s { xioValidate = x } } theSubstDTDEntities :: Selector XIOSysState Bool theSubstDTDEntities = theParseConfig >>> S { getS = xioSubstDTDEntities , setS = \ x s -> s { xioSubstDTDEntities = x } } theSubstHTMLEntities :: Selector XIOSysState Bool theSubstHTMLEntities = theParseConfig >>> S { getS = xioSubstHTMLEntities , setS = \ x s -> s { xioSubstHTMLEntities = x } } theCheckNamespaces :: Selector XIOSysState Bool theCheckNamespaces = theParseConfig >>> S { getS = xioCheckNamespaces , setS = \ x s -> s { xioCheckNamespaces = x } } theCanonicalize :: Selector XIOSysState Bool theCanonicalize = theParseConfig >>> S { getS = xioCanonicalize , setS = \ x s -> s { xioCanonicalize = x } } theIgnoreNoneXmlContents :: Selector XIOSysState Bool theIgnoreNoneXmlContents = theParseConfig >>> S { getS = xioIgnoreNoneXmlContents , setS = \ x s -> s { xioIgnoreNoneXmlContents = x } } theTagSoup :: Selector XIOSysState Bool theTagSoup = theParseConfig >>> S { getS = xioTagSoup , setS = \ x s -> s { xioTagSoup = x } } theTagSoupParser :: Selector XIOSysState (IOSArrow XmlTree XmlTree) theTagSoupParser = theParseConfig >>> S { getS = xioTagSoupParser , setS = \ x s -> s { xioTagSoupParser = x } } theExpat :: Selector XIOSysState Bool theExpat = theParseConfig >>> S { getS = xioExpat , setS = \ x s -> s { xioExpat = x } } theExpatParser :: Selector XIOSysState (IOSArrow XmlTree XmlTree) theExpatParser = theParseConfig >>> S { getS = xioExpatParser , setS = \ x s -> s { xioExpatParser = x } } theExpatErrors :: Selector XIOSysState (IOSArrow XmlTree XmlTree) theExpatErrors = theSysWriter >>> S { getS = xioExpatErrors , setS = \ x s -> s { xioExpatErrors = x } } -- ---------------------------------------- theCacheConfig :: Selector XIOSysState XIOCacheConfig theCacheConfig = theSysEnv >>> S { getS = xioCacheConfig , setS = \ x s -> s { xioCacheConfig = x} } theBinaryCompression :: Selector XIOSysState (ByteString -> ByteString) theBinaryCompression = theCacheConfig >>> S { getS = xioBinaryCompression , setS = \ x s -> s { xioBinaryCompression = x} } theBinaryDeCompression :: Selector XIOSysState (ByteString -> ByteString) theBinaryDeCompression = theCacheConfig >>> S { getS = xioBinaryDeCompression , setS = \ x s -> s { xioBinaryDeCompression = x} } theWithCache :: Selector XIOSysState Bool theWithCache = theCacheConfig >>> S { getS = xioWithCache , setS = \ x s -> s { xioWithCache = x} } theCacheDir :: Selector XIOSysState String theCacheDir = theCacheConfig >>> S { getS = xioCacheDir , setS = \ x s -> s { xioCacheDir = x} } theDocumentAge :: Selector XIOSysState Int theDocumentAge = theCacheConfig >>> S { getS = xioDocumentAge , setS = \ x s -> s { xioDocumentAge = x} } theCache404Err :: Selector XIOSysState Bool theCache404Err = theCacheConfig >>> S { getS = xioCache404Err , setS = \ x s -> s { xioCache404Err = x} } theCacheRead :: Selector XIOSysState (String -> IOSArrow XmlTree XmlTree) theCacheRead = theCacheConfig >>> S { getS = xioCacheRead , setS = \ x s -> s { xioCacheRead = x} } theStrictDeserialize :: Selector XIOSysState Bool theStrictDeserialize = theCacheConfig >>> S { getS = xioStrictDeserialize , setS = \ x s -> s { xioStrictDeserialize = x} } -- ------------------------------------------------------------ getSysVar :: Selector XIOSysState c -> IOStateArrow s b c getSysVar sel = IOSLA $ \ s _x -> return (s, (:[]) . getS (theSysState >>> sel) $ s) setSysVar :: Selector XIOSysState c -> IOStateArrow s c c setSysVar sel = (\ v -> configSysVar $ setS sel v) $< this chgSysVar :: Selector XIOSysState c -> (b -> c -> c) -> IOStateArrow s b b chgSysVar sel op = (\ v -> configSysVar $ chgS sel (op v)) $< this configSysVar :: SysConfig -> IOStateArrow s c c configSysVar cf = IOSLA $ \ s v -> return (chgS theSysState cf s, [v]) configSysVars :: SysConfigList -> IOStateArrow s c c configSysVars cfs = configSysVar $ foldr (>>>) id $ cfs localSysVar :: Selector XIOSysState c -> IOStateArrow s a b -> IOStateArrow s a b localSysVar sel f = IOSLA $ \ s0 v -> let sel' = theSysState >>> sel in let c0 = getS sel' s0 in do (s1, res) <- runIOSLA f s0 v return (setS sel' c0 s1, res) localSysEnv :: IOStateArrow s a b -> IOStateArrow s a b localSysEnv = localSysVar theSysEnv incrSysVar :: Selector XIOSysState Int -> IOStateArrow s a Int incrSysVar cnt = getSysVar cnt >>> arr (+1) >>> setSysVar cnt >>> arr (\ x -> x - 1) -- ------------------------------ -- | store a string in global state under a given attribute name setSysAttr :: String -> IOStateArrow s String String setSysAttr n = chgSysVar theAttrList (addEntry n) -- | remove an entry in global state, arrow input remains unchanged unsetSysAttr :: String -> IOStateArrow s b b unsetSysAttr n = configSysVar $ chgS theAttrList (delEntry n) -- | read an attribute value from global state getSysAttr :: String -> IOStateArrow s b String getSysAttr n = getSysVar theAttrList >>^ lookup1 n -- | read all attributes from global state getAllSysAttrs :: IOStateArrow s b Attributes getAllSysAttrs = getSysVar theAttrList setSysAttrString :: String -> String -> IOStateArrow s b b setSysAttrString n v = perform ( constA v >>> setSysAttr n ) -- | store an int value in global state setSysAttrInt :: String -> Int -> IOStateArrow s b b setSysAttrInt n v = setSysAttrString n (show v) -- | read an int value from global state -- -- > getSysAttrInt 0 myIntAttr getSysAttrInt :: Int -> String -> IOStateArrow s b Int getSysAttrInt def n = getSysAttr n >>^ toInt def toInt :: Int -> String -> Int toInt def s | not (null s) && all isDigit s = read s | otherwise = def -- ------------------------------------------------------------