module XsltProcTopLevel where import HdomParser import XPath import XPathFct ( xstring ) import XsltFunctions import XsltParserFunctions import XsltDataTypes import XsltProcTemplate (processTemplElems) -- ----------------------------------------------------------------------------- -- | -- Function library type TLEProcTable = [(String, XsltTLFct)] procTableTLE :: TLEProcTable procTableTLE = [("output" , idTLFct) ,("variable" , procTLVariable) ,("import" , idTLFct) --procTLImport) ,("template" , idTLFct) --procTLTemplate) ,("template_sep" , procTLTemplate) ,("include" , idTLFct) --procTLInclude) ,("key" , procTLKey) ,("attribute-set" , procTLAttributeSet) ,("decimal-format" , procTLDecimalFormat) ,("namespace-alias" , idTLFct) ,("param" , procTLParam) ,("preserve-space" , idTLFct) --procTLPreserveSpace) ,("strip-space" , idTLFct) --procTLStripSpace) ,("preserve-space_sep" , procTLPreserveSpace) ,("strip-space_sep" , procTLStripSpace) ] -- procTLInclude, procTLPreserveSpace, procTLStripSpace und procTLTemplate -- are called directly from xslProcessStylesheet -- ----------------------------------------------------------------------------- -- | -- read and prepare information from top level elements -- 1. Parameter: TagName des zu bearbeitenden TLE, -- wenn nicht angegeben, werden alle TLE bearbeitet processTLElems :: String -> XsltEnv -> XsltResult -> XmlTrees -> XmlTrees -> XsltStat -> (XsltEnv, XsltResult) processTLElems tagName env res xmlFile _ xsltStat | null allTLElems = (xsltEnv, xsltRes) | not $ null tagName= foldl (processTLElems' tagName xsltStat) (xsltEnv, xsltRes) $ filter (isOfTLElem tagName) allTLElems | otherwise = foldl (processTLElems' tagName xsltStat) (xsltEnv, xsltRes) allTLElems where xsltEnv = env { sourceNavTree = xmlRootElem } xsltRes = res xmlRootElem = head $ getNavTree "/" $$ xmlFile allTLElems = childAxis $ ruleBody xsltStat isOfTLElem :: String -> NavTree XNode -> Bool isOfTLElem tn nt = not $ null $ hasLocalPart tn $ subtreeNT nt processTLElems' :: String -> XsltStat -> (XsltEnv,XsltResult) -> NavTree XNode -> (XsltEnv,XsltResult) processTLElems' tagName xsltStat (xsltEnv, xsltRes) nt | (null tagName) && elem (namePrefix qn) (xslNamespaces xsltEnv) = processTLXsltTag (xsltStat {currRuleNode = nt}) (xsltEnv, xsltRes) | elem (namePrefix qn) (xslNamespaces xsltEnv) = processOneTLXsltTag tagName (xsltStat {currRuleNode = nt}) (xsltEnv, xsltRes) | otherwise = (xsltEnv, xsltRes) where (XTag qn _) = dataNT nt -- | -- "spreading" processing of top level xslt elements processTLXsltTag :: XsltTLFct processTLXsltTag xsltStat (xsltEnv, xsltRes) = case (lookup (localPart qn) procTableTLE) of Nothing -> (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ [("unknown top-level - xsl-tag found: '" ++ (localPart qn) ++ "'" )] }) Just fct -> fct xsltStat (xsltEnv, xsltRes) where (XTag qn _) = dataNT $ currRuleNode xsltStat -- | -- process only one given element processOneTLXsltTag :: String -> XsltTLFct processOneTLXsltTag tagName xsltStat (xsltEnv, xsltRes) = case (lookup (tagName ++ "_sep") procTableTLE) of Nothing -> (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ [("unknown top-level - xsl-tag found: '" ++ tagName ++ "'" )] }) Just fct -> fct xsltStat (xsltEnv, xsltRes) -- ----------------------------------------------------------------------------- -- functions to process top level elements idTLFct :: XsltTLFct idTLFct _ envres = envres -- | -- processing xsl:template -- defined in XSLT section 5.3, Defining Template Rules procTLTemplate :: XsltTLFct procTLTemplate xsltStat (xsltEnv, xsltRes) | matchAtt == "" && nameAtt == "" = (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ ["xsl:template without match AND name attribute!"]}) | matchAtt == "" = mkNameRule template (mkName nameAtt) xsltStat (xsltEnv, xsltRes) | otherwise = mkRule template (mkNSName "" $ getXslAttribute "mode" xsltStat) (patternParser matchAtt) nameAtt (floatParser $ getXslAttribute "pri" xsltStat) (floatParser $ getXslAttribute "priority" xsltStat) xsltStat (xsltEnv, xsltRes) where matchAtt = getXslAttribute "match" xsltStat nameAtt = getXslAttribute "name" xsltStat template = getChildren $ subtreeNT $ currRuleNode xsltStat -- | -- processing xsl:variable -- defined in XSLT section 11.2, Values of Variables and Parameters -- and 11.4, Top-level Variables and Parameters -- -- to do: double binding on variable name must result in error procTLVariable :: XsltTLFct procTLVariable xsltStat (xsltEnv, xsltRes) | valName == "" = (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ ["no 'name' attribute given for variable-node!"]}) | select /= "" = (xsltEnv {globalVars = addVars notReplace vars valName $ head selectValue} ,xsltRes) | not $ null $ resultNodes theChildren = (xsltEnv {globalVars = addVars notReplace vars valName (XPVNode [ntree (mkRootTree [] (resultNodes theChildren))])} ,xsltRes) | null selectValue = (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ ["no result from selet-value-eval"]}) | otherwise = (xsltEnv {globalVars = addVars notReplace vars valName (XPVString "")} ,xsltRes) where vars = globalVars xsltEnv select = getXslAttribute "select" xsltStat valName = getXslAttribute "name" xsltStat theChildren = processTemplElems xsltEnv xsltStat emptyResult selectValue = [evalXPExpr (getXsltData xsltStat xsltEnv XsltGlobVar) select (1,1, currRuleNode xsltStat) ] -- | -- processing xsl:param -- defined in XSLT section 11.2, Values of Variables and Parameters -- and 11.4, Top-level Variables and Parameters -- -- to do: double binding on param name must result in error procTLParam :: XsltTLFct procTLParam xsltStat (xsltEnv, xsltRes) | paramName == "" = (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ ["no 'name' attribute given for param-node!"]}) | select /= "" = (xsltEnv {globalParam = addVars notReplace vars paramName $ head selectValue} ,xsltRes) | not $ null $ resultNodes theChildren = (xsltEnv {globalVars = addVars notReplace vars paramName (XPVNode [ntree (mkRootTree [] (resultNodes theChildren))])} ,xsltRes) | null selectValue = (xsltEnv ,xsltRes {errors = (errors xsltRes) ++ ["no result from selet-value-eval"]}) | otherwise = (xsltEnv {globalParam = addVars notReplace vars paramName (XPVString "")} ,xsltRes) where vars = globalParam xsltEnv select = getXslAttribute "select" xsltStat paramName = getXslAttribute "name" xsltStat theChildren = processTemplElems xsltEnv xsltStat emptyResult selectValue = [evalXPExpr (getXsltData xsltStat xsltEnv XsltGlobPara) select (1,1, currRuleNode xsltStat) ] -- | -- processing xsl:decimal-format -- defined in XSLT section 12.3 Number Formatting procTLDecimalFormat :: XsltTLFct procTLDecimalFormat xsltStat (xsltEnv, xsltRes) = (xsltEnv {decFormats = (decFormats xsltEnv) ++ [DecForm { formatName = mkNSName "" $ df xsltStat "name" "" ,decSep = df xsltStat "decimal-seperator" "." ,grpSep = df xsltStat "grouping-seperator" "," ,perCent = df xsltStat "percent" "%" ,perMille = df xsltStat "per-mille" "#x2030" ,zeroDigit = df xsltStat "zero-digit" "0" ,digit = df xsltStat "digit" "#" ,patternSep = df xsltStat "pattern-seperator" ";" ,infinity = df xsltStat "infinity" "Infinity" ,minusSign = df xsltStat "minus-sign" "-" ,nan = df xsltStat "NaN" "NaN" }] } , xsltRes) where df :: XsltStat -> String -> String -> String df xStat attrName str | null att = str | otherwise = att where att = getXslAttribute attrName xStat -- | -- processing xsl:attribute-set -- defined in XSLT section 7.1.4, Named Attribute Sets -- -- to do : "use-attribute-sets" attribute procTLAttributeSet :: XsltTLFct procTLAttributeSet xsltStat (xsltEnv, xsltRes) = ( xsltEnv { attSets = attribSet : (attSets xsltEnv) } ,xsltRes { resultNodes = (resultNodes xsltRes) } ) where xsltData = getXsltData xsltStat xsltEnv XsltVar nameAtt = qNameParser $ mkElemName xsltData xsltStat $ getXslAttribute "name" xsltStat --useAttSet = getXslAttribute "use-attribute-sets" xsltStat attribSet = (mkNSName (fst $ nameAtt) (snd $ nameAtt) ,map (mkAttribSet xsltData xsltStat) (getExprNodes xsltData (currRuleNode xsltStat) "attribute" (xslNamespaces xsltEnv) ) ) -- | -- helper function for procTLAttributeSet mkAttribSet :: XsltData -> XsltStat -> NavXmlTree -> XsltAttribute mkAttribSet xsltData xsltStat nt = Att { attName = mkNSName (fst $ nameAtt) (snd $ nameAtt) ,attValue = [ mkXAttrTree (snd $ nameAtt) (getChildren $ subtreeNT nt) ] } where nameAtt = qNameParser $ mkElemName xsltData xsltStat $ valueOf "name" $ subtreeNT nt -- | -- processing xsl:strip-space -- defined in XSLT section 3.4 Whitespace Stripping procTLStripSpace :: XsltTLFct procTLStripSpace xsltStat (xsltEnv, xsltRes) | null tokens = (xsltEnv , xsltRes {errors = (errors xsltRes) ++ ["no 'elements' attribute given for strip-space-node!"]}) | null pErrors = (xsltEnv {stripSpace = (stripSpace xsltEnv) ++ (mkToken stripSpaceCond tokens)} , xsltRes) | otherwise = (xsltEnv , xsltRes {errors = (errors xsltRes) ++ [pErrors]}) where tokens = nameTestsParser $ getXslAttribute "elements" xsltStat pErrors= concat $ map getSLParseError tokens -- | -- processing xsl:preserve-space -- defined in XSLT section 3.4 Whitespace Stripping procTLPreserveSpace :: XsltTLFct procTLPreserveSpace xsltStat (xsltEnv, xsltRes) | null tokens = (xsltEnv , xsltRes {errors = (errors xsltRes) ++ ["no 'elements' attribute given for preserve-space-node!"]}) | null pErrors = (xsltEnv {preserveSpace = (preserveSpace xsltEnv) ++ (mkToken preserveSpaceCond tokens)} , xsltRes) | otherwise = (xsltEnv , xsltRes {errors = (errors xsltRes) ++ [pErrors]}) where tokens = nameTestsParser $ getXslAttribute "elements" xsltStat pErrors= concat $ map getSLParseError tokens mkToken :: NavXmlTreeFilter -> [XsltStepList] -> [(Priority, QName)] mkToken _ [] = [] mkToken _ [(StepList [])] = [] mkToken condFilter [(StepList sl)] = map (mkToken' condFilter) sl mkToken _ _ = [] mkToken' :: NavXmlTreeFilter -> XsltStep -> (Priority, QName) mkToken' _ step@(XsltToken qn) = (Pri {priority = 0, importPri = 0, defPri = defPriority step}, qn) mkToken' _ _ = (initialPriority, mkNSName "" "") -- | -- processing xsl:key -- defined in XSLT section 12.2 Keys procTLKey :: XsltTLFct procTLKey xsltStat (xsltEnv, xsltRes) = ( xsltEnv { keyTable = mkKeyTab (getQName $ getXslAttribute "name" xsltStat) (getXslAttribute "use" xsltStat) $ filterPatternNT (patternParser $ getXslAttribute "match" xsltStat) $ preorderNT (sourceNavTree xsltEnv) } ,xsltRes ) -- | -- helper function for procTLKey mkKeyTab :: QName -> String -> NavXmlTrees -> [(QName, String, NavXmlTree)] mkKeyTab _ _ [] = [] mkKeyTab qn use ts = map (mkKeyTabCol qn use) ts mkKeyTabCol :: QName -> String -> NavXmlTree -> (QName, String, NavXmlTree) mkKeyTabCol qn use t = ( qn ,xPValue2String $ xstring (0 ,0, ntree emptyRoot) (convertXsltDataToXPathEnv xsltInitData) [evalXPExpr xsltInitData use (1,1, t)] ,t )