module Text.XML.HXT.XSLT.Application
( applyStylesheet
, applyStylesheetWParams
, XPathParams
)
where
import Text.XML.HXT.XSLT.Common
import Text.XML.HXT.XSLT.CompiledStylesheet
import Data.Char
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map hiding (Map)
import Data.Maybe
type XPathParams = Map ExName Expr
type VariableSet = Map ExName XPathValue
type ParamSet = VariableSet
data Context = Ctx NavXmlTree
[NavXmlTree]
Int
Int
VariableSet
VariableSet
CompiledStylesheet
(Maybe MatchRule)
Int
| CtxEmpty
ctxGetNode :: Context -> NavXmlTree
ctxGetNode CtxEmpty = error "ctxGetNode: Internal error attempt to access the empty context"
ctxGetNode (Ctx node _ _ _ _ _ _ _ _) = node
ctxGetStylesheet :: Context -> CompiledStylesheet
ctxGetStylesheet CtxEmpty = error "ctxGetStylesheet: Internal error attempt to access the empty context"
ctxGetStylesheet (Ctx _ _ _ _ _ _ stylesheet _ _) = stylesheet
ctxGetRule :: Context -> Maybe MatchRule
ctxGetRule CtxEmpty = Nothing
ctxGetRule (Ctx _ _ _ _ _ _ _ rule _) = rule
ctxSetNodes :: [NavXmlTree] -> Context -> Context
ctxSetNodes _ CtxEmpty = error "ctxSetNodes: Internal error attempt to access the empty context"
ctxSetNodes [] _ = CtxEmpty
ctxSetNodes nodes (Ctx _ _ _ _ globVars locVars cs rl rd) =
Ctx (head nodes) nodes 1 (length nodes) globVars locVars cs rl rd
ctxSetRule :: Maybe MatchRule -> Context -> Context
ctxSetRule _ CtxEmpty = error "ctxSetRule: Internal error attempt to access the empty context"
ctxSetRule rule (Ctx node nodes pos len globVars locVars cs _ rd) =
Ctx node nodes pos len globVars locVars cs rule rd
addVariableBinding :: ExName -> XPathValue -> Context -> Context
addVariableBinding name val (Ctx node nodes pos len globVars locVars cs rl rd)
= Ctx node nodes pos len globVars locVarsNew cs rl rd
where
locVarsNew = Map.insertWith (errF) name val locVars
errF = error $ "Local variable or parameter " ++ show name ++ " is already bound in this context"
addVariableBinding _ _ CtxEmpty = CtxEmpty
clearLocalVariables :: Context -> Context
clearLocalVariables CtxEmpty = CtxEmpty
clearLocalVariables (Ctx node nodes pos len globVars _ cs rl rd)
= (Ctx node nodes pos len globVars Map.empty cs rl rd)
processContext :: Context -> (Context->[XmlTree]) -> [XmlTree]
processContext CtxEmpty _f = []
processContext ctx@(Ctx _node nodeList pos len globVar locVar cs rl rd) f
| pos > len
= []
| otherwise
= f ctx ++ processContext (Ctx (nodeList!!pos) nodeList (pos+1) len globVar locVar cs rl rd) f
incRecDepth :: Context -> Context
incRecDepth CtxEmpty = CtxEmpty
incRecDepth (Ctx n nl p l gl lc cs rl rd) = Ctx n nl p l gl lc cs rl (rd+1)
recDepth :: Context -> Int
recDepth (Ctx _ _ _ _ _ _ _ _ rd) = rd
recDepth CtxEmpty = 0
evalXPathExpr :: Expr -> Context -> XPathValue
evalXPathExpr expr (Ctx node _ pos len globVars locVars _ _ _)
= filterXPath $ evalExpr (vars,[]) (pos, len, node) expr (XPVNode . singletonNodeSet $ node)
where
filterXPath (XPVError err) = error err
filterXPath xpv = xpv
vars = map (\(name, val) -> ((exUri name, exLocal name), val)) varList
varList = Map.toAscList $ locVars `Map.union` globVars
evalXPathExpr _ CtxEmpty
= error "internal error in evalXPathExpr in XSLT module"
evalRtf :: Template -> String -> Context -> XPathValue
evalRtf template rtfId ctx = XPVNode $ singletonNodeSet (ntree rtfRoot)
where
rtfRoot = setAttribute rootIdName ("rtf " ++ rtfId) $ mkRoot [] $ applyTemplate template ctx
rootIdName = mkQName "" "rootId" ""
applySelect :: SelectExpr -> Context -> [NavXmlTree]
applySelect = applySelect'
applySelect' :: SelectExpr -> Context -> [NavXmlTree]
applySelect' (SelectExpr expr) ctx =
extractNodes xpathResult
where
xpathResult = evalXPathExpr expr ctx
extractNodes (XPVNode nodes) = attributesFirst . fromNodeSet $ nodes
extractNodes r = error $ "XPATH-Expression in select or match attribute returned a value of the wrong type ("
++ take 15 (show r) ++ "...)"
attributesFirst = uncurry (++) . partition (isAttr . subtreeNT)
applyTest :: TestExpr -> Context -> Bool
applyTest (TestExpr expr) ctx = bool
where (XPVBool bool) = evalXPathExpr expr ctx
applyStringExpr :: StringExpr -> Context -> String
applyStringExpr (StringExpr expr) ctx = string
where (XPVString string) = evalXPathExpr expr ctx
applyMatch :: MatchExpr -> Context -> Bool
applyMatch (MatchExpr expr) ctx
= matchBySelect (SelectExpr expr) (ctxGetNode ctx) ctx
where
matchBySelect :: SelectExpr -> NavXmlTree -> Context -> Bool
matchBySelect _ _ CtxEmpty = False
matchBySelect expr' matchNode ctx'
| matchNode `isNotInNodeList` applySelect expr' ctx'
= matchBySelect expr' matchNode $ ctxSetNodes (maybeToList $ upNT $ ctxGetNode ctx') ctx'
| otherwise
= True
applyComputedQName :: ComputedQName -> Context -> QName
applyComputedQName (LiteralQName qName) ctx =
lookupAlias (getAliases $ ctxGetStylesheet ctx) qName
applyComputedQName (CompQName uris nameATV nsATV) ctx =
if null nsuri && not (null pref)
then mkQName pref loc $ lookupPrefix uris pref
else mkQName pref loc nsuri
where
nsuri = applyStringExpr nsATV ctx
(pref, loc) = if null loc' then ("", pref')
else (pref', tail loc')
(pref', loc') = span (/=':') $ applyStringExpr nameATV ctx
applyComposite :: Template -> Context -> [XmlTree]
applyComposite (TemplComposite templates) ctx
= concat $ reverse $ fst $ foldl applyElem ([], ctx) templates
where
applyElem :: ([[XmlTree]], Context) -> Template -> ([[XmlTree]], Context)
applyElem (nodes, ctx') (TemplVariable v) = (nodes, processLocalVariable v Map.empty ctx')
applyElem (nodes, ctx') t = (applyTemplate t ctx' : nodes, ctx')
applyComposite _ _ = []
applyForEach :: Template -> Context -> [XmlTree]
applyForEach (TemplForEach expr sorting template) ctx
= processContext sortedCtx $ applyTemplate template
where
sortedCtx = applySorting sorting ctxWOrule nodes
ctxWOrule = ctxSetRule Nothing $ ctx
nodes = applySelect expr ctx
applyForEach _ _ = []
applyChoose :: Template -> Context -> [XmlTree]
applyChoose (TemplChoose whenList) ctx
= applyWhenList whenList ctx
applyChoose _ _ = []
applyWhenList :: [When] -> Context -> [XmlTree]
applyWhenList [] _ = []
applyWhenList ((WhenPart expr template):xs) ctx
| applyTest expr ctx
= applyTemplate template ctx
| otherwise
= applyWhenList xs ctx
applyMessage :: Template -> Context -> [XmlTree]
applyMessage (TemplMessage halt template) ctx
| halt
= error $ "Message(fatal): " ++ msg
| otherwise
= []
where
msg = showTrees content
content = applyTemplate template ctx
applyMessage _ _ = []
applyElement :: Template -> Context -> [XmlTree]
applyElement (TemplElement compQName uris attribSets template) ctx =
return $ createElement name uris aliases fullcontent
where
aliases = getAliases $ ctxGetStylesheet ctx
name = applyComputedQName compQName ctx
fullcontent = applyAttribSets [] attribSets ctx ++ applyTemplate template ctx
applyElement _ _ = []
createElement :: QName -> UriMapping -> NSAliasing -> [XmlTree] -> XmlTree
createElement name uris aliases fullcontent =
mkElement name (nsAttrs ++ distinctAttribs) content
where
nsAttrs = uriMap2Attrs $ aliasUriMapping aliases uris
distinctAttribs = nubBy eqAttr $ reverse attribs
(attribs, content) = span (isAttr) fullcontent
eqAttr node1 node2 = equivQName (fromJust $ getAttrName node1) (fromJust $ getAttrName node2)
applyAttribute :: Template -> Context -> [XmlTree]
applyAttribute (TemplAttribute compQName template) ctx =
return $ mkAttr qName content
where
qName = applyComputedQName compQName ctx
content = applyTemplate template ctx
applyAttribute _ _ = []
applyText :: Template -> Context -> [XmlTree]
applyText (TemplText s) _
= [mkText s]
applyText _ _ = []
applyValueOf :: Template -> Context -> [XmlTree]
applyValueOf (TemplValueOf expr) ctx
= [mkText $ applyStringExpr expr ctx]
applyValueOf _ _ = []
applyComment :: Template -> Context -> [XmlTree]
applyComment (TemplComment content) ctx =
return $ mkCmt $ format $ collectTextnodes $ applyTemplate content ctx
where
format "" = ""
format "-" = "- "
format ('-':'-':xs) = '-':' ':format ('-':xs)
format (x:xs) = x:format xs
applyComment _ _ = []
applyProcInstr :: Template -> Context -> [XmlTree]
applyProcInstr (TemplProcInstr nameExpr template) ctx =
return $ mkPi (mkName name) [mkText . format . collectTextnodes . applyTemplate template $ ctx]
where
name = applyStringExpr nameExpr ctx
format "" = ""
format ('?':'>':xs) = '?':' ':'>':format xs
format (x:xs) = x:format xs
applyProcInstr _ _ = []
applyApplTempl :: Template -> Context -> [XmlTree]
applyApplTempl (TemplApply expr mode args sorting) ctx =
applyMatchRulesToEntireContext params rules mode sortedCtx
where
params = createParamSet args ctx
sortedCtx = applySorting sorting ctx nodes
nodes = maybe (getChildrenNT $ ctxGetNode ctx)
(flip applySelect ctx)
expr
rules = getMatchRules $ ctxGetStylesheet ctx
applyApplTempl _ _ = []
applyImports :: Template -> Context -> [XmlTree]
applyImports (TemplApplyImports) ctx=
applyMatchRules Map.empty rules mode ctx
where
rules = getRuleImports currRule
mode = getRuleMode currRule
currRule = maybe (error "apply-imports must not be called during xsl:for-each") id $ ctxGetRule ctx
applyImports _ _ = []
applyCallTempl :: Template -> Context -> [XmlTree]
applyCallTempl (TemplCall name args) ctx =
instantiateNamedRule params rule ctx
where
params = createParamSet args ctx
rule = maybe errNoRule id $ Map.lookup name rules
rules = getNamedRules $ ctxGetStylesheet ctx
errNoRule = error $ "No rule with qualified name: " ++ show name
applyCallTempl _ _ = []
applyCopy :: Template -> Context -> [XmlTree]
applyCopy (TemplCopy attrsets template) ctx
| isRoot currNode
= applyTemplate template ctx
| isElem currNode
= return $ createElement name (getUriMap currNode) Map.empty fullcontent
| otherwise
= return currNode
where
currNode = subtreeNT $ ctxGetNode ctx
name = fromJust $ getElemName currNode
fullcontent = applyAttribSets [] attrsets ctx ++ applyTemplate template ctx
applyCopy _ _ = []
applyCopyOf :: Template -> Context -> [XmlTree]
applyCopyOf (TemplCopyOf expr)
= concatMap expandRoot . xPValue2XmlTrees . evalXPathExpr expr
where
expandRoot node
| isRoot node = getChildren node
| otherwise = return node
applyCopyOf _ = const []
applyTemplate :: Template -> Context -> [XmlTree]
applyTemplate = applyTemplate'
applyTemplate' :: Template -> Context -> [XmlTree]
applyTemplate' t@(TemplComposite _) = applyComposite t
applyTemplate' t@(TemplMessage _ _) = applyMessage t
applyTemplate' t@(TemplForEach _ _ _) = applyForEach t
applyTemplate' t@(TemplChoose _) = applyChoose t
applyTemplate' t@(TemplElement _ _ _ _) = applyElement t
applyTemplate' t@(TemplAttribute _ _) = applyAttribute t
applyTemplate' t@(TemplText _) = applyText t
applyTemplate' t@(TemplValueOf _) = applyValueOf t
applyTemplate' t@(TemplComment _) = applyComment t
applyTemplate' t@(TemplProcInstr _ _) = applyProcInstr t
applyTemplate' t@(TemplApply _ _ _ _) = applyApplTempl t
applyTemplate' t@(TemplApplyImports) = applyImports t
applyTemplate' t@(TemplCall _ _) = applyCallTempl t
applyTemplate' t@(TemplCopy _ _) = applyCopy t
applyTemplate' t@(TemplCopyOf _) = applyCopyOf t
applyTemplate' (TemplVariable _) = const []
applyStylesheetWParams :: XPathParams -> CompiledStylesheet -> XmlTree -> [XmlTree]
applyStylesheetWParams inputParams cs@(CompStylesheet matchRules _ vars _ strips _) rawDoc =
map fixupNS $ applyMatchRules Map.empty matchRules Nothing ctxRoot
where
ctxRoot = Ctx docNode [docNode] 1 1 gloVars Map.empty cs Nothing 0
gloVars = Map.map (evalVariableWParamSet extParams ctxRoot) vars
extParams = Map.map (flip evalXPathExpr ctxRoot) inputParams
docNode = ntree $ expandNSDecls $ stripDocument strips rawDoc
applyStylesheet :: CompiledStylesheet -> XmlTree -> [XmlTree]
applyStylesheet = applyStylesheetWParams Map.empty
applyMatchRulesToChildren :: ParamSet -> [MatchRule] -> (Maybe ExName) -> Context -> [XmlTree]
applyMatchRulesToChildren args rules mode ctx =
applyMatchRulesToEntireContext args rules mode childCtx
where
childCtx = ctxSetNodes (getChildrenNT $ ctxGetNode ctx) ctx
applyMatchRulesToEntireContext :: ParamSet -> [MatchRule] -> Maybe ExName -> Context -> [XmlTree]
applyMatchRulesToEntireContext args rules mode ctx = processContext ctx (applyMatchRules args rules mode)
applyMatchRules :: ParamSet -> [MatchRule] -> (Maybe ExName) -> Context -> [XmlTree]
applyMatchRules _ [] mode ctx = matchDefaultRules mode ctx
applyMatchRules args (rule:rules) mode ctx =
maybe (applyMatchRules args rules mode ctx)
id
(applyMatchRule args rule mode ctx)
applyMatchRule :: ParamSet -> MatchRule -> Maybe ExName -> Context -> Maybe [XmlTree]
applyMatchRule args rule@(MatRule expr _ ruleMode _ _ _) mode ctx =
if mode==ruleMode && applyMatch expr ctx
then Just $ instantiateMatchRule args rule $ ctxSetRule (Just rule) ctx
else Nothing
instantiateMatchRule :: ParamSet -> MatchRule -> Context -> [XmlTree]
instantiateMatchRule args (MatRule _ _ _ _ params content) ctx =
applyTemplate content ctxNew
where
ctxNew = incRecDepth $ processParameters params args $ clearLocalVariables ctx
instantiateNamedRule :: ParamSet -> NamedRule -> Context -> [XmlTree]
instantiateNamedRule args (NamRule _ params content) ctx =
applyTemplate content ctxNew
where
ctxNew = incRecDepth $ processParameters params args $ clearLocalVariables ctx
matchDefaultRules :: (Maybe ExName) -> Context -> [XmlTree]
matchDefaultRules mode ctx@(Ctx ctxNavNode _ _ _ _ _ stylesheet _ _)
| isElem ctxNode
= applyMatchRulesToChildren Map.empty rules mode ctx
| isText ctxNode
= [ctxNode]
| isAttr ctxNode
= [mkText $ collectTextnodes $ getChildren ctxNode]
| otherwise
= []
where
rules = getMatchRules stylesheet
ctxNode = subtreeNT ctxNavNode
matchDefaultRules _ _ = []
processLocalVariable :: Variable -> ParamSet -> Context -> Context
processLocalVariable var@(MkVar _ name _) arguments ctx =
addVariableBinding name val ctx
where
val = evalVariableWParamSet arguments ctx var
processParameters :: [Variable] -> ParamSet -> Context -> Context
processParameters params arguments ctx
= foldl (\c v -> processLocalVariable v arguments c) ctx params
evalVariableWParamSet :: ParamSet -> Context -> Variable -> XPathValue
evalVariableWParamSet ps ctx (MkVar isPar name exprOrRtf)
| isPar
= maybe (resultFromVar exprOrRtf) id $ Map.lookup name ps
| otherwise
= resultFromVar exprOrRtf
where
resultFromVar (Left expr) = evalXPathExpr expr ctx
resultFromVar (Right rtf) = evalRtf rtf (show (recDepth ctx) ++ " " ++ show name) ctx
createParamSet :: Map ExName Variable -> Context -> ParamSet
createParamSet wParamList ctx = Map.map (evalVariableWParamSet Map.empty ctx) wParamList
applyAttribSets :: [ExName] -> UsedAttribSets -> Context -> [XmlTree]
applyAttribSets callstack (UsedAttribSets sets) ctx = concatMap (\name -> applyAllAttrSetForName callstack name ctx) sets
applyAllAttrSetForName :: [ExName] -> ExName -> Context -> [XmlTree]
applyAllAttrSetForName callstack name ctx =
if name `elem` callstack
then error $ "Attribute-Set " ++ show name ++ " is recursively used." ++
concatMap (("\n used in "++) . show) callstack
else if isNothing attrset
then error $ "No attribute set with name: " ++ show name
else concatMap (flip (applyAttribSet (name:callstack)) ctx) $ fromJust attrset
where
attrset = Map.lookup name $ getAttributeSets $ ctxGetStylesheet ctx
applyAttribSet :: [ExName] -> AttributeSet -> Context -> [XmlTree]
applyAttribSet callstack (AttribSet _ usedSets content) ctx =
applyAttribSets callstack usedSets ctx ++ applyTemplate content ctx
applySorting :: [SortKey] -> Context -> [NavXmlTree] -> Context
applySorting [] ctx nodes = ctxSetNodes nodes ctx
applySorting sortKeys ctx nodes =
ctxSetNodes resultOrder ctx
where
resultOrder = snd $ unzip sortedKVs
sortedKVs = sortBy compKV keysWVals
keysWVals = zip keys nodes
keys = map extract nodes
(extrFs, cmpFs) = unzip $ map (flip applySortKey ctx) sortKeys
extract node = map ($ ctxSetNodes [node] ctx) extrFs
compKV (k1,_) (k2,_) = compressOrds $ compares k1 k2
compares = zipWith3 (($) $) cmpFs
compressOrds = maybe EQ id . find (/=EQ)
type SortVal = Either Float String
applySortKey :: SortKey -> Context -> ( Context -> SortVal
, SortVal -> SortVal -> Ordering)
applySortKey (SortK expr typeATV orderATV) ctx
| typ /= "number"
&&
typ /= "text"
= error $ "unsupported type in xsl:sort: " ++ typ
| ordering /="ascending"
&&
ordering /="descending"
= error $ "order in xsl:sort element must be ascending or descending. Found: " ++ ordering
| otherwise
= (extractFct, cmpFct)
where
isNum = typ == "number"
isDesc = ordering == "descending"
ordering = applyStringExpr orderATV ctx
typ = applyStringExpr typeATV ctx
extractFct ctx'
= let
val = applyStringExpr expr ctx'
in
if isNum
then Left $ readWDefault (1.0 / 0.0) val
else Right val
cmpFct a
= ( if isDesc then invertOrd else id )
.
( if isNum then cmpNum a else cmpString a )
cmpNum (Left n1) (Left n2)
= compare n1 n2
cmpNum _ _
= error "internal error in cmpNum in applySortKey"
cmpString (Right s1) (Right s2)
= compare (map toLower s1) (map toLower s2)
cmpString _ _
= error "internal error in cmpString in applySortKey"
invertOrd :: Ordering -> Ordering
invertOrd EQ = EQ
invertOrd LT = GT
invertOrd GT = LT
fixupNS :: XmlTree -> XmlTree
fixupNS = compressNS . disambigNS
compressNS :: XmlTree -> XmlTree
compressNS =
mapTreeCtx compressElem $ Map.fromAscList [("xml", xmlNamespace), ("xmlns", xmlnsNamespace)]
compressElem :: UriMapping -> XNode -> (UriMapping, XNode)
compressElem uris node
| isElem node = (newUris, changeAttrl (filter $ isImportant) node)
| otherwise = (uris, node)
where
newUris = uris `Map.union` getUriMap node
isImportant n = not (isNsAttr n)
|| not ((localPart $ fromJust $ getAttrName n) `Map.member` uris)
disambigNS :: XmlTree -> XmlTree
disambigNS =
mapTreeCtx step $ Map.fromAscList [("xml", xmlNamespace), ("xmlns", xmlnsNamespace)]
where
step uris node
| isElem node = let uris' = uris `Map.union` getUriMap node
(newUris, newNode') = disambigElem uris' node in
(newUris, setUriMap newUris newNode')
| otherwise = (uris, node)
disambigElem :: UriMapping -> XNode -> (UriMapping, XNode)
disambigElem nsMap element =
(newNsMap, XTag
(remapNsName newNsMap $ fromJust $ getElemName element)
$ map (changeName $ remapNsName newNsMap) $ fromJust $ getAttrl element )
where
newNsMap = nsMap `Map.union` Map.fromAscList newTuples
newTuples = zip newPrefs $ nub newUris
newUris = filter (`notElem` oldUris) $ filter (not . null) $ map namespaceUri $ mapMaybe getName
(element : map getNode (fromJust $ getAttrl element))
newPrefs = filter (`notElem` oldPrefs) ["ns" ++ show i | i <- [(1::Int)..]]
oldPrefs = Map.keys nsMap
oldUris = Map.elems nsMap
remapNsName :: UriMapping -> QName -> QName
remapNsName nsMap name
| null nsUri
||
( isJust luUri
&&
fromJust luUri == nsUri
) = name
| otherwise = mkQName newPref (localPart name) nsUri
where
luUri = Map.lookup (namePrefix name) nsMap
newPref = head $ (++ (error $ "int. error: No prefix for " ++ show name ++ " " ++ show nsMap ++ " " ++ show luUri ++ " " ++ show nsUri))
$ Map.keys $ Map.filter (==namespaceUri name) nsMap
nsUri = namespaceUri name