hxt-xslt-9.1.1/0000755000000000000000000000000011701313734011503 5ustar0000000000000000hxt-xslt-9.1.1/hxt-xslt.cabal0000644000000000000000000000652411701313734014271 0ustar0000000000000000-- arch-tag: Haskell XML Toolbox XSLT Module Name: hxt-xslt Version: 9.1.1 Synopsis: The XSLT modules for HXT. Description: The Haskell XML Toolbox XSLT library. License: OtherLicense License-file: LICENSE Author: Tim Walkenhorst Maintainer: Uwe Schmidt Stability: Experimental Category: XML 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/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 ghc-prof-options: -auto-all -caf-all extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances build-depends: base >= 4 && < 5, containers >= 0.2 && < 1, directory >= 1 && < 2, filepath >= 1 && < 2, parsec >= 2.1 && < 4, hxt >= 9.1 && < 10, hxt-xpath >= 9.1 && < 10 hxt-xslt-9.1.1/LICENSE0000644000000000000000000000212011701313733012502 0ustar0000000000000000The 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. hxt-xslt-9.1.1/Setup.lhs0000644000000000000000000000015711701313734013316 0ustar0000000000000000#!/usr/bin/runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain hxt-xslt-9.1.1/src/0000755000000000000000000000000011701313733012271 5ustar0000000000000000hxt-xslt-9.1.1/src/Text/0000755000000000000000000000000011701313733013215 5ustar0000000000000000hxt-xslt-9.1.1/src/Text/XML/0000755000000000000000000000000011701313733013655 5ustar0000000000000000hxt-xslt-9.1.1/src/Text/XML/HXT/0000755000000000000000000000000011701313733014320 5ustar0000000000000000hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT.hs0000644000000000000000000000130011701313733015440 0ustar0000000000000000-- ------------------------------------------------------------ {- | 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 -- ------------------------------------------------------------ hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT/0000755000000000000000000000000011701313733015112 5ustar0000000000000000hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT/XsltArrows.hs0000644000000000000000000002250411701313733017601 0ustar0000000000000000-- ------------------------------------------------------------ {- | 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 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 Control.Exception ( evaluate ) import Text.XML.HXT.Core 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 (evaluate . f) `catchA` issueExc "arrWithCatch" -- ------------------------------------------------------------ -- | lift prepareXSLTDocument prepareXSLTDoc :: IOSArrow XmlTree XmlTree prepareXSLTDoc = ( arrWithCatch prepareXSLTDocument >>> traceDoc "prepareXSLTDocument" ) `when` documentStatusOk -- | read an XSLT stylesheet readXSLTDoc :: SysConfigList -> IOSArrow String XmlTree readXSLTDoc options = readFromDocument (options ++ defaultOptions) where defaultOptions = [ withCheckNamespaces yes , withValidate no , withPreserveComment no ] -- | 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 ) ] >>> traceValue 3 (("compiled stylesheet:\n" ++) . show) where assStylesheet imports -- do the assembly, the compilation = arrWithCatch (flip assembleStylesheet $ imports) expStylesheet (imports, rest) = traceMsg 2 "expand stylesheet" >>> 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 stylesheet" ) `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) -} hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT/Names.hs0000644000000000000000000001201011701313733016503 0ustar0000000000000000-- ------------------------------------------------------------ {- | 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 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 hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT/Compilation.hs0000644000000000000000000005007111701313733017727 0ustar0000000000000000-- ------------------------------------------------------------ {- | 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.Parser.XmlCharParser ( withNormNewline ) 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 (withNormNewline (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> 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> 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> 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> 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> Template compileComment = TemplComment . compileTemplate . getChildren compileProcInstr :: XmlTree -> Template compileProcInstr node = TemplProcInstr name content where name = parseAVT> Template compileLiteralResultElement node = TemplElement compQName nsUris attribSets content where nsUris = extractAddUris node compQName = LiteralQName $ fromJust $ getElemName node attribSets = UsedAttribSets $ parseExNames> 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> Template compileApplyImports _node = TemplApplyImports compileCallTempl :: XmlTree -> Template compileCallTempl node = TemplCall name args where name = parseExName> Template compileTemplVariable = TemplVariable . compileVariable -- ----------------------------------- compileCopy :: XmlTree -> Template compileCopy node = TemplCopy attribSets $ compileTemplate (getChildren node) where attribSets = UsedAttribSets $ parseExNames> Template compileCopyOf node = TemplCopyOf $ parseExpr> 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> 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> 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> AttributeSet compileAttributeSet node = AttribSet name usedsets template where name = parseExName> SortKey compileSortKey node = SortK expr dataType order where expr = parseStringExpr> String -> [NTest] parseNTests uris = map (parseNTest uris) . words compileStrips,compilePreserves :: XmlTree -> [NTest] compileStrips node = parseNTests> (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> ["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))> 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 -- just for debugging -- import Debug.Trace(trace) -- import Text.XML.HXT.XPath.NavTree (subtreeNT) -- ------------------------------------------------------------ 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 . singletonNodeSet $ node) where filterXPath (XPVError err) = error err -- 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 vars = map (\(name, val) -> ((exUri name, exLocal name), val)) varList varList = Map.toAscList $ locVars `Map.union` globVars evalXPathExpr _ CtxEmpty = error "internal error in evalXPathExpr in XSLT module" evalRtf :: Template -> String -> Context -> XPathValue evalRtf template rtfId ctx = XPVNode $ singletonNodeSet (ntree rtfRoot) where rtfRoot = setAttribute rootIdName ("rtf " ++ rtfId) $ mkRoot [] $ applyTemplate template ctx rootIdName = mkQName "" "rootId" "" -- ------------------------------------------------------------ applySelect :: SelectExpr -> Context -> [NavXmlTree] applySelect = applySelect' {- 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) = attributesFirst . fromNodeSet $ nodes extractNodes r = error $ "XPATH-Expression in select or match attribute returned a value of the wrong type (" ++ take 15 (show r) ++ "...)" attributesFirst = uncurry (++) . partition (isAttr . subtreeNT) -- ------------------------------------------------------------ applyTest :: TestExpr -> Context -> Bool applyTest (TestExpr expr) ctx = bool where (XPVBool bool) = evalXPathExpr expr ctx applyStringExpr :: StringExpr -> Context -> String applyStringExpr (StringExpr expr) ctx = string where (XPVString string) = evalXPathExpr expr ctx applyMatch :: MatchExpr -> Context -> Bool applyMatch (MatchExpr expr) ctx = matchBySelect (SelectExpr expr) (ctxGetNode ctx) ctx where matchBySelect :: SelectExpr -> NavXmlTree -> Context -> Bool matchBySelect _ _ CtxEmpty = False matchBySelect expr' matchNode ctx' | matchNode `isNotInNodeList` applySelect expr' ctx' = matchBySelect expr' matchNode $ ctxSetNodes (maybeToList $ upNT $ ctxGetNode ctx') ctx' | otherwise = True -- ------------------------------------ applyComputedQName :: ComputedQName -> Context -> QName applyComputedQName (LiteralQName qName) ctx = lookupAlias (getAliases $ ctxGetStylesheet ctx) qName applyComputedQName (CompQName uris nameATV nsATV) ctx = if null nsuri && not (null pref) then mkQName pref loc $ lookupPrefix uris pref else mkQName pref loc nsuri where nsuri = applyStringExpr nsATV ctx (pref, loc) = if null loc' then ("", pref') else (pref', tail loc') (pref', loc') = span (/=':') $ applyStringExpr nameATV ctx -- ------------------------------------ applyComposite :: Template -> Context -> [XmlTree] applyComposite (TemplComposite templates) ctx = concat $ reverse $ fst $ foldl applyElem ([], ctx) templates where applyElem :: ([[XmlTree]], Context) -> Template -> ([[XmlTree]], Context) applyElem (nodes, ctx') (TemplVariable v) = (nodes, processLocalVariable v Map.empty ctx') applyElem (nodes, ctx') t = (applyTemplate t ctx' : nodes, ctx') applyComposite _ _ = [] applyForEach :: Template -> Context -> [XmlTree] applyForEach (TemplForEach expr sorting template) ctx = processContext sortedCtx $ applyTemplate template where sortedCtx = applySorting sorting ctxWOrule nodes ctxWOrule = ctxSetRule Nothing $ ctx nodes = applySelect expr ctx applyForEach _ _ = [] applyChoose :: Template -> Context -> [XmlTree] applyChoose (TemplChoose whenList) ctx = applyWhenList whenList ctx applyChoose _ _ = [] applyWhenList :: [When] -> Context -> [XmlTree] applyWhenList [] _ = [] applyWhenList ((WhenPart expr template):xs) ctx | applyTest expr ctx = applyTemplate template ctx | otherwise = applyWhenList xs ctx applyMessage :: Template -> Context -> [XmlTree] applyMessage (TemplMessage halt template) ctx | halt = error $ "Message(fatal): " ++ msg | otherwise = [] -- 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 = 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] 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 hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT/CompiledStylesheet.hs0000644000000000000000000002006011701313733021252 0ustar0000000000000000-- ------------------------------------------------------------ {- | 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 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 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 hxt-xslt-9.1.1/src/Text/XML/HXT/XSLT/Common.hs0000644000000000000000000003666211701313733016713 0ustar0000000000000000-- ------------------------------------------------------------ {- | 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.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( NavTree , ntree , subtreeNT , upNT , downNT , rightNT , leftNT , getChildrenNT , Expr ( LiteralExpr , FctExpr , GenExpr , PathExpr ) , Op ( Union ) , LocationPath ( LocPath ) , Path ( Rel ) , XStep ( Step ) , NodeTest ( NameTest , 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 ) 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.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, "")] --------------------------- hxt-xslt-9.1.1/examples/0000755000000000000000000000000011701313734013321 5ustar0000000000000000hxt-xslt-9.1.1/examples/Makefile0000644000000000000000000000037611701313734014767 0ustar0000000000000000# Example Applications # EXAMPLES = hparser MORE_SAMPLES = 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 hxt-xslt-9.1.1/examples/hparser/0000755000000000000000000000000011701313733014764 5ustar0000000000000000hxt-xslt-9.1.1/examples/hparser/HXmlParser.hs0000644000000000000000000001104011701313733017341 0ustar0000000000000000-- ------------------------------------------------------------ {- | Module : HXmlParser Copyright : Copyright (C) 2005-2010 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.Core 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 -- ------------------------------------------------------------ -- | -- 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 :: SysConfigList -> String -> IOSArrow b Int parser config src = configSysVars config -- set all global config options, the output file and all >>> -- other user options are stored as key-value pairs in the system state -- and can be referenced with "getSysAttr" readDocument [] src -- no more special read options needed >>> ( ( traceMsg 1 "start processing document" >>> ( processDocument $< getSysAttr "xslt" ) -- ask for the xslt schema to be applied >>> traceMsg 1 "document processing finished" ) `when` documentStatusOk ) >>> traceSource >>> traceTree >>> ( writeDocument [] $< getSysAttr "output-file" ) -- ask for the output file stored in the system configuration >>> getErrStatus -- simple example of a processing arrow processDocument :: String -> IOSArrow XmlTree XmlTree processDocument xsltUri = traceMsg 1 ("applying XSLT stylesheet " ++ show xsltUri) >>> xsltApplyStylesheetFromURI xsltUri -- ------------------------------------------------------------ -- -- the options definition part -- see doc for System.Console.GetOpt progName :: String progName = "HXmlParser" options :: [OptDescr SysConfig] options = generalOptions ++ inputOptions ++ outputOptions ++ [ Option "" ["xslt"] (ReqArg (withSysAttr "xslt") "STYLESHEET") "STYLESHEET is the uri of the XSLT stylesheet to be applied" ] ++ showOptions 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 = "HXT XSLT Transformer\n\n" ++ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]" use = usageInfo header options cmdlineOpts :: [String] -> IO (SysConfigList, String) cmdlineOpts argv = case (getOpt Permute options argv) of (ol,n,[]) -> do sa <- src n help (getConfigAttr 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 "1" _ = usage [] help _ [] = usage ["no input uri or file given\n"] help _ _ = return () -- ------------------------------------------------------------ hxt-xslt-9.1.1/examples/hparser/Makefile0000644000000000000000000000100311701313733016416 0ustar0000000000000000HXT_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 hxt-xslt-9.1.1/examples/hparser/xslt/0000755000000000000000000000000011701313734015757 5ustar0000000000000000hxt-xslt-9.1.1/examples/hparser/xslt/nspropXSLT.xsl0000644000000000000000000000074311701313734020547 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/default_rules.xsl0000644000000000000000000000133111701313733021342 0ustar0000000000000000 Attributes matched with default rules: Attributes matched with default rules in mode m: Match content with default rules hxt-xslt-9.1.1/examples/hparser/xslt/strip_example.xml0000644000000000000000000000052611701313734021360 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/lre_stylesheet.xsl0000644000000000000000000000027611701313734021547 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/prio.xsl0000644000000000000000000000077611701313734017472 0ustar0000000000000000 unreachable prio.xsl match_element_type3 occurance 2 (before include) prio.xsl match_nested_element occurance 2 (after include) =====6= hxt-xslt-9.1.1/examples/hparser/xslt/comment_pi.xsl0000644000000000000000000000075611701313733020650 0ustar0000000000000000 simple-comment -c=a-b ------------- pi-content?> hxt-xslt-9.1.1/examples/hparser/xslt/Makefile0000644000000000000000000000322511701313734017421 0ustar0000000000000000# $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' \ 'copy_rec.xsl example0.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 hxt-xslt-9.1.1/examples/hparser/xslt/prio_imp1_2.xsl0000644000000000000000000000064411701313734020633 0ustar0000000000000000 unreachable (prio_imp1_2.xsl) match_document prio_imp1_2.xsl match_element_type2 =====5= [TXT] hxt-xslt-9.1.1/examples/hparser/xslt/exdoc2.xml0000644000000000000000000000114611701313733017666 0ustar0000000000000000 some text some more text . hxt-xslt-9.1.1/examples/hparser/xslt/example_document2.xml0000644000000000000000000000106511701313733022115 0ustar0000000000000000 some text some more text hxt-xslt-9.1.1/examples/hparser/xslt/default_prio.xsl0000644000000000000000000001133211701313733021163 0ustar0000000000000000 Match element textnode length "" comment node: pi node: root-node attribute with priority name : || hxt-xslt-9.1.1/examples/hparser/xslt/strip_example.xsl0000644000000000000000000000043211701313734021362 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/invoice.xml0000644000000000000000000000031111701313734020130 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/for_each_when_if.xsl0000644000000000000000000000200511701313733021750 0ustar0000000000000000 Nr:: with if: Number is larger than 3 Number is larger than 2 Number is larger than 1 Number is larger than 0 with choose: Number is larger than 3 Number is larger than 2 Number is larger than 1 Number is larger than 0 Number is smaller than 1 hxt-xslt-9.1.1/examples/hparser/xslt/strip_space_imp.xsl0000644000000000000000000000123111701313734021665 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/copy_copy_of.xsl0000644000000000000000000000151111701313733021174 0ustar0000000000000000 === copy-of of /: === copy-of of /: with variable V === copy on /: ...should've been empty copy recursively: hxt-xslt-9.1.1/examples/hparser/xslt/empty.xml0000644000000000000000000000001011701313733017625 0ustar0000000000000000hxt-xslt-9.1.1/examples/hparser/xslt/lre.xsl0000644000000000000000000000044111701313734017270 0ustar0000000000000000 textnode hxt-xslt-9.1.1/examples/hparser/xslt/doc_level_prep_exp.xsl0000644000000000000000000000067011701313733022347 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/strip_space.xsl0000644000000000000000000000035711701313734021030 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/invoiceSort.xsl0000644000000000000000000000067311701313734021021 0ustar0000000000000000
hxt-xslt-9.1.1/examples/hparser/xslt/invoice.xsl0000644000000000000000000000051211701313734020141 0ustar0000000000000000
hxt-xslt-9.1.1/examples/hparser/xslt/testNS.xsl0000644000000000000000000000276211701313734017736 0ustar0000000000000000 xsl:template match="xslbread:toast" xsl:template match="xslcheeseX:camembert" xmlns:xslcheeseX="http://cheese.org" xsl:template match="@xslcheese:*" xsl:template match="xslcheese:*" xsl:template match="*" hxt-xslt-9.1.1/examples/hparser/xslt/inc_lre.xsl0000644000000000000000000000021211701313734020115 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/strip_space_with_rules.xsl0000644000000000000000000000226111701313734023271 0ustar0000000000000000 ===================1) ===================2) hxt-xslt-9.1.1/examples/hparser/xslt/prio_imp1_1.xsl0000644000000000000000000000056111701313734020630 0ustar0000000000000000 prio_imp1_1.xsl match / =====1= unreachable (prio_imp1_1.xsl) match_document hxt-xslt-9.1.1/examples/hparser/xslt/prio_imp2.xsl0000644000000000000000000000123511701313734020410 0ustar0000000000000000 unreachable prio_imp2.xsl match_document Prio 2.0 occurance 1 prio_imp2.xsl match_document Prio 2.0 occurance 2 =====2= unreachable prio_imp2.xsl match_document Prio 1.0 occurance 1 unreachable prio_imp2.xsl match_document Prio 1.0 occurance 2 hxt-xslt-9.1.1/examples/hparser/xslt/example2.xml0000644000000000000000000000003411701313733020212 0ustar0000000000000000hxt-xslt-9.1.1/examples/hparser/xslt/alias.xsl0000644000000000000000000000076711701313733017611 0ustar0000000000000000 This XSL stylesheet is created from literal result elements hxt-xslt-9.1.1/examples/hparser/xslt/nspropXSLTyyy.xsl0000644000000000000000000000073511701313734021323 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/recAdd.xsl0000644000000000000000000000053311701313734017672 0ustar0000000000000000 TRUE hxt-xslt-9.1.1/examples/hparser/xslt/sorting.xsl0000644000000000000000000000176711701313734020207 0ustar0000000000000000 Using for-each: : Using apply-template Param p: hxt-xslt-9.1.1/examples/hparser/xslt/example_document3.xml0000644000000000000000000000014111701313733022110 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/vars_and_params_imp.xsl0000644000000000000000000000224511701313734022517 0ustar0000000000000000 Value of variable A:: Value of variable B:: Value of variable C:: Value of parameter P1:: Value of parameter P2:: Value of parameter p3:: Value of parameter p3:: hxt-xslt-9.1.1/examples/hparser/xslt/vars_and_params.xsl0000644000000000000000000000541311701313734021652 0ustar0000000000000000 Value of variable A:: Value of variable B:: Value of variable C:: Introducing local variable B... Value of variable A:: Value of variable B:: Value of variable C:: Setting variable C to default Value of variable A:: Value of variable B:: Value of variable C:: Value of variable A:: Value of variable B:: Value of variable C:: Value of parameter P1:: Value of parameter P2:: Value of parameter p3:: Value of parameter p3:: hxt-xslt-9.1.1/examples/hparser/xslt/doc_level_prep.xsl0000644000000000000000000000114311701313733021467 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/imp_lre.xsl0000644000000000000000000000021111701313734020130 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/prio_inc.xsl0000644000000000000000000000101211701313734020303 0ustar0000000000000000 prio_inc.xsl match_element_type2 =====3= prio_inc.xsl match_nested_element occurance 1 prio_inc.xsl match_element_type3 occurance 2 (after being included) =====7= hxt-xslt-9.1.1/examples/hparser/xslt/example_document.xml0000644000000000000000000000067611701313733022042 0ustar0000000000000000 some text some more text hxt-xslt-9.1.1/examples/hparser/xslt/alias2.xsl0000644000000000000000000000052711701313733017665 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/attset_imp.xsl0000644000000000000000000000110511701313733020654 0ustar0000000000000000 att1Loc1 att1_1Loc1 att1_2Loc1 att2Loc1 hxt-xslt-9.1.1/examples/hparser/xslt/elems_and_attrs.xsl0000644000000000000000000000105611701313733021654 0ustar0000000000000000 value still within attr textnode hxt-xslt-9.1.1/examples/hparser/xslt/prio_imp1.xsl0000644000000000000000000000102011701313734020377 0ustar0000000000000000 unreachable (prio_imp1.xsl) match_document prio_imp1.xsl match_element_type2 =====4= hxt-xslt-9.1.1/examples/hparser/xslt/testEX.xsl0000644000000000000000000000104011701313734017716 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/testNS.xml0000644000000000000000000000037111701313734017722 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/match_by_for_each.xsl0000644000000000000000000000111211701313734022116 0ustar0000000000000000 Match: a/b Match: b Match: * Match: the rest hxt-xslt-9.1.1/examples/hparser/xslt/stripXSLT.xsl0000644000000000000000000000150211701313734020361 0ustar0000000000000000 hxt-xslt-9.1.1/examples/hparser/xslt/attset.xsl0000644000000000000000000000065011701313733020013 0ustar0000000000000000 att1GLOB1 att1_1Glob1 att1GLOB2