module Text.XML.HXT.XSLT.XsltArrows
( xsltCompileStylesheet
, xsltCompileStylesheetFromURI
, xsltApplyStylesheet
, xsltApplyStylesheetFromURI
, CompiledStylesheet
)
where
import Prelude hiding ( catch )
import Control.Exception
( SomeException
, catch
, evaluate )
import Control.Arrow.ListArrows
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.ReadDocument
import Text.XML.HXT.XSLT.Names
import Text.XML.HXT.XSLT.CompiledStylesheet
( CompiledStylesheet )
import Text.XML.HXT.XSLT.Compilation
( prepareXSLTDocument
, assembleStylesheet
)
import Text.XML.HXT.XSLT.Application
( applyStylesheet )
arrWithCatch :: (a -> b) -> IOSArrow a b
arrWithCatch f
= arrIO (applyf f)
>>>
( (applyA (arr issueErr) >>> none)
|||
this
)
applyf :: (a -> b) -> a -> IO (Either String b)
applyf f x
= catch' ( do
res <- evaluate ( f x )
return . Right $ res
)
(\ e -> return . Left . ("XSLT: " ++) . show $ e)
where
catch' :: IO a -> (SomeException -> IO a) -> IO a
catch' = catch
prepareXSLTDoc :: IOSArrow XmlTree XmlTree
prepareXSLTDoc
= ( arrWithCatch prepareXSLTDocument
>>>
traceDoc "prepareXSLTDocument"
)
`when`
documentStatusOk
readXSLTDoc :: Attributes -> IOSArrow String XmlTree
readXSLTDoc options
= readFromDocument (options ++ defaultOptions)
where
defaultOptions
= [ (a_check_namespaces, v_1)
, (a_validate, v_0)
, (a_preserve_comment, v_0)
]
compileSSTWithIncludeStack :: [String] -> IOSArrow XmlTree CompiledStylesheet
compileSSTWithIncludeStack incStack
= traceMsg 2 "compile stylesheet"
>>>
getChildren
>>>
isElem
>>>
choiceA
[ isXsltLREstylesheet
:-> ( xsltlre2stylesheet
>>>
assStylesheet []
)
, isXsltStylesheetElem
:-> ( expStylesheet
$< ( listA ( getChildren
>>>
expandIncludes incStack
)
>>>
partitionA isXsltImport
)
)
, this
:-> ( issueErr "XSLT: Either xsl:stylesheet/xsl:transform or simplified syntax expected"
>>>
none
)
]
>>>
traceValue 3 (("compiled stylesheet:\n" ++) . show)
where
assStylesheet imports
= arrWithCatch (flip assembleStylesheet $ imports)
expStylesheet (imports, rest)
= traceMsg 2 "expand stylesheet"
>>>
setChildren rest
>>>
assStylesheet $< listA ( constL imports
>>>
getXsltAttrValue xsltHRef
>>>
compileSSTFromUriWithIncludeStack incStack
)
readSSTWithIncludeStack :: [String] -> IOSArrow String XmlTree
readSSTWithIncludeStack incStack
= ifP (`elem` incStack)
( (issueErr $< arr recursiveInclude) >>> none )
( readXSLTDoc []
>>>
prepareXSLTDoc
)
where
recursiveInclude uri
= "XSLT error: "
++ show uri ++ " is recursively imported/included."
++ concatMap (("\n imported/included from: " ++) . show) incStack
compileSSTFromUriWithIncludeStack :: [String] -> IOSArrow String CompiledStylesheet
compileSSTFromUriWithIncludeStack incStack
= comp $< this
where
comp uri
= readSSTWithIncludeStack incStack
>>>
compileSSTWithIncludeStack (uri:incStack)
expandIncludes :: [String] -> IOSArrow XmlTree XmlTree
expandIncludes incStack
= isElem
>>>
( ( expandInclude $< getXsltAttrValue xsltHRef )
`when`
isXsltInclude
)
where
expandInclude href
= ( constA href
>>>
readSSTWithIncludeStack incStack
>>>
getChildren
>>>
isElem
>>>
choiceA
[ isXsltLREstylesheet
:-> xsltlre2template
, isXsltStylesheetElem
:-> ( getChildren
>>>
expandIncludes (href:incStack)
)
, this
:-> issueFatal ("XSLT error: Included file " ++ show href ++ " is not a stylesheet")
]
)
isXsltElem :: ArrowXml a => QName -> a XmlTree XmlTree
isXsltElem qn = isElem >>> hasNameWith (equivQName qn)
isXsltAttr :: ArrowXml a => QName -> a XmlTree XmlTree
isXsltAttr qn = isAttr >>> hasNameWith (equivQName qn)
hasXsltAttr :: ArrowXml a => QName -> a XmlTree XmlTree
hasXsltAttr qn = ( getAttrl >>> isXsltAttr qn )
`guards`
this
isXsltInclude :: ArrowXml a => a XmlTree XmlTree
isXsltInclude = isXsltElem xsltInclude
isXsltImport :: ArrowXml a => a XmlTree XmlTree
isXsltImport = isXsltElem xsltImport
isXsltLREstylesheet :: ArrowXml a => a XmlTree XmlTree
isXsltLREstylesheet = hasXsltAttr xsltVersionLRE
isXsltStylesheetElem :: ArrowXml a => a XmlTree XmlTree
isXsltStylesheetElem = ( isXsltElem xsltTransform
<+>
isXsltElem xsltStylesheet
)
>>>
hasXsltAttr xsltVersion
getXsltAttrValue :: ArrowXml a => QName -> a XmlTree String
getXsltAttrValue qn = getAttrl >>> isXsltAttr qn >>> xshow getChildren
xsltlre2template :: ArrowXml a => a XmlTree XmlTree
xsltlre2template = mkqelem xsltTemplate [sqattr xsltMatch "/"] [this]
xsltlre2stylesheet :: ArrowXml a => a XmlTree XmlTree
xsltlre2stylesheet = mkqelem xsltTransform [] [ this >>> xsltlre2template ]
checkApplySST :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
checkApplySST appl
= ( isRoot
>>>
replaceChildren appl
>>>
traceDoc "XSLT stylesheet applied"
>>>
setDocumentStatusFromSystemState "applying XSLT stylesheet"
)
`orElse`
issueErr "XSLT: complete document with root node required for stylesheet application"
xsltCompileStylesheet :: IOSArrow XmlTree CompiledStylesheet
xsltCompileStylesheet
= prepareXSLTDoc
>>>
compileSSTWithIncludeStack []
xsltCompileStylesheetFromURI :: IOSArrow String CompiledStylesheet
xsltCompileStylesheetFromURI = compileSSTFromUriWithIncludeStack []
xsltApplyStylesheet :: CompiledStylesheet -> IOSArrow XmlTree XmlTree
xsltApplyStylesheet css
= checkApplySST (arrWithCatch (applyStylesheet css) >>. concat)
xsltApplyStylesheetFromURI :: String -> IOSArrow XmlTree XmlTree
xsltApplyStylesheetFromURI uri
= xsltApplyStylesheet $< (constA uri >>> xsltCompileStylesheetFromURI)