diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,14 +1,8 @@ -# $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 ;) diff --git a/examples/hparser/xslt/Makefile b/examples/hparser/xslt/Makefile --- a/examples/hparser/xslt/Makefile +++ b/examples/hparser/xslt/Makefile @@ -29,6 +29,7 @@ 'comment_pi.xsl example_document.xml' \ 'attset.xsl example_document.xml' \ 'copy_copy_of.xsl example_document.xml' \ + 'copy_rec.xsl example0.xml' \ 'sorting.xsl example_document.xml' \ 'strip_space.xsl exdoc2.xml' \ 'testEX.xsl empty.xml' \ diff --git a/examples/hparser/xslt/Makefile~ b/examples/hparser/xslt/Makefile~ deleted file mode 100644 --- a/examples/hparser/xslt/Makefile~ +++ /dev/null @@ -1,65 +0,0 @@ -# $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 - diff --git a/hxt-xslt.cabal b/hxt-xslt.cabal --- a/hxt-xslt.cabal +++ b/hxt-xslt.cabal @@ -1,10 +1,10 @@ -- arch-tag: Haskell XML Toolbox XSLT Module name: hxt-xslt -version: 8.4.0 +version: 8.5.0 license: OtherLicense license-file: LICENCE maintainer: Uwe Schmidt -stability: stable +stability: experimental 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. @@ -42,7 +42,6 @@ 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 @@ -87,5 +86,6 @@ directory >= 1 && < 2, filepath >= 1 && < 2, parsec >= 2.1 && < 4, - hxt >= 8.4 && < 9 + hxt >= 8.5 && < 9, + hxt-xpath >= 8.5 && < 9 diff --git a/src/Text/XML/HXT/XSLT/Application.hs b/src/Text/XML/HXT/XSLT/Application.hs --- a/src/Text/XML/HXT/XSLT/Application.hs +++ b/src/Text/XML/HXT/XSLT/Application.hs @@ -34,6 +34,10 @@ import qualified Data.Map as Map hiding (Map) import Data.Maybe +-- just for debugging +-- import Debug.Trace(trace) +-- import Text.XML.HXT.XPath.NavTree (subtreeNT) + -- ------------------------------------------------------------ type XPathParams = Map ExName Expr @@ -110,10 +114,12 @@ evalXPathExpr :: Expr -> Context -> XPathValue evalXPathExpr expr (Ctx node _ pos len globVars locVars _ _ _) - = filterXPath $ evalExpr (vars,[]) (pos, len, node) expr (XPVNode [node]) + = filterXPath $ evalExpr (vars,[]) (pos, len, node) expr (XPVNode . singletonNodeSet $ node) where filterXPath (XPVError err) = error err - filterXPath (XPVNode nodes) = XPVNode $ (\x -> fst x ++ snd x) $ partition (isAttr.subtreeNT) nodes + -- filterXPath (XPVNode nodes) = XPVNode $ (\x -> fst x ++ snd x) $ partition (isAttr . subtreeNT) nodes + -- this has been moved to applySelect, that's the point where the node set is converted inot a list of trees + -- line above: complicated issue: consider: -- assume a is in document order before b. Shall b's attributes be added to lre or be ignored?! filterXPath xpv = xpv @@ -124,20 +130,40 @@ = error "internal error in evalXPathExpr in XSLT module" evalRtf :: Template -> String -> Context -> XPathValue -evalRtf template rtfId ctx = XPVNode [ntree rtfRoot] +evalRtf template rtfId ctx = XPVNode $ singletonNodeSet (ntree rtfRoot) where rtfRoot = setAttribute rootIdName ("rtf " ++ rtfId) $ mkRoot [] $ applyTemplate template ctx rootIdName = mkQName "" "rootId" "" -applySelect :: SelectExpr -> Context -> [NavXmlTree] -applySelect (SelectExpr expr) ctx = +-- ------------------------------------------------------------ + +applySelect :: SelectExpr -> Context -> [NavXmlTree] +applySelect = applySelect' + +{- just for debugging +applySelect e@(SelectExpr expr) ctx = trace msg2 $ res + where + res = applySelect' e $ trace msg1 ctx + msg1 = unlines $ [ "applySelect: " ++ show expr + , formatXmlTree . subtreeNT . ctxGetNode $ ctx + ] + msg2 = unlines $ "result trees" : map (formatXmlTree . subtreeNT) res +-} + +applySelect' :: SelectExpr -> Context -> [NavXmlTree] +applySelect' (SelectExpr expr) ctx = extractNodes xpathResult where xpathResult = evalXPathExpr expr ctx - extractNodes (XPVNode nodes) = nodes + + extractNodes (XPVNode nodes) = attributesFirst . fromNodeSet $ nodes extractNodes r = error $ "XPATH-Expression in select or match attribute returned a value of the wrong type (" ++ take 15 (show r) ++ "...)" + attributesFirst = uncurry (++) . partition (isAttr . subtreeNT) + +-- ------------------------------------------------------------ + applyTest :: TestExpr -> Context -> Bool applyTest (TestExpr expr) ctx = bool where (XPVBool bool) = evalXPathExpr expr ctx @@ -362,27 +388,45 @@ 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 [] +applyTemplate = applyTemplate' --- ------------------------------------ +{- just for debugging +applyTemplate t ctx + = trace msg2 $ res + where + res = applyTemplate' t $ trace msg1 ctx + msg1 = unlines [ "applyTemplate begin" + , "template: " ++ show t + , "context tree: " + , formatXmlTree . subtreeNT . ctxGetNode $ ctx + ] + msg2 = unlines $ [ "applyTemplate end" + , "result trees:" + ] ++ map formatXmlTree res +-} + +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] diff --git a/src/Text/XML/HXT/XSLT/Common.hs b/src/Text/XML/HXT/XSLT/Common.hs --- a/src/Text/XML/HXT/XSLT/Common.hs +++ b/src/Text/XML/HXT/XSLT/Common.hs @@ -26,7 +26,6 @@ , 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 @@ -110,7 +109,16 @@ import Text.XML.HXT.DOM.FormatXmlTree ( formatXmlTree ) -import Text.XML.HXT.XPath.XPathDataTypes( Expr ( LiteralExpr +import Text.XML.HXT.XPath.XPathDataTypes( NavTree + , ntree + , subtreeNT + , upNT + , downNT + , rightNT + , leftNT + , getChildrenNT + + , Expr ( LiteralExpr , FctExpr , GenExpr , PathExpr @@ -123,12 +131,25 @@ , PI , TypeTest ) + , NodeSet (..) , NavXmlTree , XPathValue ( XPVNode , XPVBool , XPVString , XPVError ) + , emptyNodeSet + , singletonNodeSet + , nullNodeSet + , cardNodeSet + , deleteNodeSet + , insertNodeSet + , unionNodeSet + , elemsNodeSet + , fromNodeSet + , toNodeSet + , headNodeSet + , withNodeSet ) import Text.XML.HXT.XPath.XPathParser ( parseXPath ) @@ -144,15 +165,6 @@ import Data.Tree.Class -import Data.NavTree ( NavTree - , ntree - , subtreeNT - , upNT - , downNT - , rightNT - , leftNT - , getChildrenNT - ) import Data.Maybe import Data.List import Data.Char diff --git a/src/Text/XML/HXT/XSLT/XsltArrows.hs b/src/Text/XML/HXT/XSLT/XsltArrows.hs --- a/src/Text/XML/HXT/XSLT/XsltArrows.hs +++ b/src/Text/XML/HXT/XSLT/XsltArrows.hs @@ -138,12 +138,14 @@ none ) ] + >>> + traceValue 3 (("compiled stylesheet:\n" ++) . show) where assStylesheet imports -- do the assembly, the compilation = arrWithCatch (flip assembleStylesheet $ imports) expStylesheet (imports, rest) - = traceMsg 2 "expandStylesheet" + = traceMsg 2 "expand stylesheet" >>> setChildren rest -- remove import rules from stylesheet >>> @@ -259,7 +261,7 @@ >>> traceDoc "XSLT stylesheet applied" >>> - setDocumentStatusFromSystemState "applying XSLT styleshhet" + setDocumentStatusFromSystemState "applying XSLT stylesheet" ) `orElse` issueErr "XSLT: complete document with root node required for stylesheet application"