module Text.XML.HXT.XSLT.Compilation
( prepareXSLTDocument
, assembleStylesheet
)
where
import Control.Monad
import Data.Maybe
import Data.Either
import Data.List
import qualified Data.Map as Map hiding (Map)
import Data.Map(Map)
import Text.ParserCombinators.Parsec.Prim(runParser)
import Text.XML.HXT.XSLT.Common
import Text.XML.HXT.XSLT.Names
import Text.XML.HXT.XSLT.CompiledStylesheet
infixl 9 ><
(><) :: XmlNode n => (UriMapping -> a ) -> n -> a
f >< node
= f $ getUriMap node
parseExpr :: UriMapping -> String -> Expr
parseExpr uris selectStr
= either (error.show) id parseResult
where
parseResult = runParser parseXPath (Map.toList uris) ("select-expr:"++selectStr) selectStr
parseSelect :: UriMapping -> String -> SelectExpr
parseSelect uris
= SelectExpr . parseExpr uris
parseTest :: UriMapping -> String -> TestExpr
parseTest uris
= TestExpr . mkBoolExpr . parseExpr uris
parseStringExpr :: UriMapping -> String -> StringExpr
parseStringExpr uris
= StringExpr . mkStringExpr . parseExpr uris
parseMatch :: UriMapping -> String -> MatchExpr
parseMatch uris str
= if isMatchExpr expr
then MatchExpr expr
else error $ str ++ " is not a legal match-expression"
where
expr = parseExpr uris str
parseAVT :: UriMapping -> String -> StringExpr
parseAVT uris str =
StringExpr $ concatExpr $ splitAVT str ""
where
splitAVT :: String -> String -> [Expr]
splitAVT "" acc = acc2lit acc
splitAVT ('{':'{':xs) acc = splitAVT xs $ '{':acc
splitAVT ('}':'}':xs) acc = splitAVT xs $ '}':acc
splitAVT ('{':xs) acc = let (body, rest) = span (`notElem` "{}") xs in
if not (null rest) && head rest == '}'
then acc2lit acc ++ parseExpr uris body : splitAVT (tail rest) ""
else error $ "Unterminated expression " ++ xs ++ " in AVT."
splitAVT ('}':_) _ = error $ "deserted '}' in AVT."
splitAVT (x:xs) acc = splitAVT xs $ x:acc
acc2lit :: String -> [Expr]
acc2lit "" = []
acc2lit acc = [mkLiteralExpr $ reverse acc]
compileComputedQName :: XmlTree -> ComputedQName
compileComputedQName node =
(CompQName><node) nameAVT nsAVT
where
nameAVT = parseAVT><node $ fetchAttribute node xsltName
nsAVT = parseAVT><node $ fetchAttributeWDefault node xsltNamespace ""
compileComposite :: [XmlTree] -> Template
compileComposite = TemplComposite . map (compileTemplate . return)
compileMessage :: XmlTree -> Template
compileMessage node = TemplMessage halt content
where halt = termAttr == "yes"
termAttr = fetchAttributeWDefault node xsltTerminate "no"
content = compileTemplate (getChildren node)
compileForEach :: XmlTree -> Template
compileForEach node = TemplForEach expr sorting template
where expr = parseSelect><node $ fetchAttribute node xsltSelect
sorting = map compileSortKey srt
template = compileTemplate cnt
(srt, cnt) = partition (isElemType xsltSort) $ getChildren node
compileChoose :: XmlTree -> Template
compileChoose node = TemplChoose whenParts
where whenParts = map compl children
children = filter isElem (getChildren node)
compl node' = let elemName = fromJust $ getElemName node' in
if equivQName elemName xsltWhen then compileWhen node'
else if equivQName elemName xsltOtherwise then compileOtherwise node'
else error ("No elements of type " ++ show elemName ++ " allowed within xsl-choose template!")
compileWhen :: XmlTree -> When
compileWhen node = WhenPart expr $ compileTemplate $ getChildren node
where expr = parseTest><node $ fetchAttribute node xsltTest
compileOtherwise :: XmlTree -> When
compileOtherwise node = WhenPart (TestExpr mkTrueExpr) $ compileTemplate $ getChildren node
compileIf :: XmlTree -> Template
compileIf = TemplChoose . return . compileWhen
parseExNames :: UriMapping -> String -> [ExName]
parseExNames urm = map (parseExName urm) . words
compileElement :: XmlTree -> Template
compileElement node =
TemplElement compQName Map.empty attribSets template
where
compQName = compileComputedQName node
attribSets = UsedAttribSets $ parseExNames><node
$ fetchAttributeWDefault node xsltUseAttributeSets ""
template = compileTemplate (getChildren node)
compileAttribute :: XmlTree -> Template
compileAttribute node =
TemplAttribute (compileComputedQName node) $ compileTemplate (getChildren node)
compileText :: XmlTree -> Template
compileText = TemplText . collectTextnodes . getChildren
compileTextnode :: XmlTree -> Template
compileTextnode = TemplText . fromJust . getText
compileValueOf :: XmlTree -> Template
compileValueOf node =
TemplValueOf $ parseStringExpr><node $ fetchAttribute node xsltSelect
compileComment :: XmlTree -> Template
compileComment = TemplComment . compileTemplate . getChildren
compileProcInstr :: XmlTree -> Template
compileProcInstr node =
TemplProcInstr name content
where
name = parseAVT><node $ fetchAttribute node xsltName
content = compileTemplate $ getChildren node
compileLiteralResultElement :: XmlTree -> Template
compileLiteralResultElement node =
TemplElement compQName nsUris attribSets content
where
nsUris = extractAddUris node
compQName = LiteralQName $ fromJust $ getElemName node
attribSets = UsedAttribSets $ parseExNames><node $ attrSetsStr
attrSetsStr = fetchAttributeWDefault node xsltUseAttributeSetsLRE ""
content = TemplComposite $ attributes ++ [template]
attributes = mapMaybe (compileLREAttribute><node) $ fromJust $ getAttrl node
template = compileTemplate (getChildren node)
compileLREAttribute :: UriMapping -> XmlTree -> Maybe Template
compileLREAttribute uris node =
if isSpecial
then Nothing
else Just $ TemplAttribute (LiteralQName name) val
where
isSpecial = namespaceUri name `elem` [xsltUri, xmlnsNamespace]
name = fromJust $ getAttrName node
val = TemplValueOf $ parseAVT uris $ collectTextnodes $ getChildren node
compileApplyTempl :: XmlTree -> Template
compileApplyTempl node =
TemplApply expr mode args sorting
where
expr = liftM (parseSelect><node) $ tryFetchAttribute node xsltSelect
mode = liftM (parseExName><node) $ tryFetchAttribute node xsltMode
args = compileVariables $ filter (isElemType xsltWithParam) $ par
sorting = map compileSortKey srt
(srt,par) = partition (isElemType xsltSort) $ getChildren node
compileApplyImports :: XmlTree -> Template
compileApplyImports _node
= TemplApplyImports
compileCallTempl :: XmlTree -> Template
compileCallTempl node =
TemplCall name args
where
name = parseExName><node $ fetchAttribute node xsltName
args = compileVariables $ filter (isElemType xsltWithParam) $ getChildren node
compileTemplVariable :: XmlTree -> Template
compileTemplVariable = TemplVariable . compileVariable
compileCopy :: XmlTree -> Template
compileCopy node =
TemplCopy attribSets $ compileTemplate (getChildren node)
where
attribSets = UsedAttribSets $ parseExNames><node $ fetchAttributeWDefault node xsltUseAttributeSets ""
compileCopyOf :: XmlTree -> Template
compileCopyOf node = TemplCopyOf $ parseExpr><node $ fetchAttribute node xsltSelect
compileTemplate :: [XmlTree] -> Template
compileTemplate [node] =
if isElem node
then let elemName = fromJust $ getElemName node in
if equivQName elemName xsltMessage then compileMessage node
else if equivQName elemName xsltForEach then compileForEach node
else if equivQName elemName xsltChoose then compileChoose node
else if equivQName elemName xsltIf then compileIf node
else if equivQName elemName xsltElement then compileElement node
else if equivQName elemName xsltAttribute then compileAttribute node
else if equivQName elemName xsltText then compileText node
else if equivQName elemName xsltValueOf then compileValueOf node
else if equivQName elemName xsltComment then compileComment node
else if equivQName elemName xsltProcInstr then compileProcInstr node
else if equivQName elemName xsltApplyTemplates then compileApplyTempl node
else if equivQName elemName xsltApplyImports then compileApplyImports node
else if equivQName elemName xsltCallTemplate then compileCallTempl node
else if equivQName elemName xsltVariable then compileTemplVariable node
else if equivQName elemName xsltCopy then compileCopy node
else if equivQName elemName xsltCopyOf then compileCopyOf node
else if namespaceUri elemName == xsltUri
then error $ "xslt-element " ++ localPart elemName ++ " not allowed within this context."
else compileLiteralResultElement node
else if isText node then compileTextnode node
else
error $ "Unsupported node-type in xslt sheet: " ++ show (getNode node)
compileTemplate list = compileComposite list
assembleStylesheet :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet
assembleStylesheet xslNode imports =
CompStylesheet matchRules namedRules variables attsets strips aliases
where
(namedRules,
matchRules) = assembleRules ruleElems importedMatchRules importedNamedRules
variables = assembleVariables varElems importedVariables
attsets = assembleAttrSets attsetElems importedAttribSets
strips = assembleStrips stripElems preserveElems importedStrips
aliases = assembleAliases nsAliasElems importedAliases
(nsAliasElems, _r5) = partition (isElemType xsltNamespaceAlias) r4
(ruleElems, r4) = partition (isElemType xsltTemplate) r3
(varElems, r3) = partition (\node -> isElemType xsltVariable node || isElemType xsltParam node) r2
(attsetElems, r2) = partition (isElemType xsltAttributeSet) r1
(preserveElems, r1) = partition (isElemType xsltPreserveSpace) r0
(stripElems, r0) = partition (isElemType xsltStripSpace) $ getChildren xslNode
importedAttribSets = map getAttributeSets imports
importedVariables = map getVariables revImports
importedNamedRules = map getNamedRules revImports
importedMatchRules = concatMap getMatchRules revImports
importedStrips = concatMap getStrips revImports
importedAliases = map getAliases revImports
revImports = reverse imports
assembleRules :: [XmlTree] -> [MatchRule] -> [Map ExName NamedRule] -> (Map ExName NamedRule, [MatchRule])
assembleRules nodes importedMatches importedProcs =
(resProcs, resMatches)
where
resMatches = localMatches ++ importedMatches
localMatches = reverse $ sortBy cmp matches
cmp rulA rulB = compare (getRulePrio rulA) (getRulePrio rulB)
resProcs = Map.unions (localProcs:importedProcs)
localProcs = foldl ins Map.empty procs
ins map' rule = Map.insertWith (error $ "named-rule "++ show (getRuleName rule) ++" is already defined on this level")
(getRuleName rule) rule map'
(procs, matches) = catMaybes *** concat $ unzip $ map (compileRule importedMatches) nodes
assembleVariables :: [XmlTree] -> [(Map ExName Variable)] -> (Map ExName Variable)
assembleVariables varElems = Map.unions . (compileVariables varElems:)
assembleAttrSets :: [XmlTree] -> [Map ExName [AttributeSet]] -> Map ExName [AttributeSet]
assembleAttrSets attsetElems =
foldr (Map.unionWith (++)) localAttribSets
where
localAttribSets = foldr insertAs Map.empty
$ map compileAttributeSet attsetElems
insertAs as@(AttribSet name _ _) = Map.insertWith (++) name [as]
assembleStrips :: [XmlTree] -> [XmlTree]-> [Strips] -> [Strips]
assembleStrips stripElems preserveElems =
(localStrips :)
where
localStrips = feedStrips (concatMap compileStrips stripElems)
$ feedPreserves (concatMap compilePreserves preserveElems)
$ Map.empty
assembleAliases :: [XmlTree] -> [NSAliasing] -> NSAliasing
assembleAliases nsAliasElems =
Map.unions . (localAliases:)
where
localAliases = foldr addAlias' Map.empty nsAliasElems
addAlias' node = uncurry (addAlias><node) $ compileAlias node
compileRule :: [MatchRule] -> XmlTree -> (Maybe NamedRule, [MatchRule])
compileRule imports node =
if isNothing match && isNothing name
then error "Error: Bogus rule (xsl:template) with neither match nor name attribute is illegal"
else if isJust mode && isNothing match
then error "Error: Bogus mode attribute on none-match rule is illegal"
else if isJust priority && isNothing match
then error "Error: Bogus priority attribute on none-match rule is illegal"
else
(
liftM (\n -> NamRule n params template) name
, concat $ maybeToList $ liftM (assembleMatchRule priority mode imports params template) match
)
where
match = liftM (parseMatch><node) $ tryFetchAttribute node xsltMatch
name = liftM (parseExName><node) $ tryFetchAttribute node xsltName
priority = liftM read $ tryFetchAttribute node xsltPriority
mode = liftM (parseExName><node) $ tryFetchAttribute node xsltMode
template = compileTemplate content
params = map compileVariable paramsXml
(paramsXml, content) =
partition (isElemType xsltParam) $ getChildren node
assembleMatchRule :: Maybe Float -> Maybe ExName -> [MatchRule] -> [Variable] -> Template -> MatchExpr -> [MatchRule]
assembleMatchRule pri m imp par tmpl mtch@(MatchExpr expr) =
if isJust pri
then return $ MatRule mtch (fromJust pri) m imp par tmpl
else map expand $ splitMatchByPrio expr
where
expand (pri', mtch') = MatRule (MatchExpr mtch') pri' m imp par tmpl
compileVariables :: [XmlTree] -> Map ExName Variable
compileVariables nodes =
foldl insertVar Map.empty $ varList
where
varList = map compileVariable $ nodes
insertVar map' var = Map.insertWith (error $ "parameter or variable "++ show (getVarName var) ++" is already defined on this level")
(getVarName var) var map'
compileVariable :: XmlTree -> Variable
compileVariable node =
MkVar modus name exprOrRtf
where
modus = isElemType xsltParam node
name = parseExName><node $ fetchAttribute node xsltName
exprOrRtf = if hasAttribute node xsltSelect || null (getChildren node)
then Left $ parseExpr><node $ fetchAttributeWDefault node xsltSelect "''"
else Right $ compileTemplate $ getChildren node
compileAttributeSet :: XmlTree -> AttributeSet
compileAttributeSet node =
AttribSet name usedsets template
where
name = parseExName><node $ fetchAttribute node xsltName
usedsets = UsedAttribSets $ parseExNames><node $ fetchAttributeWDefault node xsltUseAttributeSets ""
template = compileTemplate $ filter (isElemType xsltAttribute) $ getChildren node
compileSortKey :: XmlTree -> SortKey
compileSortKey node =
SortK expr dataType order
where
expr = parseStringExpr><node $ fetchAttributeWDefault node xsltSelect "."
dataType = parseAVT><node $ fetchAttributeWDefault node xsltDataType "text"
order = parseAVT><node $ fetchAttributeWDefault node xsltOrder "ascending"
parseNTests :: UriMapping -> String -> [NTest]
parseNTests uris = map (parseNTest uris) . words
compileStrips,compilePreserves :: XmlTree -> [NTest]
compileStrips node = parseNTests><node $ fetchAttribute node xsltElements
compilePreserves = compileStrips
compileAlias :: XmlTree -> (String, String)
compileAlias node =
(fetchAttribute node xsltStylesheetPrefix, fetchAttribute node xsltResultPrefix)
prepareXSLTDocument :: XmlTree -> XmlTree
prepareXSLTDocument = expandExEx . expandNSDecls . stripStylesheet . removePiCmt
removePiCmt :: XmlTree -> XmlTree
removePiCmt = fromJustErr "XSLT: No root element" . filterTree (\n -> not (isPi n) && not (isCmt n))
expandExEx :: XmlTree -> XmlTree
expandExEx = mapTreeCtx expandExExElem ([xsltUri,xmlNamespace,xmlnsNamespace],[])
expandExExElem :: ([String], [String]) -> XNode -> (([String], [String]), XNode)
expandExExElem c@(excl, ext) node
| isElem node = ((exclAcc, extAcc), nodeNew)
| otherwise = (c, node)
where
nodeNew = setAttribute nameExcl (unwords exclAcc) $ setAttribute nameExt (unwords extAcc) node
exclAcc = exclNew ++ excl
extAcc = extNew ++ ext
exclNew = extNew ++ (parsePreList><node $ fetchAttributeWDefault node nameExcl "")
extNew = parsePreList><node $ fetchAttributeWDefault node nameExt ""
(nameExcl,
nameExt) = if (namespaceUri $ fromJust $ getElemName node) == xsltUri
then (xsltExlcudeResultPrefixes , xsltExtensionElementPrefixes )
else (xsltExlcudeResultPrefixesLRE, xsltExtensionElementPrefixesLRE)
parsePreList :: UriMapping -> String -> [String]
parsePreList uris = map (lookupPrefix uris) . words
extractAddUris :: XmlTree -> UriMapping
extractAddUris node =
(Map.filter (`notElem` exclUris))><node
where
exclUris = words $ fetchAttributeWDefault node xsltExlcudeResultPrefixesLRE ""