hxt-xslt (empty) → 8.4.0
raw patch · 62 files changed
+3751/−0 lines, 62 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, haskell98, hxt, parsec
Files
- LICENCE +9/−0
- Setup.lhs +8/−0
- examples/Makefile +23/−0
- examples/hparser/HXmlParser.hs +170/−0
- examples/hparser/Makefile +30/−0
- examples/hparser/xslt/Makefile +56/−0
- examples/hparser/xslt/Makefile~ +65/−0
- examples/hparser/xslt/alias.xsl +16/−0
- examples/hparser/xslt/alias2.xsl +11/−0
- examples/hparser/xslt/attset.xsl +14/−0
- examples/hparser/xslt/attset_imp.xsl +17/−0
- examples/hparser/xslt/comment_pi.xsl +10/−0
- examples/hparser/xslt/copy_copy_of.xsl +38/−0
- examples/hparser/xslt/default_prio.xsl +103/−0
- examples/hparser/xslt/default_rules.xsl +31/−0
- examples/hparser/xslt/doc_level_prep.xsl +23/−0
- examples/hparser/xslt/doc_level_prep_exp.xsl +18/−0
- examples/hparser/xslt/elems_and_attrs.xsl +18/−0
- examples/hparser/xslt/empty.xml +1/−0
- examples/hparser/xslt/example2.xml +1/−0
- examples/hparser/xslt/example_document.xml +16/−0
- examples/hparser/xslt/example_document2.xml +20/−0
- examples/hparser/xslt/example_document3.xml +10/−0
- examples/hparser/xslt/exdoc2.xml +33/−0
- examples/hparser/xslt/for_each_when_if.xsl +47/−0
- examples/hparser/xslt/imp_lre.xsl +3/−0
- examples/hparser/xslt/inc_lre.xsl +3/−0
- examples/hparser/xslt/invoice.xml +5/−0
- examples/hparser/xslt/invoice.xsl +12/−0
- examples/hparser/xslt/invoiceSort.xsl +14/−0
- examples/hparser/xslt/lre.xsl +11/−0
- examples/hparser/xslt/lre_stylesheet.xsl +5/−0
- examples/hparser/xslt/match_by_for_each.xsl +21/−0
- examples/hparser/xslt/nspropXSLT.xsl +14/−0
- examples/hparser/xslt/nspropXSLTyyy.xsl +14/−0
- examples/hparser/xslt/prio.xsl +18/−0
- examples/hparser/xslt/prio_imp1.xsl +20/−0
- examples/hparser/xslt/prio_imp1_1.xsl +15/−0
- examples/hparser/xslt/prio_imp1_2.xsl +17/−0
- examples/hparser/xslt/prio_imp2.xsl +21/−0
- examples/hparser/xslt/prio_inc.xsl +15/−0
- examples/hparser/xslt/recAdd.xsl +10/−0
- examples/hparser/xslt/sorting.xsl +33/−0
- examples/hparser/xslt/stripXSLT.xsl +24/−0
- examples/hparser/xslt/strip_example.xml +21/−0
- examples/hparser/xslt/strip_example.xsl +10/−0
- examples/hparser/xslt/strip_space.xsl +8/−0
- examples/hparser/xslt/strip_space_imp.xsl +28/−0
- examples/hparser/xslt/strip_space_with_rules.xsl +48/−0
- examples/hparser/xslt/testEX.xsl +21/−0
- examples/hparser/xslt/testNS.xml +11/−0
- examples/hparser/xslt/testNS.xsl +46/−0
- examples/hparser/xslt/vars_and_params.xsl +69/−0
- examples/hparser/xslt/vars_and_params_imp.xsl +30/−0
- hxt-xslt.cabal +91/−0
- src/Text/XML/HXT/XSLT.hs +27/−0
- src/Text/XML/HXT/XSLT/Application.hs +644/−0
- src/Text/XML/HXT/XSLT/Common.hs +406/−0
- src/Text/XML/HXT/XSLT/Compilation.hs +500/−0
- src/Text/XML/HXT/XSLT/CompiledStylesheet.hs +266/−0
- src/Text/XML/HXT/XSLT/Names.hs +152/−0
- src/Text/XML/HXT/XSLT/XsltArrows.hs +310/−0
+ LICENCE view
@@ -0,0 +1,9 @@+The MIT License++Copyright (c) 2005 Uwe Schmidt, Martin Schmidt, Torben Kuseler++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/runhaskell++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ examples/Makefile view
@@ -0,0 +1,23 @@+# $Id: Makefile,v 1.15 2006/11/12 14:52:59 hxml Exp $+#+# Example Applications+#++HXT_HOME = ..++EXAMPLES = hparser+MORE_SAMPLES = +DIST = ../$(DIST_NAME)+DIST_DIR = $(DIST)/examples++all :+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i all ;)++test :+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i $@ ;)++clean :+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i $@ ;)++.PHONY : all test clean+
+ examples/hparser/HXmlParser.hs view
@@ -0,0 +1,170 @@+-- ------------------------------------------------------------++{- |+ Module : HXmlParser+ Copyright : Copyright (C) 2005 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt+ Maintainer : uwe@fh-wedel.de+ Stability : experimental+ Portability: portable++ HXmlParser - Validating XML Parser of the Haskell XML Toolbox with XSLT support++ XML well-formed checker and validator.++ this program may be used as example main program for the+ arrow API of the Haskell XML Toolbox++ commandline parameter evaluation and+ and return code is the most complicated part+ of this example application+-}++-- ------------------------------------------------------------++module Main+where++import Text.XML.HXT.Arrow+import Text.XML.HXT.XSLT ( xsltApplyStylesheetFromURI )++import System.IO -- import the IO and commandline option stuff+import System.Environment+import System.Console.GetOpt+import System.Exit++import Data.Maybe++-- ------------------------------------------------------------++-- |+-- the main program of the Haskell XML Validating Parser++main :: IO ()+main+ = do+ argv <- getArgs -- get the commandline arguments+ (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list+ [rc] <- runX (parser al src) -- run the parser arrow+ exitProg (rc >= c_err) -- set return code and terminate++-- ------------------------------------------------------------++exitProg :: Bool -> IO a+exitProg True = exitWith (ExitFailure (-1))+exitProg False = exitWith ExitSuccess++-- ------------------------------------------------------------++-- |+-- the /real/ main program+--+-- get wellformed document, validates document, propagates and check namespaces+-- and controls output++parser :: Attributes -> String -> IOSArrow b Int+parser al src+ = readDocument al src+ >>>+ ( ( traceMsg 1 "start processing document"+ >>>+ processDocument al+ >>>+ traceMsg 1 "document processing finished"+ )+ `when`+ documentStatusOk+ )+ >>>+ traceSource+ >>>+ traceTree+ >>>+ writeDocument al (fromMaybe "-" . lookup a_output_file $ al) `whenNot` hasAttr "no-output"+ >>>+ getErrStatus++-- simple example of a processing arrow++processDocument :: Attributes -> IOSArrow XmlTree XmlTree+processDocument al+ | applyXSLT+ = traceMsg 1 ("applying XSLT stylesheet " ++ show xsltUri)+ >>>+ xsltApplyStylesheetFromURI xsltUri+ | extractText+ = traceMsg 1 "selecting plain text"+ >>>+ processChildren (deep isText)+ | otherwise+ = this+ where+ applyXSLT = hasEntry "xslt" $ al+ extractText = optionIsSet "show-text" $ al+ xsltUri = lookup1 "xslt" $ al++-- ------------------------------------------------------------+--+-- the options definition part+-- see doc for System.Console.GetOpt++progName :: String+progName = "HXmlParser"+ +options :: [OptDescr (String, String)]+options+ = generalOptions+ +++ inputOptions+ +++ relaxOptions+ +++ outputOptions+ +++ [ Option "" ["xslt"] (ReqArg (att "xslt") "STYLESHEET") "STYLESHEET is the uri of the XSLT stylesheet to be applied"+ , Option "q" ["no-output"] (NoArg ("no-output", "1")) "no output of resulting document"+ , Option "x" ["show-text"] (NoArg ("show-text", "1")) "output only the raw text, remove all markup"+ ]+ +++ showOptions+ where+ att n v = (n, v)++usage :: [String] -> IO a+usage errl+ | null errl+ = do+ hPutStrLn stdout use+ exitProg False+ | otherwise+ = do+ hPutStrLn stderr (concat errl ++ "\n" ++ use)+ exitProg True+ where+ header = "HXmlParser - Validating XML Parser of the Haskell XML Toolbox with Arrow Interface\n" +++ "XML well-formed checker, DTD validator, Relax NG validator and XSLT transformer.\n\n" +++ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"+ use = usageInfo header options++cmdlineOpts :: [String] -> IO (Attributes, String)+cmdlineOpts argv+ = case (getOpt Permute options argv) of+ (ol,n,[])+ -> do+ sa <- src n+ help (lookup a_help ol) sa+ return (ol, sa)+ (_,_,errs)+ -> usage errs+ where+ src [] = return []+ src [uri] = return uri+ src _ = usage ["only one input uri or file allowed\n"]++ help (Just _) _ = usage []+ help Nothing [] = usage ["no input uri or file given\n"]+ help Nothing _ = return ()++-- ------------------------------------------------------------
+ examples/hparser/Makefile view
@@ -0,0 +1,30 @@+HXT_HOME = ../..+PKGFLAGS = +GHCFLAGS = -Wall -O2+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)++prog = ./HXmlParser++all : $(prog)++$(prog) : HXmlParser.hs+ $(GHC) --make -o $@ $<++force :+ $(GHC) --make -o $(prog) $(prog).hs++test : $(prog)+ @echo "===> run a few simple test cases with the validating parser"+ @echo "===> first see all command line options"+ $(prog) --help+ @echo+ $(MAKE) xslttest++xslttest :+ $(MAKE) -C xslt test+++clean :+ rm -f $(prog) *.o *.hi++.PHONY : all force test xslttest clean
+ examples/hparser/xslt/Makefile view
@@ -0,0 +1,56 @@+# $Id: Makefile,v 1.1 2006/11/11 15:36:03 hxml Exp $++HXT_HOME = ../../..+PKGFLAGS = +GHCFLAGS = -Wall -O2+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)++prog = ../HXmlParser+xslt = $(prog) --do-not-validate++all :+ $(MAKE) -C .. all++test :+ @echo "===> run a few simple xslt test cases with $(prog)"+ $(MAKE) test1++testcases = \+ 'strip_example.xsl strip_example.xml' \+ 'elems_and_attrs.xsl example_document.xml' \+ 'lre.xsl example_document.xml' \+ 'for_each_when_if.xsl example_document.xml' \+ 'prio.xsl example_document.xml' \+ 'default_rules.xsl example_document.xml' \+ 'vars_and_params.xsl example_document.xml' \+ 'lre_stylesheet.xsl example_document.xml' \+ 'imp_lre.xsl example_document.xml' \+ 'inc_lre.xsl example_document.xml' \+ 'comment_pi.xsl example_document.xml' \+ 'attset.xsl example_document.xml' \+ 'copy_copy_of.xsl example_document.xml' \+ 'sorting.xsl example_document.xml' \+ 'strip_space.xsl exdoc2.xml' \+ 'testEX.xsl empty.xml' \+ 'testNS.xsl testNS.xml' \+ 'default_prio.xsl example_document2.xml'++test1 :+ for tc in $(testcases) ; \+ do \+ stylesheet=$$(echo $$tc | cut -d ' ' -f 1) ; \+ input=$$(echo $$tc | cut -d ' ' -f 2) ; \+ $(xslt) --xslt=$$stylesheet --output-file=$$stylesheet.out $$input ; \+ echo "Contents of $$stylesheet.out" ; \+ echo "============================" ; \+ cat $$stylesheet.out ; \+ echo ; \+ done++stylesheets = $(wildcard *.xsl)+inputs = $(wildcard *.xml)++clean :+ rm -f *.xsl.out++.PHONY : all test test1 clean
+ examples/hparser/xslt/Makefile~ view
@@ -0,0 +1,65 @@+# $Id: Makefile,v 1.1 2006/11/11 15:36:03 hxml Exp $++HXT_HOME = ../../../..+PKGFLAGS = +GHCFLAGS = -Wall -O2+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)++DIST = $(HXT_HOME)/dist/examples/arrows/hparser+DIST_DIR = $(DIST)/xslt++prog = ../HXmlParser+xslt = $(prog) --do-not-validate++all :+ $(MAKE) -C .. all++test :+ @echo "===> run a few simple xslt test cases with $(prog)"+ $(MAKE) test1+++++testcases = \+ 'strip_example.xsl strip_example.xml' \+ 'elems_and_attrs.xsl example_document.xml' \+ 'lre.xsl example_document.xml' \+ 'for_each_when_if.xsl example_document.xml' \+ 'prio.xsl example_document.xml' \+ 'default_rules.xsl example_document.xml' \+ 'vars_and_params.xsl example_document.xml' \+ 'lre_stylesheet.xsl example_document.xml' \+ 'imp_lre.xsl example_document.xml' \+ 'inc_lre.xsl example_document.xml' \+ 'comment_pi.xsl example_document.xml' \+ 'attset.xsl example_document.xml' \+ 'copy_copy_of.xsl example_document.xml' \+ 'sorting.xsl example_document.xml' \+ 'strip_space.xsl exdoc2.xml' \+ 'testEX.xsl empty.xml' \+ 'testNS.xsl testNS.xml' \+ 'default_prio.xsl example_document2.xml'++test1 :+ for tc in $(testcases) ; \+ do \+ stylesheet=$$(echo $$tc | cut -d ' ' -f 1) ; \+ input=$$(echo $$tc | cut -d ' ' -f 2) ; \+ $(xslt) --xslt=$$stylesheet --output-file=$$stylesheet.out $$input ; \+ echo "Contents of $$stylesheet.out" ; \+ echo "============================" ; \+ cat $$stylesheet.out ; \+ echo ; \+ done++stylesheets = $(wildcard *.xsl)+inputs = $(wildcard *.xml)++dist :+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)+ cp $(EX) Makefile $(stylesheets) $(inputs) $(DIST_DIR)++clean :+ rm -f *.xsl.out+
+ examples/hparser/xslt/alias.xsl view
@@ -0,0 +1,16 @@+<xsl:transform + xml:space="preserve" + version="1.0" + xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns:axsl="http://xsldude.org" > + + <xsl:namespace-alias stylesheet-prefix="axsl" result-prefix="xsl" /> + + <xsl:template match="/"> + <axsl:transform version="1.0"> + <axsl:template match="/"> + <axsl:message>This XSL stylesheet is created from literal result elements</axsl:message> + </axsl:template> + </axsl:transform> + </xsl:template> +</xsl:transform>
+ examples/hparser/xslt/alias2.xsl view
@@ -0,0 +1,11 @@+<xsl:transform version = "1.0" + xmlns:xsl = "http://www.w3.org/1999/XSL/Transform" + xmlns:axsl = "http://xsldude.org" > + + <xsl:namespace-alias stylesheet-prefix="axsl" result-prefix="xsl" /> + + <xsl:template match="/" > + <lre-stylesheet axsl:version="1.0" /> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/attset.xsl view
@@ -0,0 +1,14 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:import href="attset_imp.xsl" /> + +<xsl:attribute-set name="as1"> + <xsl:attribute name="att1">att1GLOB1</xsl:attribute> + <xsl:attribute name="att1_1">att1_1Glob1</xsl:attribute> +</xsl:attribute-set> + +<xsl:attribute-set name="as1"> + <xsl:attribute name="att1">att1GLOB2</xsl:attribute> +</xsl:attribute-set> + +</xsl:transform>
+ examples/hparser/xslt/attset_imp.xsl view
@@ -0,0 +1,17 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:attribute-set name="as1"> + <xsl:attribute name="att1">att1Loc1</xsl:attribute> + <xsl:attribute name="att1_1">att1_1Loc1</xsl:attribute> + <xsl:attribute name="att1_2">att1_2Loc1</xsl:attribute> +</xsl:attribute-set> + +<xsl:attribute-set name="as2" use-attribute-sets = "as1"> + <xsl:attribute name="att2">att2Loc1</xsl:attribute> +</xsl:attribute-set> + +<xsl:template match="/"> + <LRE xsl:use-attribute-sets="as2" kyr="bar" kar="bra" kur="rab"/> +</xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/comment_pi.xsl view
@@ -0,0 +1,10 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <!-- XALAN will insert an extra newline after the processing instruction. Therefore the output-files differ. --> + <xsl:template match="/"> + <result> + <xsl:comment>simple-comment</xsl:comment> + <xsl:comment>-c=a-b -------------</xsl:comment> + <xsl:processing-instruction name="secret_instruction_{1+1}">pi-content?></xsl:processing-instruction> + </result> + </xsl:template> +</xsl:transform>
+ examples/hparser/xslt/copy_copy_of.xsl view
@@ -0,0 +1,38 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:variable name="V" select="."/> + + <xsl:attribute-set name="as"> + <xsl:attribute name="name"><xsl:value-of select="name()"/></xsl:attribute> + + </xsl:attribute-set> + + <xsl:template match="/"> + <result> + + === copy-of of /: + <xsl:copy-of select = "."/> + + === copy-of of /: with variable V + <xsl:copy-of select = "$V"/> + + === copy on /: + <xsl:copy/> + ...should've been empty + + copy recursively: + + <xsl:apply-templates mode="copy"/> + + </result> + </xsl:template> + + <xsl:template match="@*|node()" mode="copy"> + <xsl:copy use-attribute-sets="as"> + <xsl:apply-templates select="node()|@*" mode="copy" /> + </xsl:copy> + </xsl:template> + + +</xsl:transform> +
+ examples/hparser/xslt/default_prio.xsl view
@@ -0,0 +1,103 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <!-- Some work-arounds for errors of in the XPath module: + - you can select text() nodes below an attribute node, which is illegal (, no matter how HXT treats attributes internally) + - the body of a processing instruction is not selected with ".". + - FIXED: ns:* matches everything, regardless of namespaces or even prefixes. + - FIXED: root is treated as an element (matches *)(FIXED) AND has the name() "/" instead of "" (FIXED), both illegal. + --> + + + <xsl:template match="/"> + <result> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.5 /'" /></xsl:call-template> + </result> + </xsl:template> + + <xsl:template match="/" priority="0.4"> + <result> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.4 /'" /></xsl:call-template> + </result> + </xsl:template> + + <xsl:template match="/document"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.5 a'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="document"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.0'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="document[self::*]"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.5 b'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="*"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.5'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="@*"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.5'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="text()" priority="-0.4"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.4'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="text()"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.5'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="processing-instruction('Milk')"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.0'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="processing-instruction()"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.5'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="comment()"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.5'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="comment()" priority="-0.6"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.6'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="/document/element_type2/nested_element"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.5 a'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="element_type2/nested_element"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.5 b'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="ns:*" xmlns:ns="http://ns.org"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'-0.25'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="element_type3/@nr"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.5'" /></xsl:call-template> + </xsl:template> + + <xsl:template match="@nr"> + <xsl:call-template name="printMatch"><xsl:with-param name="prio" select="'0.0'" /></xsl:call-template> + </xsl:template> + + <xsl:template name="printMatch"> + <xsl:param name="prio" /> + Match <xsl:choose> + <xsl:when test="self::*">element <xsl:value-of select="name()"/></xsl:when> + <xsl:when test="self::text()">textnode length <xsl:value-of select="string-length(.)"/> "<xsl:value-of select="."/>"</xsl:when> + <xsl:when test="self::comment()">comment node: <xsl:value-of select="."/></xsl:when> + <xsl:when test="self::processing-instruction()">pi node: <xsl:value-of select="name()"/></xsl:when> + <xsl:when test="not(name())">root-node</xsl:when> + <xsl:otherwise>attribute <xsl:value-of select="name()"/></xsl:otherwise> + </xsl:choose> with priority <xsl:value-of select="$prio" /> name : |<xsl:value-of select="name()"/>| + <!-- <xsl:for-each select="@*|@*">attribute: <xsl:value-of select="name()"/> <xsl:text> </xsl:text></xsl:for-each> --> + <xsl:apply-templates select="@*|*|text()|comment()|processing-instruction()|node()" > + <xsl:sort select="name()" /> + </xsl:apply-templates> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/default_rules.xsl view
@@ -0,0 +1,31 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:template match="/"> + <result> + <xsl:apply-templates/> + </result> + </xsl:template> + + <xsl:template match="/" priority="0.5"> + <resultXXX> + <xsl:apply-templates/> + </resultXXX> + </xsl:template> + + + <xsl:template match="nested_element"> + <nested_element_matched> + Attributes matched with default rules: + <xsl:apply-templates select="@*"/> + + + Attributes matched with default rules in mode m: + <xsl:apply-templates select="@*" mode="m"/> + + Match content with default rules + <xsl:apply-templates/> + + </nested_element_matched> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/doc_level_prep.xsl view
@@ -0,0 +1,23 @@+<xsl:transform version="1.0" + xml:space="preserve" + xmlns:unused="unused.org" + xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns:extension="extension.org" + extension-element-prefixes="extension" + xmlns:ns1="ns1.org"> + + <xsl:template match="*" xml:space="preserve" +> + <xsl:element name="result"> + <ns1:result/> + <xsl:call-template name="procedure" /> + </xsl:element> + </xsl:template> + + <xsl:template name="procedure" xmlns:ns2="ns2.org"> + <ns2:result xsl:exclude-result-prefixes="ns1"> + <inner/> + </ns2:result> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/doc_level_prep_exp.xsl view
@@ -0,0 +1,18 @@+<xsl:transform version="1.0" + xml:strip-space="preserve" + xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns:extension="extension.org" + extension-element-prefixes="extension" + xmlns:ns1="ns1.org"> + + <xsl:template match="*"> + <ns1:result/> + </xsl:template> + + <xsl:template name="procedure" + exclude-result-prefixes="ns1" + xmlns:ns2="ns2.org"> + <ns2:result/> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/elems_and_attrs.xsl view
@@ -0,0 +1,18 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:template match="/"> + <xsl:element name="result"> + <xsl:attribute name="attr">value</xsl:attribute> + + <xsl:element name="nested_{-2+3}"> + <xsl:attribute name="attr_nested"> + <xsl:value-of select="concat('value ',-5+4*4)" /> + <xsl:text>still within attr</xsl:text> + </xsl:attribute> + <xsl:text>textnode</xsl:text> + </xsl:element> + + </xsl:element> +</xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/empty.xml view
@@ -0,0 +1,1 @@+<empty/>
+ examples/hparser/xslt/example2.xml view
@@ -0,0 +1,1 @@+<e a1="" a2="" a3="" a4=""/>
+ examples/hparser/xslt/example_document.xml view
@@ -0,0 +1,16 @@+<document order="descending"> + some text + <element_type1 nr="1"/> + <element_type2> + <nested_element nested_element_attrib="nested_element_attrib_value"> + some more text<X/> + </nested_element> + </element_type2> + <element_type1 nr="2" /> + <element_type1 nr="3" /> + <element_type1 nr="4" /> + <element_type1 nr="-1" /> + <element_type3 brot=""/> + <element_type3 kaese=""/> + <element_type3 milch=""/> +</document>
+ examples/hparser/xslt/example_document2.xml view
@@ -0,0 +1,20 @@+<document order=""> + some text + <element_type1 nr=""/> + <element_type2> + <nested_element nested_element_attrib=""> + some more text<X/> + </nested_element> + </element_type2> + <ns:element_typeNS xmlns:ns="http://ns.org" /> + <element_type1 nr="" /> + <element_type1 nr="" /> + <element_type1 nr="" /> + <element_type1 nr="" /> + <element_type3 brot=""/> + <element_type3 kaese=""/> + <!-- Milk is good for you! --> + <?Milk /opt1 /opt2 /opt3 ?> + <?Bread with cheese, or maybe not? ?> + <element_type3 milch="" nr=""/> +</document>
+ examples/hparser/xslt/example_document3.xml view
@@ -0,0 +1,10 @@+<document> + <a> + <b/> + <c/> + </a> + <d> + <b/> + <e/> + </d> +</document>
+ examples/hparser/xslt/exdoc2.xml view
@@ -0,0 +1,33 @@+<document order="descending"> + some text + <element_type1 nr="1"/> + <element_type2> + <nested_element nested_element_attrib="nested_element_attrib_value"> + some more text<X/><!-- DUDE DUDE--> + </nested_element> + </element_type2> + <element_type1 nr="2" /> + <element_type1 nr="3" /> + <element_type1 nr="4" /> + <element_type1 nr="-1" /> + <element_type3 brot=""/> + <element_type3 kaese=""/> + <spacy-elem> + + <X/> + + + <Y/> + + . + + <Z/> + + <spacy-elem2> + + + </spacy-elem2> + + </spacy-elem> + <element_type3 milch=""/> +</document>
+ examples/hparser/xslt/for_each_when_if.xsl view
@@ -0,0 +1,47 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:template match="/"> + <result> + <xsl:for-each select="*/element_type1"> + Nr:<xsl:value-of select="@nr"/>: + + with if: + + <xsl:if test="@nr>3"> Number is larger than 3 + </xsl:if> + + <xsl:if test="@nr>2"> Number is larger than 2 + </xsl:if> + + <xsl:if test="@nr>1"> Number is larger than 1 + </xsl:if> + + <xsl:if test="@nr>0"> Number is larger than 0 + </xsl:if> + + with choose: + + <xsl:choose> + + <xsl:when test="@nr>3"> Number is larger than 3 + </xsl:when> + + <xsl:when test="@nr>2"> Number is larger than 2 + </xsl:when> + + <xsl:when test="@nr>1"> Number is larger than 1 + </xsl:when> + + <xsl:when test="@nr>0"> Number is larger than 0 + </xsl:when> + + <xsl:otherwise> Number is smaller than 1 + </xsl:otherwise> + + </xsl:choose> + + </xsl:for-each> + </result> +</xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/imp_lre.xsl view
@@ -0,0 +1,3 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> +<xsl:import href="lre_stylesheet.xsl"/> +</xsl:transform>
+ examples/hparser/xslt/inc_lre.xsl view
@@ -0,0 +1,3 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> +<xsl:include href="lre_stylesheet.xsl"/> +</xsl:transform>
+ examples/hparser/xslt/invoice.xml view
@@ -0,0 +1,5 @@+<invoice> + <item name="Steam-hammer HXT 6.1" value="145.75" /> + <item name="Electric screwdriver GHC 6.4" value="69.49" /> + <item name="Medium sized screws 1000 pack" value="15.98" /> +</invoice>
+ examples/hparser/xslt/invoice.xsl view
@@ -0,0 +1,12 @@+<html xsl:version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <body> + <table> + <xsl:for-each select="*/item"> + <tr> + <td><xsl:value-of select="@name"/></td> + <td><xsl:value-of select="@value"/></td> + </tr> + </xsl:for-each> + </table> + </body> +</html>
+ examples/hparser/xslt/invoiceSort.xsl view
@@ -0,0 +1,14 @@+<html xsl:version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <body> + <table> + <xsl:for-each select="*/item"> + <xsl:sort select="@value" data-type="number" order="descending"/> + <xsl:sort select="@name"/> + <tr> + <td><xsl:value-of select="@name"/></td> + <td><xsl:value-of select="@value"/></td> + </tr> + </xsl:for-each> + </table> + </body> +</html>
+ examples/hparser/xslt/lre.xsl view
@@ -0,0 +1,11 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:template match="/"> + <result attr="value"> + <nested_1 attr_nested="value is {{{1+1}}} ({1+1}) :-}} :-{{)"> + textnode + </nested_1> + </result> +</xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/lre_stylesheet.xsl view
@@ -0,0 +1,5 @@+<literalResult xsl:version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <xsl:for-each select="document/*"> + <element name="{name()}" /> + </xsl:for-each> +</literalResult>
+ examples/hparser/xslt/match_by_for_each.xsl view
@@ -0,0 +1,21 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:template match="document"> + <xsl:for-each select="*/*"> + <xsl:choose> + <xsl:when test="self::b[parent::a[not (parent::*)]]"> + Match: a/b + </xsl:when> + <xsl:when test="self::b"> + Match: b + </xsl:when> + <xsl:when test="self::*"> + Match: * + </xsl:when> + <xsl:otherwise> + Match: the rest + </xsl:otherwise> + </xsl:choose> + </xsl:for-each> + </xsl:template> +</xsl:transform>
+ examples/hparser/xslt/nspropXSLT.xsl view
@@ -0,0 +1,14 @@+<!-- Works only if we allow XPath to select xmlns:* attributes... --> +<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:template match="*"> + <xsl:param name="nsattrs" select="@xmlns:*"/> + <xsl:copy> + <xsl:copy-of select="@*|$nsattrs|@xmlns:*"/> + <xsl:apply-templates> + <xsl:with-param name="nsattrs" select="$nsattrs|@xmlns:*" /> + </xsl:apply-templates> + </xsl:copy> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/nspropXSLTyyy.xsl view
@@ -0,0 +1,14 @@+<!-- Works only if we allow XPath to select xmlns:* attributes... --> +<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:template match="*"> + <xsl:param name="nsattrs" select="@xsl:*"/> + <xsl:copy> + <xsl:copy-of select="@*|$nsattrs|@xsl:*"/> + <xsl:apply-templates> + <xsl:with-param name="nsattrs" select="$nsattrs|@xsl:*" /> + </xsl:apply-templates> + </xsl:copy> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/prio.xsl view
@@ -0,0 +1,18 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + + <xsl:import href="prio_imp1.xsl"/> + <xsl:import href="prio_imp2.xsl"/> + + <xsl:template match="element_type3"> + unreachable prio.xsl match_element_type3 occurance 2 (before include) + </xsl:template> + + <xsl:include href="prio_inc.xsl"/> + + <xsl:template match="nested_element"> + prio.xsl match_nested_element occurance 2 (after include) =====6= + </xsl:template> + + +</xsl:transform>
+ examples/hparser/xslt/prio_imp1.xsl view
@@ -0,0 +1,20 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> +<xsl:import href="prio_imp1_1.xsl"/> +<xsl:import href="prio_imp1_2.xsl"/> + +<xsl:template match="document"> + unreachable (prio_imp1.xsl) match_document +</xsl:template> + + <xsl:template match="element_type2"> + prio_imp1.xsl match_element_type2 =====4= + <xsl:apply-imports/> + </xsl:template> + + + <xsl:template match="text()"> + <xsl:call-template name="handleText"/> + </xsl:template> + + +</xsl:transform>
+ examples/hparser/xslt/prio_imp1_1.xsl view
@@ -0,0 +1,15 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:template match="/"> + <result> + prio_imp1_1.xsl match / =====1= + <xsl:apply-templates /> + </result> +</xsl:template> + +<xsl:template match="document"> + unreachable (prio_imp1_1.xsl) match_document +</xsl:template> + + +</xsl:transform>
+ examples/hparser/xslt/prio_imp1_2.xsl view
@@ -0,0 +1,17 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:template match="document"> + unreachable (prio_imp1_2.xsl) match_document +</xsl:template> + + <xsl:template match="element_type2"> + prio_imp1_2.xsl match_element_type2 =====5= + <xsl:apply-templates/> + </xsl:template> + +<xsl:template name="handleText">[TXT] +</xsl:template> + + + +</xsl:transform>
+ examples/hparser/xslt/prio_imp2.xsl view
@@ -0,0 +1,21 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:template match="document" priority="2.0"> + unreachable prio_imp2.xsl match_document Prio 2.0 occurance 1 +</xsl:template> +<xsl:template match="document" priority="2.0"> + prio_imp2.xsl match_document Prio 2.0 occurance 2 =====2= + <xsl:apply-templates/> +</xsl:template> +<xsl:template match="document" priority="1.0"> + unreachable prio_imp2.xsl match_document Prio 1.0 occurance 1 +</xsl:template> +<xsl:template match="document" priority="1.0"> + unreachable prio_imp2.xsl match_document Prio 1.0 occurance 2 +</xsl:template> + + + + + +</xsl:transform>
+ examples/hparser/xslt/prio_inc.xsl view
@@ -0,0 +1,15 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <xsl:template match="element_type2"> + prio_inc.xsl match_element_type2 =====3= + <xsl:apply-imports/> + </xsl:template> + + <xsl:template match="nested_element"> + prio_inc.xsl match_nested_element occurance 1 + </xsl:template> + + <xsl:template match="element_type3"> + prio_inc.xsl match_element_type3 occurance 2 (after being included) =====7= + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/recAdd.xsl view
@@ -0,0 +1,10 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <xsl:template match="/|*"> + <xsl:copy use-attribute-sets="as"> + <xsl:apply-templates/> + </xsl:copy> + </xsl:template> + <xsl:attribute-set name="as"> + <xsl:attribute name="processed">TRUE</xsl:attribute> + </xsl:attribute-set> +</xsl:transform>
+ examples/hparser/xslt/sorting.xsl view
@@ -0,0 +1,33 @@+<?xml version="1.0" ?> +<?karl version="1.0" ?> +<!-- comment axg f --> +<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:variable name="V" select="'ascending'"/> + + <xsl:template match="/"> + <result> + Using for-each: + <xsl:for-each select = "*/*"> + <xsl:sort select="name()" order="{document/@order}"/> + <xsl:sort select="@nr" data-type="number"/> + :<xsl:copy-of select="." /> + </xsl:for-each> + Using apply-template + <xsl:apply-templates select="*/*" mode="copy"> + <xsl:sort select="@nr" data-type="number" order="descending"/> + <xsl:sort select="name()" order="{$V}"/> + <xsl:with-param name="p" select="concat('value_',document/@order)"/> + </xsl:apply-templates> + </result> + </xsl:template> + + <xsl:template match="*" mode="copy"> + <xsl:param name="p"/> + Param p: <xsl:value-of select="$p"/> + <xsl:copy-of select="."/> + </xsl:template> + + +</xsl:transform> +
+ examples/hparser/xslt/stripXSLT.xsl view
@@ -0,0 +1,24 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + + <xsl:template match="*"> + <xsl:param name="strip" select="true()"/> + <xsl:copy> + <xsl:copy-of select="@*"/> + <xsl:apply-templates> + <xsl:with-param name="strip" + select=" ( local-name()!='text' or + namespace-uri()!='http://www.w3.org/1999/XSL/Transform' ) + and not(@xml:space='preserve') + and ($strip or @xml:space='default') "/> + </xsl:apply-templates> + </xsl:copy> + </xsl:template> + + <xsl:template match="text()"> + <xsl:param name="strip" select="true()"/> + <xsl:if test="not($strip) or string-length(normalize-space(.)) > 0"> + <xsl:value-of select="." /> + </xsl:if> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/strip_example.xml view
@@ -0,0 +1,21 @@+<stuff:document xmlns:text="http://text.org" xmlns:stuff="http://stuff.org"> +<stuff:something> +<text:chapter> + +<text:paragraph> + + +<stuff:reference> </stuff:reference> +</text:paragraph> + + + +</text:chapter> +</stuff:something> + +<text:quotation> + + + +</text:quotation> +</stuff:document>
+ examples/hparser/xslt/strip_example.xsl view
@@ -0,0 +1,10 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" xmlns:text="http://text.org"> + +<xsl:strip-space elements="*" /> +<xsl:preserve-space elements="text:*" /> + +<xsl:template match="/"> + <xsl:copy-of select="/" /> +</xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/strip_space.xsl view
@@ -0,0 +1,8 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:import href="strip_space_imp.xsl"/> + +<xsl:strip-space elements="element_type2" /> +<xsl:preserve-space elements="spacy-elem2" /> + +</xsl:transform>
+ examples/hparser/xslt/strip_space_imp.xsl view
@@ -0,0 +1,28 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:strip-space elements="spacy-elem spacy-elem2" /> + +<xsl:template match="/"> + <Element xml:space="preserve" > + <Nested1> + + + </Nested1> + <Nested2 xml:space="default"> + + + <xsl:text> </xsl:text> + + </Nested2> + <!-- There is an error in _XALAN_ on the following line. "space" will be treated as "xml:space" which is wrong! + + <Nested3 space="default"> </Nested3> + --> + <Nested4> </Nested4> + + + <xsl:copy-of select="document" /> + </Element> +</xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/strip_space_with_rules.xsl view
@@ -0,0 +1,48 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<!-- <xsl:strip-space elements="element_type2" /> --> + + +<xsl:template match="element_type2" mode="strip-space"> + <xsl:copy> + <xsl:copy-of select="@*" /> + <xsl:apply-templates mode="strip-space"> + <xsl:with-param name="strip" select="true()" /> + </xsl:apply-templates> + </xsl:copy> +</xsl:template> + + +<xsl:template match="*|/" mode="strip-space" priority="-1000"> + <xsl:copy> + <xsl:copy-of select="@*" /> + <xsl:apply-templates mode="strip-space"/> + </xsl:copy> +</xsl:template> + +<xsl:template match="text()" mode="strip-space"> + <xsl:param name="strip" select="false()"/> + <xsl:choose> + <xsl:when test="$strip and normalize-space()=''"> + </xsl:when> + <xsl:otherwise> + <xsl:copy/> + </xsl:otherwise> + </xsl:choose> +</xsl:template> + +<xsl:template match="processing-instruction()|comment()" mode="strip-space"> + <xsl:copy /> +</xsl:template> + + +<xsl:template match="/"> +===================1) + <xsl:copy-of select="document" /> +===================2) + <xsl:apply-templates mode="strip-space" /> + +</xsl:template> + + +</xsl:transform>
+ examples/hparser/xslt/testEX.xsl view
@@ -0,0 +1,21 @@+<xsl:transform + version="1.0" + xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns:a="a.uri" + xmlns:b="b.uri" + xmlns:c="c.uri" + xmlns:d="d.uri" + xmlns:e="e.uri" + xmlns:f="f.uri" + exclude-result-prefixes="a b" + extension-element-prefixes="c" xml:space="preserve" > + + + + <xsl:template match="*"> + <result exclude-result-prefixes="d" ><!-- Tricky NOT xsl:... --> + <inner xsl:extension-element-prefixes="e" xsl:exclude-result-prefixes="f" xmlns:g="g.uri"/> + </result> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/testNS.xml view
@@ -0,0 +1,11 @@+<lonely xmlns:cheese = "http://cheese.org"> + + <cheese:brie/> + + <bread:toast cheese:cheddar="" xmlns:bread="http://bread.org"/> + + <canape:baguette xmlns:canape="http://bread.org"> + <cheese:camembert/> + </canape:baguette> + +</lonely>
+ examples/hparser/xslt/testNS.xsl view
@@ -0,0 +1,46 @@+<xsl:transform + version="1.0" + xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns:xslcheese = "http://cheese.org" + xmlns:xslbread = "http://bread.org"> + + <xsl:template match="xslbread:toast"> + xsl:template match="xslbread:toast" + <xsl:apply-templates select="@*" /> + <xsl:apply-templates select="*" /> + </xsl:template> + + <xsl:template match="xslcheeseX:camembert" xmlns:xslcheeseX="http://cheese.org"> + xsl:template match="xslcheeseX:camembert" xmlns:xslcheeseX="http://cheese.org" + <xsl:apply-templates select="@*" /> + <xsl:apply-templates select="*" /> + </xsl:template> + + <xsl:template match="@xslcheese:*"> + xsl:template match="@xslcheese:*" + </xsl:template> + + + + <xsl:template match="xslcheese:*"> + xsl:template match="xslcheese:*" + <xsl:apply-templates select="@*" /> + <xsl:apply-templates select="*" /> + </xsl:template> + + <xsl:template match="*" xml:space="preserve"> + <result> + xsl:template match="*" + <xsl:apply-templates select="@*" /> + <xsl:apply-templates select="*" /> + <xsl:element name="no-ns-name" /> + <xsl:element name="xslcheese:ns-name" xmlns:useless="useless.uri"/> + <xsl:element name="cheese:ns-name" xmlns:cheese="http://cheese.org" /> + <xsl:element name="newns:ns-name" xmlns:newns="http://latest.org" /> + <xsl:element name="computed:ns-name" namespace="http://computed_{1+1-1}.org" /> + + + </result> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/vars_and_params.xsl view
@@ -0,0 +1,69 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + +<xsl:import href="vars_and_params_imp.xsl" /> + +<xsl:variable name="A" select="concat('global var A refers to:',$C)" /> +<xsl:param name="B" select="concat('global par B',*/*/@nr)" /> +<xsl:variable name="C" select="concat('global var C refers to:',$B)" /> + +<xsl:template match="/"> + <template_match_root> + + Value of variable A:<xsl:value-of select="$A"/>: + Value of variable B:<xsl:value-of select="$B"/>: + Value of variable C:<xsl:value-of select="$C"/>: + + Introducing local variable B... + <xsl:variable name="B" select="'local B'"/> + Value of variable A:<xsl:value-of select="$A"/>: + Value of variable B:<xsl:value-of select="$B"/>: + Value of variable C:<xsl:value-of select="$C"/>: + + Setting variable C to default + <xsl:variable name="C"/> + Value of variable A:<xsl:value-of select="$A"/>: + Value of variable B:<xsl:value-of select="$B"/>: + Value of variable C:<xsl:value-of select="$C"/>: + + <xsl:apply-templates select="document"> + <xsl:with-param name="P1"/> + <xsl:with-param name="P2" select="'passed argument 2'"/> + <xsl:with-param name="Punknown" select="'unreachable'"/> + </xsl:apply-templates> + </template_match_root> +</xsl:template> + + <xsl:template match="document"> + <xsl:param name="P1" select="'default for P1'" /> + <xsl:param name="P2" select="'you will never see me'"/> + <xsl:param name="P3" select="concat('current-name:',name())"/> + <xsl:param name="P4" select="concat('P4 depends on P2 :',$P2,': but not the other way around')"/> + + <template_match_document> + + Value of variable A:<xsl:value-of select="$A"/>: + Value of variable B:<xsl:value-of select="$B"/>: + Value of variable C:<xsl:value-of select="$C"/>: + + Value of parameter P1:<xsl:value-of select="$P1"/>: + Value of parameter P2:<xsl:value-of select="$P2"/>: + Value of parameter p3:<xsl:value-of select="$P3"/>: + Value of parameter p3:<xsl:value-of select="$P4"/>: + + <xsl:apply-imports/> + + </template_match_document> + </xsl:template> + + <xsl:template name="function"> + <xsl:param name="depth" select="0"/> + <xsl:element name="function_{$depth}"> + <xsl:if test="$depth > 0"> + <xsl:call-template name="function"> + <xsl:with-param name="depth" select="$depth - 1"/> + </xsl:call-template> + </xsl:if> + </xsl:element> + </xsl:template> + +</xsl:transform>
+ examples/hparser/xslt/vars_and_params_imp.xsl view
@@ -0,0 +1,30 @@+<xsl:transform version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> +<!-- Import-file for var_and_params_imp.xsl --> + + <xsl:template match="document"> + <xsl:param name="P1" select="'imported P1'" /> + <xsl:param name="P2" select="'imported P2'" /> + <xsl:param name="P3" select="'imported P3'" /> + <xsl:param name="P4" select="'imported P4'" /> + + <template_match_document_imported> + + Value of variable A:<xsl:value-of select="$A"/>: + Value of variable B:<xsl:value-of select="$B"/>: + Value of variable C:<xsl:value-of select="$C"/>: + + Value of parameter P1:<xsl:value-of select="$P1"/>: + Value of parameter P2:<xsl:value-of select="$P2"/>: + Value of parameter p3:<xsl:value-of select="$P3"/>: + Value of parameter p3:<xsl:value-of select="$P4"/>: + + <xsl:call-template name="function"> + <xsl:with-param name="depth" select="5"/> + </xsl:call-template> + + </template_match_document_imported> + </xsl:template> + + + +</xsl:transform>
+ hxt-xslt.cabal view
@@ -0,0 +1,91 @@+-- arch-tag: Haskell XML Toolbox XSLT Module+name: hxt-xslt+version: 8.4.0+license: OtherLicense+license-file: LICENCE+maintainer: Uwe Schmidt <uwe@fh-wedel.de>+stability: stable+category: XML+synopsis: The XSLT modules for HXT.+description: The Haskell XML Toolbox XSLT library. Since version 8.4 this library is packed in a separate package.+homepage: http://www.fh-wedel.de/~si/HXmlToolbox/index.html+copyright: Copyright (c) 2005-2010 Uwe Schmidt+build-type: Simple+cabal-version: >=1.6++extra-source-files:+ examples/hparser/HXmlParser.hs+ examples/hparser/Makefile + examples/hparser/xslt/alias2.xsl+ examples/hparser/xslt/alias.xsl+ examples/hparser/xslt/attset_imp.xsl+ examples/hparser/xslt/attset.xsl+ examples/hparser/xslt/comment_pi.xsl+ examples/hparser/xslt/copy_copy_of.xsl+ examples/hparser/xslt/default_prio.xsl+ examples/hparser/xslt/default_rules.xsl + examples/hparser/xslt/doc_level_prep_exp.xsl+ examples/hparser/xslt/doc_level_prep.xsl+ examples/hparser/xslt/elems_and_attrs.xsl+ examples/hparser/xslt/empty.xml+ examples/hparser/xslt/example2.xml+ examples/hparser/xslt/example_document2.xml+ examples/hparser/xslt/example_document3.xml+ examples/hparser/xslt/example_document.xml+ examples/hparser/xslt/exdoc2.xml+ examples/hparser/xslt/for_each_when_if.xsl+ examples/hparser/xslt/imp_lre.xsl+ examples/hparser/xslt/inc_lre.xsl+ examples/hparser/xslt/invoiceSort.xsl+ examples/hparser/xslt/invoice.xml+ examples/hparser/xslt/invoice.xsl+ examples/hparser/xslt/lre_stylesheet.xsl+ examples/hparser/xslt/lre.xsl + examples/hparser/xslt/Makefile+ examples/hparser/xslt/Makefile~+ examples/hparser/xslt/match_by_for_each.xsl+ examples/hparser/xslt/nspropXSLT.xsl+ examples/hparser/xslt/nspropXSLTyyy.xsl+ examples/hparser/xslt/prio_imp1_1.xsl+ examples/hparser/xslt/prio_imp1_2.xsl+ examples/hparser/xslt/prio_imp1.xsl+ examples/hparser/xslt/prio_imp2.xsl+ examples/hparser/xslt/prio_inc.xsl+ examples/hparser/xslt/prio.xsl+ examples/hparser/xslt/recAdd.xsl+ examples/hparser/xslt/sorting.xsl+ examples/hparser/xslt/strip_example.xml+ examples/hparser/xslt/strip_example.xsl+ examples/hparser/xslt/strip_space_imp.xsl+ examples/hparser/xslt/strip_space_with_rules.xsl+ examples/hparser/xslt/strip_space.xsl+ examples/hparser/xslt/stripXSLT.xsl+ examples/hparser/xslt/testEX.xsl+ examples/hparser/xslt/testNS.xml+ examples/hparser/xslt/testNS.xsl+ examples/hparser/xslt/vars_and_params_imp.xsl+ examples/hparser/xslt/vars_and_params.xsl+ examples/Makefile ++library+ exposed-modules:+ Text.XML.HXT.XSLT,+ Text.XML.HXT.XSLT.Application,+ Text.XML.HXT.XSLT.Common,+ Text.XML.HXT.XSLT.Compilation,+ Text.XML.HXT.XSLT.CompiledStylesheet,+ Text.XML.HXT.XSLT.Names,+ Text.XML.HXT.XSLT.XsltArrows++ hs-source-dirs: src+ ghc-options: -Wall+ extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances++ build-depends: base >= 4.2 && < 5,+ haskell98 >= 1 && < 2,+ containers >= 0.3 && < 1,+ directory >= 1 && < 2,+ filepath >= 1 && < 2,+ parsec >= 2.1 && < 4,+ hxt >= 8.4 && < 9+
+ src/Text/XML/HXT/XSLT.hs view
@@ -0,0 +1,27 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT+ Copyright : Copyright (C) 2010 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable++ The HXT XSLT interface++ The application programming interface to the XSLT modules of the Haskell XML Toolbox.+ This module exports all important arrows for XSLT processing.+-}++-- ------------------------------------------------------------++module Text.XML.HXT.XSLT+ ( module Text.XML.HXT.XSLT.XsltArrows+ )+where++import Text.XML.HXT.XSLT.XsltArrows++-- ------------------------------------------------------------
+ src/Text/XML/HXT/XSLT/Application.hs view
@@ -0,0 +1,644 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT.Application+ Copyright : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+ Stability : experimental+ Portability: portable+ Version : $Id: Application.hs,v 1.7 2007/05/02 06:41:05 hxml Exp $++ The transformation functions for XSLT transformation of XML documents++ Exports only two pure functions 'applyStylesheet' and 'applyStylesheetWParams'++-}++-- ------------------------------------------------------------++module Text.XML.HXT.XSLT.Application + ( applyStylesheet -- CompiledStylesheet -> XmlTree -> [XmlTree]+ , applyStylesheetWParams -- Map ExName Expr -> CompiledStylesheet -> XmlTree -> [XmlTree]+ , 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 -- current node+ [NavXmlTree] -- current node list + Int -- pos. of curr-node 1..length+ Int -- length of node list+ VariableSet -- glob. Var+ VariableSet -- loc. Var+ CompiledStylesheet -- The stylesheet which is being applied+ (Maybe MatchRule) -- Just the last applied match rule, Nothing within xsl:for-each+ Int -- recursion depth, needed for the creation of rtf-ids+ | CtxEmpty -- The empty-context, indicates that a branch of a transformation has been finished++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 [node])+ where + filterXPath (XPVError err) = error err+ filterXPath (XPVNode nodes) = XPVNode $ (\x -> fst x ++ snd x) $ partition (isAttr.subtreeNT) nodes+ -- line above: complicated issue: consider: <lre><xsl:copy-of select="a/@*|a/*|b/@*"/></lre>+ -- assume a is in document order before b. Shall b's attributes be added to lre or be ignored?!+ 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 [ntree rtfRoot]+ where+ rtfRoot = setAttribute rootIdName ("rtf " ++ rtfId) $ mkRoot [] $ applyTemplate template ctx+ rootIdName = mkQName "" "rootId" ""++applySelect :: SelectExpr -> Context -> [NavXmlTree]+applySelect (SelectExpr expr) ctx = + extractNodes xpathResult+ where + xpathResult = evalXPathExpr expr ctx+ extractNodes (XPVNode nodes) = nodes+ extractNodes r = error $ "XPATH-Expression in select or match attribute returned a value of the wrong type (" + ++ take 15 (show r) ++ "...)"++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+ = [] -- trace ("Message(trace): " ++ msg) []+ 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 _ _ = []+++-- create an element from a list of attributes followed by content++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 "" = "" -- could probably move to hxt...?+ 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 "" = "" -- In a better Haskell: format = replaceAll "?>" "? >"+ format ('?':'>':xs) = '?':' ':'>':format xs -- could probably move to hxt...?+ 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 -- Case 1: Root node => just use the content template+ = applyTemplate template ctx+ | isElem currNode -- Case 2: Any other element-node+ = return $ createElement name (getUriMap currNode) Map.empty fullcontent+ | otherwise -- Just return the current node as result+ = 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 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 [] -- trace ("Warning: Unreacheable variable: " ++ show (getVarName v)) const []++-- ------------------------------------+-- "Main" :++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++-- ------------------------------------+-- calling named- and applying match-rules++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 -- rules for match="*|/"+ = applyMatchRulesToChildren Map.empty rules mode ctx + | isText ctxNode -- rule for match="text()"+ = [ctxNode]+ | isAttr ctxNode -- rule for match="@*"+ = [mkText $ collectTextnodes $ getChildren ctxNode]+ | otherwise -- the glorious rest (PIs and comments):+ = []+ where + rules = getMatchRules stylesheet+ ctxNode = subtreeNT ctxNavNode++matchDefaultRules _ _ = []+ +-- ------------------------------------++-- Variables and Parameters++-- Evaluate a xsl:variable or xsl:param element and add the newly+-- created local variable to the context++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++-- create a set of parameters (Names refering to XPath-values) from a set of Variable-placeholders (unevaluated expressions)+createParamSet :: Map ExName Variable -> Context -> ParamSet+createParamSet wParamList ctx = Map.map (evalVariableWParamSet Map.empty ctx) wParamList++-- ------------------------------------+-- handling of imported attributes++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+ +-- ------------------------------------+-- Sorting++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++ -- helper functions:+ 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) -- The text comparison still needs to be improved...+ cmpString _ _+ = error "internal error in cmpString in applySortKey"++invertOrd :: Ordering -> Ordering+invertOrd EQ = EQ+invertOrd LT = GT+invertOrd GT = LT++-- ------------------------------------+-- Namespace FIXUP++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+{-+ if maybe (nsUri=="") (== nsUri) luUri+ then name++ else 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+
+ src/Text/XML/HXT/XSLT/Common.hs view
@@ -0,0 +1,406 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT.Application+ Copyright : Copyright (C) 2006-2008 Tim Walkenhorst, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+ Stability : experimental+ Portability: portable++ Common imports and functions for HXSLT++-}++-- ------------------------------------------------------------++module Text.XML.HXT.XSLT.Common+ ( module Control.Arrow+ , module Text.XML.HXT.DOM.XmlNode+ , module Text.XML.HXT.DOM.XmlKeywords+ , module Text.XML.HXT.DOM.TypeDefs+ , module Text.XML.HXT.DOM.FormatXmlTree+ , module Text.XML.HXT.XPath.XPathDataTypes+ , module Text.XML.HXT.XPath.XPathParser+ , module Text.XML.HXT.XPath.XPathEval+ , module Text.XML.HXT.XPath.XPathFct+ , module Text.XML.HXT.XPath.XPathToString+ , module Data.NavTree+ , module Data.Tree.Class++ -- Tree Functions+ , filterTree -- Tree t => (a -> Bool) -> t a -> Maybe (t a)+ , mapTreeCtx -- Tree t => (c -> a -> (c, b)) -> c -> t a -> t b+ , filterTreeCtx -- Tree t => (c -> a -> (c, Bool)) -> c -> t a -> Maybe (t a)+ , zipTreeWith -- Tree t => (a -> b -> c) -> t a -> t b -> t c+ , zipTree -- Tree t => t a -> t b -> t (a,b) (zipTreeWith (,))+ , unzipTree -- Tree t => t (a,b) -> (t a, t b) (mapTree fst &&& mapTree snd)+ , showTrees++ -- XML functions+ , isElemType -- XmlNode n => QName -> n -> Bool+ , isAttrType -- XmlNode n => QName -> n -> Bool+ , isWhitespaceNode -- XmlTree -> Bool+ , collectTextnodes -- [XmlTree] -> String+ , tryFetchAttribute -- XmlNode n => n -> QName -> Maybe String+ , fetchAttributeWDefault -- XmlNode n => n -> QName -> String -> String+ , fetchAttribute -- XmlNode n => n -> QName -> String+ , hasAttribute -- XmlNode n => n -> QName -> Bool+ , setAttribute -- XmlNode n => QName -> String -> n -> n++ -- Namespace functions+ , ExName(ExName) -- String (local) -> String (uri) -> ExName+ , mkExName -- QName -> ExName+ , exLocal -- ExName -> String+ , exUri -- ExName -> String+ , parseExName -- UriMapping -> String -> ExName+ , UriMapping -- Map String String+ , getUriMap -- XmlNode n => n -> UriMapping (extract an Ns-Uri Map from an Element node)+ , setUriMap -- XmlNode n => UriMap -> n -> n+ , uriMap2Attrs -- UriMapping -> [XmlTree] (create xmlns:* Attribute nodes for Uri-Mapping)+ , expandNSDecls -- XmlTree -> XmlTree+ , lookupPrefix -- UriMapping -> String -> String+ , isNsAttr -- XmlTree -> Bool++ -- additions to XPATH:+ , mkLiteralExpr -- String -> Expr+ , mkStringExpr -- Expr -> Expr+ , mkBoolExpr -- Expr -> Expr+ , mkTrueExpr -- Expr+ , concatExpr -- [Expr] -> Expr+ , splitExpr -- Expr -> [Expr]+ , unionExpr -- [Expr] -> Expr+ , splitMatchByPrio -- Expr -> [(Float, Expr)]+ , computePriority -- Expr -> Float+ , computeNTestPriority -- NodeTest -> Float+ , isMatchExpr -- Expr -> Bool++ -- Misc.:+ , fromJustErr -- String -> Maybe a -> a, fromJust with error message+ , readWDefault -- Read a => a -> String -> a+ )+where++import Control.Arrow+import Control.Arrow.ListArrow+import Control.Arrow.ArrowList++import Text.XML.HXT.Arrow.XmlArrow ( xshow+ )+import Text.XML.HXT.DOM.XmlKeywords+import Text.XML.HXT.DOM.XmlNode ( XmlNode (..)+ , mkElement+ , mkRoot+ , mkAttr+ , mergeAttrl+ )++import Text.XML.HXT.DOM.TypeDefs ( XmlTree+ , XNode(XTag, XAttr)+ , QName+ , toNsEnv+ , namePrefix+ , localPart+ , namespaceUri+ , equivQName+ , mkName+ , mkQName+ )+import Text.XML.HXT.DOM.FormatXmlTree ( formatXmlTree+ )++import Text.XML.HXT.XPath.XPathDataTypes( Expr ( LiteralExpr+ , FctExpr+ , GenExpr+ , PathExpr+ )+ , Op ( Union )+ , LocationPath ( LocPath )+ , Path ( Rel )+ , XStep ( Step )+ , NodeTest ( NameTest+ , PI+ , TypeTest+ )+ , NavXmlTree+ , XPathValue ( XPVNode+ , XPVBool+ , XPVString+ , XPVError+ )+ )+import Text.XML.HXT.XPath.XPathParser ( parseXPath+ )+import Text.XML.HXT.XPath.XPathEval ( evalExpr+ )+import Text.XML.HXT.XPath.XPathFct ( isNotInNodeList+ )+import Text.XML.HXT.XPath.XPathToString ( xPValue2XmlTrees+ )++import Data.Map (Map)+import qualified Data.Map as Map hiding (Map)++import Data.Tree.Class ++import Data.NavTree ( NavTree+ , ntree+ , subtreeNT+ , upNT+ , downNT+ , rightNT+ , leftNT+ , getChildrenNT+ )+import Data.Maybe+import Data.List+import Data.Char++--------------------------- +-- Tree functions++-- mapTree :: Functor t => (a -> b) -> t a -> t b+-- mapTree = fmap++-- "map" on a tree with a context. +-- Contextual information from the ancestors of the current node can be collected in the context++mapTreeCtx :: Tree t => (c -> a -> (c, b)) -> c -> t a -> t b+mapTreeCtx f c tree = + mkTree b $ map (mapTreeCtx f cN) $ getChildren tree+ where + (cN, b) = f c $ getNode tree++filterTree :: Tree t => (a -> Bool) -> t a -> Maybe (t a)+filterTree p tree = if p node+ then Just $ mkTree node $ mapMaybe (filterTree p) $ getChildren tree+ else Nothing+ where node = getNode tree++-- "filter" on a tree with a context. +-- Contextual information from the ancestors of the current node can be collected in the context+filterTreeCtx :: Tree t => (c -> a -> (c, Bool)) -> c -> t a -> Maybe (t a)+filterTreeCtx p c tree =+ if b + then Just $ mkTree node $ mapMaybe (filterTreeCtx p cN) $ getChildren tree+ else Nothing+ where + (cN, b) = p c node+ node = getNode tree++zipTreeWith :: Tree t => (a -> b -> c) -> t a -> t b -> t c+zipTreeWith f a b = mkTree (f (getNode a) (getNode b)) + $ zipWith (zipTreeWith f) (getChildren a) $ getChildren b++zipTree :: Tree t => t a -> t b -> t (a,b)+zipTree = zipTreeWith (,)++unzipTree :: Functor t => t (a,b) -> (t a, t b)+unzipTree = fmap fst &&& fmap snd++showTrees :: [XmlTree] -> String+showTrees ts+ = concat + (runLA (xshow (constL ts)) $ undefined)++--------------------------- +-- Xml Functions++collectTextnodes :: [XmlTree] -> String+collectTextnodes+ = concat . mapMaybe getText++isElemType :: XmlNode n => QName -> n -> Bool+isElemType qn node+ = isElem node+ &&+ equivQName qn (fromJust $ getElemName node)++isAttrType :: XmlNode n => QName -> n -> Bool+isAttrType qname node+ = isAttr node+ &&+ equivQName qname (fromJust $ getAttrName node)++tryFetchAttribute :: XmlNode n => n -> QName -> Maybe String+tryFetchAttribute node qn+ | isElem node =++ if null candidates + then Nothing++ else if length candidates > 1+ then error ("More than one attribute " ++ show qn)++ else Just $ collectTextnodes $ getChildren $ head candidates++ | otherwise = Nothing + where + candidates = filter (isAttrType qn) $ fromJust $ getAttrl node++fetchAttributeWDefault :: XmlNode n => n -> QName -> String -> String+fetchAttributeWDefault node name def = maybe def id (tryFetchAttribute node name)++fetchAttribute :: XmlNode n => n -> QName -> String+fetchAttribute node name = fetchAttributeWDefault node name $ error ("Element " ++ show (getElemName node) ++ " has no attribute: " ++ show name)++hasAttribute :: XmlNode n => n -> QName -> Bool+hasAttribute node = isJust . tryFetchAttribute node++setAttribute :: XmlNode n => QName -> String -> n -> n+setAttribute qn val node+ | isElem node = setElemAttrl (newA : attrs) node+ | otherwise = error $ "setAttribute on none-element node" -- how print an XmlNode...+ where + attrs = filter (not . isAttrType qn) $ fromJust $ getAttrl node+ newA = mkTree (XAttr qn) [mkText val]++isWhitespaceNode :: (XmlNode n) => n -> Bool+isWhitespaceNode = maybe False (all isSpace) . getText++--------------------------- +-- Namespace Functions++-- Expanded name, is unique can therefore be used as a key (unlike QName)++data ExName = ExName String String+ deriving (Show, Eq, Ord)++mkExName :: QName -> ExName+mkExName qn = ExName (localPart qn) (namespaceUri qn)++exLocal, exUri :: ExName -> String+exLocal (ExName l _) = l+exUri (ExName _ u) = u++parseExName :: UriMapping -> String -> ExName+parseExName uris str+ | noPrefix = ExName str ""+ | otherwise = ExName loc $ lookupPrefix uris prefix+ where+ noPrefix = null loc + loc = drop 1 loc' + (prefix, loc') = span (/= ':') str++-- Mapping from namespace-Prefixes to namespace-URIs++type UriMapping = Map String String++getUriMap :: XmlNode n => n -> UriMapping+getUriMap+ = uriMappingsFromNsAttrs . filter isNsAttr . maybe err id . getAttrl+ where+ err = error "Internal error: getUriMap on none-element node"++setUriMap :: XmlNode n => UriMapping -> n -> n+setUriMap nsMap node+ = setElemAttrl (mergeAttrl (maybe [] id $ getAttrl node) $ uriMap2Attrs nsMap) node++uriMap2Attrs :: UriMapping -> [XmlTree]+uriMap2Attrs+ = map joinNsAttr . Map.toAscList++lookupPrefix :: UriMapping -> String -> String+lookupPrefix uris prefix+ = fromJustErr ("No namespace-Uri bound to prefix: "++prefix) $ Map.lookup prefix uris++expandNSDecls :: XmlTree -> XmlTree+expandNSDecls+ = mapTreeCtx (expandNSElem) $ Map.fromAscList [("xml", xmlNamespace), ("xmlns", xmlnsNamespace)]++expandNSElem :: UriMapping -> XNode -> (UriMapping, XNode)+expandNSElem umap node+ | isElem node = (umapNew, nodeNew)+ | otherwise = (umap, node)+ where+ nodeNew = XTag (fromJust $ getElemName node) attrNew+ attrNew = attrs ++ map joinNsAttr (Map.toAscList umapNew)+ umapNew = uriMappingsFromNsAttrs nsAttrs `Map.union` umap+ (nsAttrs, attrs) = partition isNsAttr $ fromJust $ getAttrl node++uriMappingsFromNsAttrs :: [XmlTree] -> UriMapping+uriMappingsFromNsAttrs+ = Map.fromList . map splitNsAttr++isNsAttr :: XmlTree -> Bool+isNsAttr+ = maybe False ((==) xmlnsNamespace . namespaceUri) . getAttrName++splitNsAttr :: XmlTree -> (String, String)+splitNsAttr node+ = (localPart $ fromJust $ getAttrName node, collectTextnodes $ getChildren node)++joinNsAttr :: (String, String) -> XmlTree+joinNsAttr (prefix, uri)+ = mkAttr (mkQName "xmlns" prefix xmlnsNamespace) [mkText uri]++-------------------------+-- additions to XPATH:++mkLiteralExpr :: String -> Expr+mkLiteralExpr = LiteralExpr++mkStringExpr :: Expr -> Expr+mkStringExpr = FctExpr "string" . return++mkBoolExpr :: Expr -> Expr+mkBoolExpr = FctExpr "boolean" . return++mkTrueExpr :: Expr+mkTrueExpr = FctExpr "true" []++concatExpr :: [Expr] -> Expr+concatExpr [] = LiteralExpr ""+concatExpr [lit@(LiteralExpr _)] = lit+concatExpr xs1@[_] = FctExpr "string" xs1+concatExpr xs = FctExpr "concat" xs++splitExpr :: Expr -> [Expr]+splitExpr (GenExpr Union expr) = expr+splitExpr rest = [rest]++unionExpr :: [Expr] -> Expr+unionExpr [e] = e+unionExpr es = GenExpr Union es++-- Intelligent splitting: Split an expression into subexpressions with equal priority+-- for example: "a|c/d|e|f/g" => [(0.0, "a|e"), (0.5, "c/d|f/g")]+splitMatchByPrio :: Expr -> [(Float, Expr)]+splitMatchByPrio = + map compress . groupBy eq . sortBy cmp . map (computePriority &&& id) . splitExpr+ where+ eq x y = fst x == fst y+ cmp x y = compare (fst x) (fst y)+ compress = (head *** unionExpr) . unzip++computePriority :: Expr -> Float+computePriority (PathExpr Nothing (Just (LocPath Rel [Step _ ntest []]))) = computeNTestPriority ntest+computePriority _ = 0.5++computeNTestPriority :: NodeTest -> Float+computeNTestPriority (PI _) = 0.0+computeNTestPriority (TypeTest _) = -0.5+computeNTestPriority (NameTest nt) + | namePrefix nt /= ""+ && localPart nt == "*" = -0.25+ | localPart nt == "*" = -0.5+ | otherwise = 0.0++isMatchExpr :: Expr -> Bool+isMatchExpr (GenExpr Union exprs) = all isMatchExpr exprs+isMatchExpr (PathExpr _ _) = True+isMatchExpr (FctExpr "id" [LiteralExpr _]) = True+isMatchExpr (FctExpr "key" [LiteralExpr _, LiteralExpr _]) = True+isMatchExpr _ = False++--------------------------- +-- Misc:++fromJustErr :: String -> Maybe a -> a+fromJustErr msg = maybe (error msg) id ++readWDefault :: Read a => a -> String -> a+readWDefault a str = fst $ head $ reads str ++ [(a, "")]++---------------------------
+ src/Text/XML/HXT/XSLT/Compilation.hs view
@@ -0,0 +1,500 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT.Application+ Copyright : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+ Stability : experimental+ Portability: portable++ The compilation functions for XSLT stylesheets++-}++-- ------------------------------------------------------------++module Text.XML.HXT.XSLT.Compilation + ( prepareXSLTDocument -- :: XmlTree -> XmlTree+ , assembleStylesheet -- :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet+ )+where++import Control.Monad++import Data.Maybe+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++-- No deep meaning just a shortcut notation for a *very* common expression...++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 (toNsEnv . 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]++-- --------------------------++-- extract ComputedQName from "name" and "namespace" AVTs of an xsl:element- or xsl-attribute-node+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++-- Otherwise is treated as a when-Part with node-test "true()"+compileOtherwise :: XmlTree -> When+compileOtherwise node = WhenPart (TestExpr mkTrueExpr) $ compileTemplate $ getChildren node++-- "if" is treated as a convenience-form of choose with exactly one "when"-Part+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)++-- compiles xsl:text+compileText :: XmlTree -> Template+compileText = TemplText . collectTextnodes . getChildren++-- compiles textNode +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++ -- no other xslt elements allowed here:+ else if namespaceUri elemName == xsltUri+ then error $ "xslt-element " ++ localPart elemName ++ " not allowed within this context."++ -- for now all other elements will be considered as Literal Result Elements+ 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+++-- -----------------------------------+-- Assembling of the entire stylesheet++assembleStylesheet :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet+assembleStylesheet xslNode imports =+ CompStylesheet matchRules namedRules variables attsets strips aliases+ where + -- entire contents:+ (namedRules, + matchRules) = assembleRules ruleElems importedMatchRules importedNamedRules+ variables = assembleVariables varElems importedVariables+ attsets = assembleAttrSets attsetElems importedAttribSets+ strips = assembleStrips stripElems preserveElems importedStrips+ aliases = assembleAliases nsAliasElems importedAliases++ -- element content:+ (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++ -- imported stuff:+ 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+ + -- matches: + resMatches = localMatches ++ importedMatches+ localMatches = reverse $ sortBy cmp matches+ cmp rulA rulB = compare (getRulePrio rulA) (getRulePrio rulB)++ -- procedures:+ 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'++ -- compile all xsl:template's:+ (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++-- -----------------------------------++-- compile a rule from an xsl:template element.+-- The resulting rule can either be a one or more match rule or a named rule, or both.+-- The first argument is needed for xsl:apply-imports and contains+-- a list of all subsequently imported rules+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)++-- -----------------------------------+-- Document level preprocessing++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))++-- Expand exclude-result-prefixes AND extension-element-prefixes++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)++-- parse a prefix list, create a list of uris: +-- "pre1 pre2 pre3" -> ["pre1.uri","pre2.uri","pre3.uri"]++parsePreList :: UriMapping -> String -> [String]+parsePreList uris = map (lookupPrefix uris) . words++-- -----------------------------------+-- Extraction of contextual Information from an XML-Node++extractAddUris :: XmlTree -> UriMapping+extractAddUris node = + (Map.filter (`notElem` exclUris))><node+ where+ exclUris = words $ fetchAttributeWDefault node xsltExlcudeResultPrefixesLRE ""++-- -----------------------------------
+ src/Text/XML/HXT/XSLT/CompiledStylesheet.hs view
@@ -0,0 +1,266 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT.Application+ Copyright : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+ Stability : experimental+ Portability: portable+ Version : $Id: CompiledStylesheet.hs,v 1.3 2007/05/02 06:41:05 hxml Exp $++ Types for compiled stylesheets++-}++-- ------------------------------------------------------------++module Text.XML.HXT.XSLT.CompiledStylesheet+where ++import Text.XML.HXT.XSLT.Common+import Text.XML.HXT.XSLT.Names++import Data.Maybe++import Data.Map (Map)+import qualified Data.Map as Map hiding (Map)++-- -------------------++-- compiled-Stylesheet:++data CompiledStylesheet = + CompStylesheet+ [MatchRule] + (Map ExName NamedRule)+ (Map ExName Variable) + (Map ExName [AttributeSet]) + [Strips] + NSAliasing + deriving Show++getMatchRules :: CompiledStylesheet -> [MatchRule]+getMatchRules (CompStylesheet matchRules _ _ _ _ _) = matchRules++getNamedRules :: CompiledStylesheet -> (Map ExName NamedRule)+getNamedRules (CompStylesheet _ namedRules _ _ _ _) = namedRules++getVariables :: CompiledStylesheet -> (Map ExName Variable)+getVariables (CompStylesheet _ _ variables _ _ _) = variables++getAttributeSets :: CompiledStylesheet -> Map ExName [AttributeSet]+getAttributeSets (CompStylesheet _ _ _ attrSets _ _) = attrSets++getStrips :: CompiledStylesheet -> [Strips]+getStrips (CompStylesheet _ _ _ _ strips _) = strips++getAliases :: CompiledStylesheet -> NSAliasing+getAliases (CompStylesheet _ _ _ _ _ aliases) = aliases++-- -------------------+-- Match-Rules:++data MatchRule = + MatRule MatchExpr+ Float -- priority+ (Maybe ExName) -- mode+ [MatchRule] -- Imported rules only for xsl:apply-imports+ [Variable] -- xsl:param list+ Template -- content+ --deriving Show -- output of imported Rules makes it unreadable++instance Show MatchRule where+ show (MatRule expr prio mode imprules params content)+ = "MkRule expr: " ++ show expr ++ "\n prio: " ++ show prio ++ "\n mode: "++ show mode + ++ "\n no. imported rules: " ++ show (length imprules) ++ "\n xsl-params: " ++ show params + ++ "\n content: " ++ show content ++"\n"++getRulePrio :: MatchRule -> Float+getRulePrio (MatRule _ prio _ _ _ _) = prio++getRuleMode :: MatchRule -> Maybe ExName+getRuleMode (MatRule _ _ mode _ _ _) = mode++getRuleImports :: MatchRule -> [MatchRule]+getRuleImports (MatRule _ _ _ imports _ _) = imports++-- -------------------+-- Named-Rules:++data NamedRule = NamRule ExName [Variable] Template+ deriving Show++getRuleName :: NamedRule -> ExName+getRuleName (NamRule name _ _) = name++-- -------------------+-- Variables ++data Variable = MkVar + Bool -- modus: False => xsl:variable, True => xsl:param+ ExName -- name+ (Either Expr Template) -- select-expression or result tree fragment+ deriving Show++getVarName :: Variable -> ExName+getVarName (MkVar _ name _) = name++isParam :: Variable -> Bool+isParam (MkVar isP _ _) = isP++-- -------------------+-- Attribute sets:++newtype UsedAttribSets = UsedAttribSets [ExName]+ deriving Show++data AttributeSet = AttribSet ExName UsedAttribSets Template+ deriving Show++-- -------------------+-- Whitespace-stripping++type NTest = ExName ++parseNTest :: UriMapping -> String -> NTest+parseNTest = parseExName++type Strips = Map NTest Bool++-- Lookup whether an element of the source document must be stripped.+-- Strip descriptions are ordered by descending import precedence:++lookupStrip :: ExName -> [Strips] -> Bool+lookupStrip name+ = head . (++ [False]) . mapMaybe (lookupStrip1 name)++-- Try to match a qualified name with a set of strip- and preserve-space attributes of the same import precedence:++lookupStrip1 :: ExName -> Strips -> Maybe Bool+lookupStrip1 name spec = + if isJust nameMatch then nameMatch+ else if isJust prefMatch then prefMatch+ else if isJust globMatch then globMatch+ else Nothing+ where+ nameMatch = Map.lookup ( name ) spec+ prefMatch = Map.lookup (ExName "*" $ exUri name) spec+ globMatch = Map.lookup (ExName "*" "" ) spec++feedSpaces :: Bool -> [NTest] -> Strips -> Strips+feedSpaces strip tests = + Map.unionWithKey feedErr $ Map.fromListWithKey feedErr $ zip tests $ repeat strip+ where+ feedErr k = error $ "Ambiguous strip- or preserve-space rules for " ++ show k++feedStrips, feedPreserves :: [NTest] -> Strips -> Strips+feedStrips = feedSpaces True+feedPreserves = feedSpaces False++stripDocument :: [Strips] -> XmlTree -> XmlTree+stripDocument strips+ = stripSpaces (\_ n -> lookupStrip (mkExName $ fromJust $ getElemName n) strips) False++stripStylesheet :: XmlTree -> XmlTree+stripStylesheet+ = stripSpaces isStrip True+ where+ isStrip strip' node+ = not (isElemType xsltText node)+ &&+ ( maybe strip' (=="default") $ tryFetchAttribute node xmlSpace )++stripSpaces :: (Bool -> XNode -> Bool) -> Bool -> XmlTree -> XmlTree+stripSpaces f def = + fromJustErr "stripSpaces (internal error)" . filterTreeCtx step def+ where+ step strip node + | isElem node = (f strip node, True)+ | isWhitespaceNode node = (strip , not strip)+ | otherwise = (strip , True)++-- -------------------+-- Namespace aliases and exclusion++-- Map a namespace URI to a new URI tuple,++type NSAliasing = Map String String++addAlias :: UriMapping -> String -> String -> NSAliasing -> NSAliasing+addAlias uris oldPr newPr+ = Map.insertWith (error $ "duplicate mapping for " ++ old) old new+ where+ old = lookupPrefix uris oldPr+ new = lookupPrefix uris newPr++-- lookup an alias in a namespace-mapping.+-- returns the original name, if there is no alias for that name.++lookupAlias :: NSAliasing -> QName -> QName+lookupAlias nsm qn+ = mkQName (namePrefix qn) (localPart qn) + $ maybe (namespaceUri qn) id+ $ Map.lookup (namespaceUri qn) nsm+ +aliasUriMapping :: NSAliasing -> UriMapping -> UriMapping+aliasUriMapping nsm = Map.map (\uri -> Map.findWithDefault uri uri nsm)++-- -------------------+-- Templates:++data Template+ = TemplComposite [Template] + | TemplForEach SelectExpr [SortKey] Template+ | TemplChoose [When] -- otherwise will be represented by <xsl:when test="true()"/> in the abstract Syntax+ | TemplMessage Bool -- halt?+ Template -- content + | TemplElement ComputedQName+ UriMapping -- Namespaces which *must* be added+ UsedAttribSets -- + Template -- content+ | TemplAttribute ComputedQName+ Template -- content+ | TemplText String+ | TemplValueOf StringExpr -- select+ | TemplComment Template+ | TemplProcInstr StringExpr -- name+ Template -- content+ | TemplApply (Maybe SelectExpr) + (Maybe ExName) -- mode+ (Map ExName Variable) -- passed arguments+ [SortKey]+ | TemplApplyImports+ | TemplVariable Variable+ | TemplCall ExName -- name+ (Map ExName Variable) -- passed arguments+ | TemplCopy UsedAttribSets+ Template+ | TemplCopyOf Expr+ deriving Show++data SortKey+ = SortK StringExpr -- select+ StringExpr -- data-type: number or text(default)+ StringExpr -- order: ascending(default) or descending+ deriving Show++data When+ = WhenPart TestExpr Template + deriving Show++data ComputedQName+ = LiteralQName QName+ | CompQName UriMapping -- namespace-env+ StringExpr -- name+ StringExpr -- namespace+ deriving Show++-- -------------------+-- different kinds of expressions++newtype SelectExpr = SelectExpr Expr deriving Show+newtype TestExpr = TestExpr Expr deriving Show+newtype StringExpr = StringExpr Expr deriving Show+newtype MatchExpr = MatchExpr Expr deriving Show
+ src/Text/XML/HXT/XSLT/Names.hs view
@@ -0,0 +1,152 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT.Application+ Copyright : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable+ Version : $Id: Names.hs,v 1.2 2006/11/11 15:36:05 hxml Exp $++ Names and constants for HXSLT++-}++-- ------------------------------------------------------------++module Text.XML.HXT.XSLT.Names+where++import Text.XML.HXT.XSLT.Common++xsltPrefix :: String+xsltPrefix = "xsl"++xsltUri :: String+xsltUri = "http://www.w3.org/1999/XSL/Transform"++mkXsltName :: String -> QName+mkXsltName name = mkQName xsltPrefix name xsltUri++mkXsltAttribName :: String -> QName+mkXsltAttribName name = mkQName "" name ""++-- XSLT-Element QNames+xsltTransform+ , xsltStylesheet+ , xsltMessage+ , xsltForEach+ , xsltChoose+ , xsltWhen+ , xsltOtherwise+ , xsltIf+ , xsltElement+ , xsltAttribute+ , xsltText+ , xsltValueOf+ , xsltComment+ , xsltProcInstr+ , xsltInclude+ , xsltImport+ , xsltTemplate+ , xsltApplyTemplates+ , xsltApplyImports+ , xsltCallTemplate+ , xsltVariable+ , xsltParam+ , xsltWithParam+ , xsltAttributeSet+ , xsltCopy+ , xsltCopyOf+ , xsltSort+ , xsltStripSpace+ , xsltPreserveSpace+ , xsltNamespaceAlias :: QName++xsltTransform = mkXsltName "transform"+xsltStylesheet = mkXsltName "stylesheet"+xsltMessage = mkXsltName "message"+xsltForEach = mkXsltName "for-each"+xsltChoose = mkXsltName "choose"+xsltWhen = mkXsltName "when"+xsltOtherwise = mkXsltName "otherwise"+xsltIf = mkXsltName "if"+xsltElement = mkXsltName "element"+xsltAttribute = mkXsltName "attribute"+xsltText = mkXsltName "text"+xsltValueOf = mkXsltName "value-of"+xsltComment = mkXsltName "comment"+xsltProcInstr = mkXsltName "processing-instruction"+xsltInclude = mkXsltName "include"+xsltImport = mkXsltName "import"+xsltTemplate = mkXsltName "template"+xsltApplyTemplates = mkXsltName "apply-templates"+xsltApplyImports = mkXsltName "apply-imports"+xsltCallTemplate = mkXsltName "call-template"+xsltVariable = mkXsltName "variable"+xsltParam = mkXsltName "param"+xsltWithParam = mkXsltName "with-param"+xsltAttributeSet = mkXsltName "attribute-set"+xsltCopy = mkXsltName "copy"+xsltCopyOf = mkXsltName "copy-of"+xsltSort = mkXsltName "sort"+xsltStripSpace = mkXsltName "strip-space"+xsltPreserveSpace = mkXsltName "preserve-space"+xsltNamespaceAlias = mkXsltName "namespace-alias"++-- XSLT-Attribute QNames+xsltTerminate+ , xsltSelect+ , xsltTest+ , xsltName+ , xsltNamespace+ , xsltUseAttributeSets+ , xsltHRef+ , xsltMatch+ , xsltPriority+ , xsltMode+ , xsltDataType+ , xsltOrder+ , xsltElements+ , xsltStylesheetPrefix+ , xsltResultPrefix+ , xsltVersion+ , xsltExlcudeResultPrefixes+ , xsltExtensionElementPrefixes :: QName++xsltTerminate = mkXsltAttribName "terminate" +xsltSelect = mkXsltAttribName "select" +xsltTest = mkXsltAttribName "test" +xsltName = mkXsltAttribName "name"+xsltNamespace = mkXsltAttribName "namespace"+xsltUseAttributeSets = mkXsltAttribName "use-attribute-sets"+xsltHRef = mkXsltAttribName "href"+xsltMatch = mkXsltAttribName "match"+xsltPriority = mkXsltAttribName "priority"+xsltMode = mkXsltAttribName "mode"+xsltDataType = mkXsltAttribName "data-type"+xsltOrder = mkXsltAttribName "order"+xsltElements = mkXsltAttribName "elements"+xsltStylesheetPrefix = mkXsltAttribName "stylesheet-prefix"+xsltResultPrefix = mkXsltAttribName "result-prefix"+xsltVersion = mkXsltAttribName "version"+xsltExlcudeResultPrefixes = mkXsltAttribName "exclude-result-prefixes"+xsltExtensionElementPrefixes = mkXsltAttribName "extension-element-prefixes"++-- XSLT-Attribute QNames for special Literal result element attributes+xsltUseAttributeSetsLRE+ , xsltVersionLRE+ , xsltExlcudeResultPrefixesLRE+ , xsltExtensionElementPrefixesLRE :: QName++xsltUseAttributeSetsLRE = mkXsltName "use-attribute-sets" +xsltVersionLRE = mkXsltName "version"+xsltExlcudeResultPrefixesLRE = mkXsltName "exclude-result-prefixes"+xsltExtensionElementPrefixesLRE = mkXsltName "extension-element-prefixes"++-- xml:space attribute-name+xmlSpace :: QName++xmlSpace = mkQName "xml" "space" xmlNamespace
+ src/Text/XML/HXT/XSLT/XsltArrows.hs view
@@ -0,0 +1,310 @@+-- ------------------------------------------------------------++{- |+ Module : Text.XML.HXT.XSLT.XsltArrows+ Copyright : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable+ Version : $Id: XsltArrows.hs,v 1.1 2006/11/11 15:36:05 hxml Exp $++ The HXT arrow interface for the XSLT module++ The application programming interface to the arrow modules of the Haskell XML Toolbox.+ This module exports all important arrows for input, output, parsing, validating and transforming XML.+ It also exports all basic datatypes and functions of the toolbox.++-}++-- ------------------------------------------------------------+++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 )++-- ------------------------------------------------------------++-- | arrow for applying a pure partial function, catch the error case and issue the error++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+ +-- ------------------------------------------------------------++-- | lift prepareXSLTDocument++prepareXSLTDoc :: IOSArrow XmlTree XmlTree+prepareXSLTDoc+ = ( arrWithCatch prepareXSLTDocument+ >>>+ traceDoc "prepareXSLTDocument"+ )+ `when`+ documentStatusOk++-- | read an XSLT stylesheet++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)+ ]++-- | Normalize stylesheet, expand includes, select imports and assemble the rules++compileSSTWithIncludeStack :: [String] -> IOSArrow XmlTree CompiledStylesheet+compileSSTWithIncludeStack incStack+ = traceMsg 2 "compile stylesheet"+ >>>+ getChildren -- remove document root+ >>>+ isElem -- select XSLT root element+ >>>+ choiceA+ [ isXsltLREstylesheet -- simplified syntax+ :-> ( xsltlre2stylesheet+ >>>+ assStylesheet []+ )+ , isXsltStylesheetElem -- xsl:stylesheet or xsl:transform+ :-> ( expStylesheet+ $< ( listA ( getChildren -- take contents and expand includes+ >>>+ expandIncludes incStack+ )+ >>>+ partitionA isXsltImport -- separate imports from normal rules+ )+ )+ , this+ :-> ( issueErr "XSLT: Either xsl:stylesheet/xsl:transform or simplified syntax expected"+ >>>+ none+ )+ ]+ where+ assStylesheet imports -- do the assembly, the compilation+ = arrWithCatch (flip assembleStylesheet $ imports)++ expStylesheet (imports, rest)+ = traceMsg 2 "expandStylesheet"+ >>>+ setChildren rest -- remove import rules from stylesheet+ >>>+ assStylesheet $< listA ( constL imports -- read the imports and assemble the stylesheet+ >>>+ getXsltAttrValue xsltHRef+ >>>+ compileSSTFromUriWithIncludeStack incStack+ )++-- | read an include and check for recursive includes++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 styleshhet"+ )+ `orElse`+ issueErr "XSLT: complete document with root node required for stylesheet application"++-- | Compile a document representing an XSLT stylesheet into an internal representation+--+-- The internal representation is an abstract syntax tree for the XSLT rules.+-- XSLT imports and includes are evaluated and the rules are normalized and prepared+-- for easy application.++xsltCompileStylesheet :: IOSArrow XmlTree CompiledStylesheet+xsltCompileStylesheet+ = prepareXSLTDoc+ >>>+ compileSSTWithIncludeStack []++-- | A convinient function for combining reading a stylesheet and compilation.+--+-- Reading an XSLT stylesheet is always done without validation but with+-- namespace propagation. Comments are removed from the stylesheet.++xsltCompileStylesheetFromURI :: IOSArrow String CompiledStylesheet+xsltCompileStylesheetFromURI = compileSSTFromUriWithIncludeStack []++-- | apply a compiled XSLT stylesheet to a whole document tree+--+-- The compiled stylesheet must have been created with 'xsltCompileStylesheet'+-- or 'xsltCompileStylesheetFromURI'++xsltApplyStylesheet :: CompiledStylesheet -> IOSArrow XmlTree XmlTree+xsltApplyStylesheet css+ = checkApplySST (arrWithCatch (applyStylesheet css) >>. concat)++-- | apply an XSLT stylesheet given by an URI to a whole document tree+--+-- The string parameter is the URI of the XSLT stylesheet.+-- In case of an error during stylesheet compilation or stylesheet application+-- all children of the root node are removed and+-- the error status is set in the attribute list of the root node of the input document.++xsltApplyStylesheetFromURI :: String -> IOSArrow XmlTree XmlTree+xsltApplyStylesheetFromURI uri+ = xsltApplyStylesheet $< (constA uri >>> xsltCompileStylesheetFromURI)++{-+xsltApplyStylesheetWParams :: Map ExName Expr -> CompiledStylesheet -> IOSArrow XmlTree XmlTree+xsltApplyStylesheetWParams wp css = arrL (applyStylesheetWParams wp css)+-}