module Text.XML.HXT.Arrow.XmlIOStateArrow
(
XIOState(..),
XIOSysState(..),
IOStateArrow,
IOSArrow,
initialState,
initialSysState,
runX,
getUserState,
setUserState,
changeUserState,
withExtendedUserState,
withOtherUserState,
getSysParam,
changeSysParam,
setParamList,
setParam,
unsetParam,
getParam,
getAllParams,
getAllParamsString,
setParamString,
getParamString,
setParamInt,
getParamInt,
clearErrStatus,
setErrStatus,
getErrStatus,
setErrMsgStatus,
setErrorMsgHandler,
errorMsgStderr,
errorMsgCollect,
errorMsgStderrAndCollect,
errorMsgIgnore,
getErrorMessages,
filterErrorMsg,
issueWarn,
issueErr,
issueFatal,
setDocumentStatus,
setDocumentStatusFromSystemState,
documentStatusOk,
setBaseURI,
getBaseURI,
changeBaseURI,
setDefaultBaseURI,
getDefaultBaseURI,
runInLocalURIContext,
setTraceLevel,
getTraceLevel,
withTraceLevel,
setTraceCmd,
getTraceCmd,
trace,
traceMsg,
traceValue,
traceString,
traceSource,
traceTree,
traceDoc,
traceState,
expandURIString,
expandURI,
mkAbsURI,
getFragmentFromURI,
getPathFromURI,
getPortFromURI,
getQueryFromURI,
getRegNameFromURI,
getSchemeFromURI,
getUserInfoFromURI,
setMimeTypeTable,
setMimeTypeTableFromFile
)
where
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowIO
import Control.Arrow.IOStateListArrow
import Control.Monad ( mzero
, mplus )
import Control.DeepSeq
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.Edit ( addHeadlineToXmlDoc
, treeRepOfXmlDoc
, indentDoc
)
import Data.Maybe
import Network.URI ( URI
, escapeURIChar
, isUnescapedInURI
, nonStrictRelativeTo
, parseURIReference
, uriAuthority
, uriFragment
, uriPath
, uriPort
, uriQuery
, uriRegName
, uriScheme
, uriUserInfo
)
import System.IO ( hPutStrLn
, hFlush
, stderr
)
import System.Directory ( getCurrentDirectory )
data XIOSysState = XIOSys { xio_trace :: ! Int
, xio_traceCmd :: Int -> String -> IO ()
, xio_errorStatus :: ! Int
, xio_errorModule :: ! String
, xio_errorMsgHandler :: String -> IO ()
, xio_errorMsgCollect :: ! Bool
, xio_errorMsgList :: ! XmlTrees
, xio_baseURI :: ! String
, xio_defaultBaseURI :: ! String
, xio_attrList :: ! (AssocList String XmlTrees)
, xio_mimeTypes :: MimeTypeTable
}
instance NFData XIOSysState where
rnf (XIOSys tr _trc es em _emh emc eml bu du al _mt)
= rnf tr `seq` rnf es `seq` rnf em `seq` rnf emc `seq` rnf eml `seq` rnf bu `seq` rnf du `seq` rnf al
data XIOState us = XIOState { xio_sysState :: ! XIOSysState
, xio_userState :: ! us
}
instance (NFData us) => NFData (XIOState us) where
rnf (XIOState sys usr) = rnf sys `seq` rnf usr
type IOStateArrow s b c = IOSLA (XIOState s) b c
type IOSArrow b c = IOStateArrow () b c
initialState :: us -> XIOState us
initialState s = XIOState { xio_sysState = initialSysState
, xio_userState = s
}
initialSysState :: XIOSysState
initialSysState = XIOSys { xio_trace = 0
, xio_traceCmd = traceOutputToStderr
, xio_errorStatus = c_ok
, xio_errorModule = ""
, xio_errorMsgHandler = hPutStrLn stderr
, xio_errorMsgCollect = False
, xio_errorMsgList = []
, xio_baseURI = ""
, xio_defaultBaseURI = ""
, xio_attrList = []
, xio_mimeTypes = defaultMimeTypeTable
}
runX :: IOSArrow XmlTree c -> IO [c]
runX = runXIOState (initialState ())
runXIOState :: XIOState s -> IOStateArrow s XmlTree c -> IO [c]
runXIOState s0 f
= do
(_finalState, res) <- runIOSLA (emptyRoot >>> f) s0 undefined
return res
where
emptyRoot = root [] []
getUserState :: IOStateArrow s b s
getUserState
= IOSLA $ \ s _ ->
return (s, [xio_userState s])
changeUserState :: (b -> s -> s) -> IOStateArrow s b b
changeUserState cf
= IOSLA $ \ s v ->
let s' = s { xio_userState = cf v (xio_userState s) }
in return (s', [v])
setUserState :: IOStateArrow s s s
setUserState
= changeUserState const
withExtendedUserState :: s1 -> IOStateArrow (s1, s0) b c -> IOStateArrow s0 b c
withExtendedUserState initS1 f
= IOSLA $ \ s0 x ->
do
~(finalS, res) <- runIOSLA f ( XIOState { xio_sysState = xio_sysState s0
, xio_userState = (initS1, xio_userState s0)
}
) x
return ( XIOState { xio_sysState = xio_sysState finalS
, xio_userState = snd (xio_userState finalS)
}
, res
)
withOtherUserState :: s1 -> IOStateArrow s1 b c -> IOStateArrow s0 b c
withOtherUserState s1 f
= IOSLA $ \ s x ->
do
(s', res) <- runIOSLA f ( XIOState { xio_sysState = xio_sysState s
, xio_userState = s1
}
) x
return ( XIOState { xio_sysState = xio_sysState s'
, xio_userState = xio_userState s
}
, res
)
getSysParam :: (XIOSysState -> c) -> IOStateArrow s b c
getSysParam f
= IOSLA $ \ s _x ->
return (s, (:[]) . f . xio_sysState $ s)
changeSysParam :: (b -> XIOSysState -> XIOSysState) -> IOStateArrow s b b
changeSysParam cf
= ( IOSLA $ \ s v ->
let s' = changeSysState (cf v) s
in return (s', [v])
)
where
changeSysState css s = s { xio_sysState = css (xio_sysState s) }
setParam :: String -> IOStateArrow s XmlTree XmlTree
setParam n
= (:[]) ^>> setParamList n
setParamList :: String -> IOStateArrow s XmlTrees XmlTree
setParamList n
= changeSysParam addE
>>>
arrL id
where
addE x s = s { xio_attrList = addEntry n x (xio_attrList s) }
unsetParam :: String -> IOStateArrow s b b
unsetParam n
= changeSysParam delE
where
delE _ s = s { xio_attrList = delEntry n (xio_attrList s) }
getParam :: String -> IOStateArrow s b XmlTree
getParam n
= getAllParams
>>>
arrL (lookup1 n)
getAllParams :: IOStateArrow s b (AssocList String XmlTrees)
getAllParams
= getSysParam xio_attrList
getAllParamsString :: IOStateArrow s b (AssocList String String)
getAllParamsString
= getAllParams
>>>
listA ( unlistA
>>>
second (xshow unlistA)
)
setParamString :: String -> String -> IOStateArrow s b b
setParamString n v
= perform ( txt v
>>>
setParam n
)
getParamString :: String -> IOStateArrow s b String
getParamString n
= xshow (getParam n)
setParamInt :: String -> Int -> IOStateArrow s b b
setParamInt n v
= setParamString n (show v)
getParamInt :: Int -> String -> IOStateArrow s b Int
getParamInt def n
= getParamString n
>>^
(\ x -> if null x then def else read x)
changeErrorStatus :: (Int -> Int -> Int) -> IOStateArrow s Int Int
changeErrorStatus f
= changeSysParam (\ l s -> s { xio_errorStatus = f l (xio_errorStatus s) })
clearErrStatus :: IOStateArrow s b b
clearErrStatus
= perform (constA 0 >>> changeErrorStatus min)
setErrStatus :: IOStateArrow s Int Int
setErrStatus
= changeErrorStatus max
getErrStatus :: IOStateArrow s XmlTree Int
getErrStatus
= getSysParam xio_errorStatus
setErrMsgStatus :: IOStateArrow s XmlTree XmlTree
setErrMsgStatus
= perform ( getErrorLevel
>>>
setErrStatus
)
setErrorMsgHandler :: Bool -> (String -> IO ()) -> IOStateArrow s b b
setErrorMsgHandler c f
= changeSysParam cf
where
cf _ s = s { xio_errorMsgHandler = f
, xio_errorMsgCollect = c }
sysErrorMsg :: IOStateArrow s XmlTree XmlTree
sysErrorMsg
= perform ( getErrorLevel &&& getErrorMsg
>>>
arr formatErrorMsg
>>>
( IOSLA $ \ s e ->
do
(xio_errorMsgHandler . xio_sysState $ s) e
return (s, undefined)
)
)
where
formatErrorMsg (level, msg) = "\n" ++ errClass level ++ ": " ++ msg
errClass l
= fromMaybe "fatal error" . lookup l $ msgList
where
msgList = [ (c_ok, "no error")
, (c_warn, "warning")
, (c_err, "error")
, (c_fatal, "fatal error")
]
errorMsgStderr :: IOStateArrow s b b
errorMsgStderr = setErrorMsgHandler False (hPutStrLn stderr)
errorMsgCollect :: IOStateArrow s b b
errorMsgCollect = setErrorMsgHandler True (const $ return ())
errorMsgStderrAndCollect :: IOStateArrow s b b
errorMsgStderrAndCollect = setErrorMsgHandler True (hPutStrLn stderr)
errorMsgIgnore :: IOStateArrow s b b
errorMsgIgnore = setErrorMsgHandler False (const $ return ())
getErrorMessages :: IOStateArrow s b XmlTree
getErrorMessages
= getSysParam (reverse . xio_errorMsgList)
>>>
clearErrorMsgList
>>>
arrL id
clearErrorMsgList :: IOStateArrow s b b
clearErrorMsgList
= changeSysParam (\ _ s -> s { xio_errorMsgList = [] } )
addToErrorMsgList :: IOStateArrow s XmlTree XmlTree
addToErrorMsgList
= changeSysParam cf
where
cf t s = if xio_errorMsgCollect s
then s { xio_errorMsgList = t : xio_errorMsgList s }
else s
filterErrorMsg :: IOStateArrow s XmlTree XmlTree
filterErrorMsg
= ( setErrMsgStatus
>>>
sysErrorMsg
>>>
addToErrorMsgList
>>>
none
)
`when`
isError
issueWarn :: String -> IOStateArrow s b b
issueWarn msg = perform (warn msg >>> filterErrorMsg)
issueErr :: String -> IOStateArrow s b b
issueErr msg = perform (err msg >>> filterErrorMsg)
issueFatal :: String -> IOStateArrow s b b
issueFatal msg = perform (fatal msg >>> filterErrorMsg)
setDocumentStatus :: Int -> String -> IOStateArrow s XmlTree XmlTree
setDocumentStatus level msg
= ( addAttrl ( sattr a_status (show level)
<+>
sattr a_module msg
)
>>>
( if level >= c_err
then setChildren []
else this
)
)
`when`
isRoot
setDocumentStatusFromSystemState :: String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState msg
= setStatus $< getErrStatus
where
setStatus level
| level <= c_warn = this
| otherwise = setDocumentStatus level msg
documentStatusOk :: ArrowXml a => a XmlTree XmlTree
documentStatusOk
= isRoot
>>>
( (getAttrValue a_status
>>>
isA (\ v -> null v || ((read v)::Int) <= c_warn)
)
`guards`
this
)
setBaseURI :: IOStateArrow s String String
setBaseURI
= changeSysParam (\ b s -> s { xio_baseURI = b } )
>>>
traceValue 2 (("setBaseURI: new base URI is " ++) . show)
getBaseURI :: IOStateArrow s b String
getBaseURI
= getSysParam xio_baseURI
>>>
( ( getDefaultBaseURI
>>>
setBaseURI
>>>
getBaseURI
)
`when`
isA null
)
changeBaseURI :: IOStateArrow s String String
changeBaseURI
= mkAbsURI
>>>
setBaseURI
setDefaultBaseURI :: String -> IOStateArrow s b String
setDefaultBaseURI base
= ( if null base
then arrIO getDir
else constA base
)
>>>
changeSysParam (\ b s -> s { xio_defaultBaseURI = b } )
>>>
traceValue 2 (("setDefaultBaseURI: new default base URI is " ++) . show)
where
getDir _ = do
cwd <- getCurrentDirectory
return ("file://" ++ normalize cwd ++ "/")
normalize wd'@(d : ':' : _)
| d `elem` ['A'..'Z'] || d `elem` ['a'..'z']
= '/' : concatMap win32ToUriChar wd'
normalize wd'
= concatMap escapeNonUriChar wd'
win32ToUriChar '\\' = "/"
win32ToUriChar c = escapeNonUriChar c
escapeNonUriChar c = escapeURIChar isUnescapedInURI c
getDefaultBaseURI :: IOStateArrow s b String
getDefaultBaseURI
= getSysParam xio_defaultBaseURI
>>>
( setDefaultBaseURI ""
>>>
getDefaultBaseURI ) `when` isA null
runInLocalURIContext :: IOStateArrow s b c -> IOStateArrow s b c
runInLocalURIContext f
= ( getBaseURI &&& this )
>>>
( this *** listA f )
>>>
( setBaseURI *** this )
>>>
arrL snd
setTraceLevel :: Int -> IOStateArrow s b b
setTraceLevel l
= changeSysParam (\ _ s -> s { xio_trace = l } )
getTraceLevel :: IOStateArrow s b Int
getTraceLevel
= getSysParam xio_trace
setTraceCmd :: (Int -> String -> IO ()) -> IOStateArrow s b b
setTraceCmd c
= changeSysParam (\ _ s -> s { xio_traceCmd = c } )
getTraceCmd :: IOStateArrow a b (Int -> String -> IO ())
getTraceCmd
= getSysParam xio_traceCmd
withTraceLevel :: Int -> IOStateArrow s b c -> IOStateArrow s b c
withTraceLevel level f
= ( getTraceLevel &&& this )
>>>
( setTraceLevel level *** listA f )
>>>
( restoreTraceLevel *** this )
>>>
arrL snd
where
restoreTraceLevel :: IOStateArrow s Int Int
restoreTraceLevel
= setTraceLevel $< this
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)
)
traceOutputToStderr :: Int -> String -> IO ()
traceOutputToStderr _level msg
= do
hPutStrLn stderr msg
hFlush stderr
traceValue :: Int -> (b -> String) -> IOStateArrow s b b
traceValue level trc
= trace level (arr $ (('-' : "- (" ++ show level ++ ") ") ++) . trc)
traceString :: Int -> (b -> String) -> IOStateArrow s b b
traceString = traceValue
traceMsg :: Int -> String -> IOStateArrow s b b
traceMsg level msg
= traceValue level (const msg)
traceSource :: IOStateArrow s XmlTree XmlTree
traceSource
= trace 3 $
xshow
( choiceA [ isRoot :-> ( indentDoc
>>>
getChildren
)
, isElem :-> ( root [] [this]
>>> indentDoc
>>> getChildren
>>> isElem
)
, this :-> this
]
)
traceTree :: IOStateArrow s XmlTree XmlTree
traceTree
= trace 4 $
xshow ( treeRepOfXmlDoc
>>>
addHeadlineToXmlDoc
>>>
getChildren
)
traceDoc :: String -> IOStateArrow s XmlTree XmlTree
traceDoc msg
= traceMsg 1 msg
>>>
traceSource
>>>
traceTree
traceState :: IOStateArrow s b b
traceState
= perform ( xshow ( (getAllParams >>. concat)
>>>
applyA (arr formatParam)
)
>>>
traceValue 2 ("global state:\n" ++)
)
where
formatParam (n, v)
= mkelem "param" [sattr "name" n] [arrL (const v)] <+> txt "\n"
parseURIReference' :: String -> Maybe URI
parseURIReference' uri
= parseURIReference uri
`mplus`
( if unesc
then parseURIReference uri'
else mzero
)
where
unesc = not . all isUnescapedInURI $ uri
escape '\\' = "/"
escape c = escapeURIChar isUnescapedInURI c
uri' = concatMap escape uri
expandURIString :: String -> String -> Maybe String
expandURIString uri base
= do
base' <- parseURIReference' base
uri' <- parseURIReference' uri
abs' <- nonStrictRelativeTo uri' base'
return $ show abs'
expandURI :: ArrowXml a => a (String, String) String
expandURI
= arrL (maybeToList . uncurry expandURIString)
mkAbsURI :: IOStateArrow s String String
mkAbsURI
= ( this &&& getBaseURI ) >>> expandURI
getSchemeFromURI :: ArrowList a => a String String
getSchemeFromURI = getPartFromURI scheme
where
scheme = init . uriScheme
getRegNameFromURI :: ArrowList a => a String String
getRegNameFromURI = getPartFromURI host
where
host = maybe "" uriRegName . uriAuthority
getPortFromURI :: ArrowList a => a String String
getPortFromURI = getPartFromURI port
where
port = dropWhile (==':') . maybe "" uriPort . uriAuthority
getUserInfoFromURI :: ArrowList a => a String String
getUserInfoFromURI = getPartFromURI ui
where
ui = reverse . dropWhile (=='@') . reverse . maybe "" uriUserInfo . uriAuthority
getPathFromURI :: ArrowList a => a String String
getPathFromURI = getPartFromURI uriPath
getQueryFromURI :: ArrowList a => a String String
getQueryFromURI = getPartFromURI uriQuery
getFragmentFromURI :: ArrowList a => a String String
getFragmentFromURI = getPartFromURI uriFragment
getPartFromURI :: ArrowList a => (URI -> String) -> a String String
getPartFromURI sel
= arrL (maybeToList . getPart)
where
getPart s = do
uri <- parseURIReference' s
return (sel uri)
setMimeTypeTable :: MimeTypeTable -> IOStateArrow s b b
setMimeTypeTable mtt
= changeSysParam (\ _ s -> s {xio_mimeTypes = mtt})
setMimeTypeTableFromFile :: FilePath -> IOStateArrow s b b
setMimeTypeTableFromFile file
= setMimeTypeTable $< arrIO0 ( readMimeTypeTable file)