diff --git a/LICENCE b/LICENCE deleted file mode 100644 --- a/LICENCE +++ /dev/null @@ -1,9 +0,0 @@ -The MIT License - -Copyright (c) 2005 Uwe Schmidt, Martin Schmidt, Torben Kuseler - -Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,9 @@ +The MIT License + +Copyright (c) 2005 Uwe Schmidt, Martin Schmidt, Torben Kuseler + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/examples/hparser/HXmlParser.hs b/examples/hparser/HXmlParser.hs --- a/examples/hparser/HXmlParser.hs +++ b/examples/hparser/HXmlParser.hs @@ -2,7 +2,7 @@ {- | Module : HXmlParser - Copyright : Copyright (C) 2005 Uwe Schmidt + Copyright : Copyright (C) 2005-2010 Uwe Schmidt License : MIT Maintainer : Uwe Schmidt @@ -27,16 +27,14 @@ module Main where -import Text.XML.HXT.Arrow +import Text.XML.HXT.Core import Text.XML.HXT.XSLT ( xsltApplyStylesheetFromURI ) -import System.IO -- import the IO and commandline option stuff +import System.IO -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit -import Data.Maybe - -- ------------------------------------------------------------ -- | @@ -45,16 +43,16 @@ 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 + 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 +exitProg :: Bool -> IO a +exitProg True = exitWith (ExitFailure (-1)) +exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------ @@ -64,107 +62,92 @@ -- get wellformed document, validates document, propagates and check namespaces -- and controls output -parser :: Attributes -> String -> IOSArrow b Int -parser al src - = readDocument al src +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 al - >>> - traceMsg 1 "document processing finished" - ) - `when` - documentStatusOk + >>> + ( processDocument $< getSysAttr "xslt" ) -- ask for the xslt schema to be applied + >>> + traceMsg 1 "document processing finished" + ) + `when` + documentStatusOk ) >>> traceSource >>> traceTree >>> - writeDocument al (fromMaybe "-" . lookup a_output_file $ al) `whenNot` hasAttr "no-output" + ( writeDocument [] $< getSysAttr "output-file" ) -- ask for the output file stored in the system configuration >>> getErrStatus -- simple example of a processing arrow -processDocument :: Attributes -> IOSArrow XmlTree XmlTree -processDocument al - | applyXSLT - = traceMsg 1 ("applying XSLT stylesheet " ++ show xsltUri) - >>> - xsltApplyStylesheetFromURI xsltUri - | extractText - = traceMsg 1 "selecting plain text" - >>> - processChildren (deep isText) - | otherwise - = this - where - applyXSLT = hasEntry "xslt" $ al - extractText = optionIsSet "show-text" $ al - xsltUri = lookup1 "xslt" $ al +processDocument :: String -> IOSArrow XmlTree XmlTree +processDocument xsltUri + = traceMsg 1 ("applying XSLT stylesheet " ++ show xsltUri) + >>> + xsltApplyStylesheetFromURI $< getSysAttr xsltUri -- ------------------------------------------------------------ -- -- the options definition part -- see doc for System.Console.GetOpt -progName :: String -progName = "HXmlParser" +progName :: String +progName = "HXmlParser" -options :: [OptDescr (String, String)] +options :: [OptDescr SysConfig] options = generalOptions ++ inputOptions ++ - relaxOptions - ++ outputOptions ++ - [ Option "" ["xslt"] (ReqArg (att "xslt") "STYLESHEET") "STYLESHEET is the uri of the XSLT stylesheet to be applied" - , Option "q" ["no-output"] (NoArg ("no-output", "1")) "no output of resulting document" - , Option "x" ["show-text"] (NoArg ("show-text", "1")) "output only the raw text, remove all markup" + [ Option "" ["xslt"] (ReqArg (withSysAttr "xslt") "STYLESHEET") "STYLESHEET is the uri of the XSLT stylesheet to be applied" ] ++ showOptions - where - att n v = (n, v) -usage :: [String] -> IO a +usage :: [String] -> IO a usage errl | null errl - = do - hPutStrLn stdout use - exitProg False + = do + hPutStrLn stdout use + exitProg False | otherwise - = do - hPutStrLn stderr (concat errl ++ "\n" ++ use) - exitProg True + = do + hPutStrLn stderr (concat errl ++ "\n" ++ use) + exitProg True where - header = "HXmlParser - Validating XML Parser of the Haskell XML Toolbox with Arrow Interface\n" ++ - "XML well-formed checker, DTD validator, Relax NG validator and XSLT transformer.\n\n" ++ + header = "HXT XSLT Transformer\n\n" ++ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]" use = usageInfo header options -cmdlineOpts :: [String] -> IO (Attributes, String) +cmdlineOpts :: [String] -> IO (SysConfigList, String) cmdlineOpts argv = case (getOpt Permute options argv) of (ol,n,[]) - -> do - sa <- src n - help (lookup a_help ol) sa - return (ol, sa) + -> do + sa <- src n + help (getConfigAttr a_help ol) sa + return (ol, sa) (_,_,errs) - -> usage errs + -> usage errs where - src [] = return [] - src [uri] = return uri - src _ = usage ["only one input uri or file allowed\n"] + src [] = return [] + src [uri] = return uri + src _ = usage ["only one input uri or file allowed\n"] - help (Just _) _ = usage [] - help Nothing [] = usage ["no input uri or file given\n"] - help Nothing _ = return () + help "1" _ = usage [] + help _ [] = usage ["no input uri or file given\n"] + help _ _ = return () -- ------------------------------------------------------------ diff --git a/hxt-xslt.cabal b/hxt-xslt.cabal --- a/hxt-xslt.cabal +++ b/hxt-xslt.cabal @@ -1,17 +1,18 @@ -- arch-tag: Haskell XML Toolbox XSLT Module -name: hxt-xslt -version: 8.5.2 -license: OtherLicense -license-file: LICENCE -maintainer: Uwe Schmidt -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. -homepage: http://www.fh-wedel.de/~si/HXmlToolbox/index.html -copyright: Copyright (c) 2005-2010 Uwe Schmidt -build-type: Simple -cabal-version: >=1.6 +Name: hxt-xslt +Version: 9.0.0 +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 @@ -86,6 +87,6 @@ directory >= 1 && < 2, filepath >= 1 && < 2, parsec >= 2.1 && < 4, - hxt >= 8.5 && < 9, - hxt-xpath >= 8.5 && < 9 + hxt >= 9 && < 10, + hxt-xpath >= 9 && < 10 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 @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: Application.hs,v 1.7 2007/05/02 06:41:05 hxml Exp $ The transformation functions for XSLT transformation of XML documents @@ -18,7 +17,7 @@ -- ------------------------------------------------------------ -module Text.XML.HXT.XSLT.Application +module Text.XML.HXT.XSLT.Application ( applyStylesheet -- CompiledStylesheet -> XmlTree -> [XmlTree] , applyStylesheetWParams -- Map ExName Expr -> CompiledStylesheet -> XmlTree -> [XmlTree] , XPathParams @@ -31,7 +30,7 @@ import Data.Char import Data.List import Data.Map (Map) -import qualified Data.Map as Map hiding (Map) +import qualified Data.Map as Map hiding (Map) import Data.Maybe -- just for debugging @@ -47,7 +46,7 @@ type ParamSet = VariableSet data Context = Ctx NavXmlTree -- current node - [NavXmlTree] -- current node list + [NavXmlTree] -- current node list Int -- pos. of curr-node 1..length Int -- length of node list VariableSet -- glob. Var @@ -98,10 +97,10 @@ 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 - + = 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) @@ -109,13 +108,13 @@ 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 + 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 @@ -137,8 +136,8 @@ -- ------------------------------------------------------------ -applySelect :: SelectExpr -> Context -> [NavXmlTree] -applySelect = applySelect' +applySelect :: SelectExpr -> Context -> [NavXmlTree] +applySelect = applySelect' {- just for debugging applySelect e@(SelectExpr expr) ctx = trace msg2 $ res @@ -151,16 +150,16 @@ -} applySelect' :: SelectExpr -> Context -> [NavXmlTree] -applySelect' (SelectExpr expr) ctx = +applySelect' (SelectExpr expr) ctx = extractNodes xpathResult - where + 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 (" + 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) + attributesFirst = uncurry (++) . partition (isAttr . subtreeNT) -- ------------------------------------------------------------ @@ -178,35 +177,35 @@ 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' + matchBySelect expr' matchNode ctx' + | matchNode `isNotInNodeList` applySelect expr' ctx' + = matchBySelect expr' matchNode $ ctxSetNodes (maybeToList $ upNT $ ctxGetNode ctx') ctx' | otherwise - = True + = True -- ------------------------------------ applyComputedQName :: ComputedQName -> Context -> QName -applyComputedQName (LiteralQName qName) ctx = +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') + 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 + 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') @@ -217,14 +216,14 @@ applyForEach :: Template -> Context -> [XmlTree] applyForEach (TemplForEach expr sorting template) ctx = processContext sortedCtx $ applyTemplate template - where + 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 @@ -236,16 +235,16 @@ applyWhenList [] _ = [] applyWhenList ((WhenPart expr template):xs) ctx | applyTest expr ctx - = applyTemplate template ctx + = applyTemplate template ctx | otherwise - = applyWhenList xs ctx + = applyWhenList xs ctx applyMessage :: Template -> Context -> [XmlTree] applyMessage (TemplMessage halt template) ctx | halt - = error $ "Message(fatal): " ++ msg + = error $ "Message(fatal): " ++ msg | otherwise - = [] -- trace ("Message(trace): " ++ msg) [] + = [] -- trace ("Message(trace): " ++ msg) [] where msg = showTrees content content = applyTemplate template ctx @@ -257,7 +256,7 @@ applyElement :: Template -> Context -> [XmlTree] applyElement (TemplElement compQName uris attribSets template) ctx = return $ createElement name uris aliases fullcontent - where + where aliases = getAliases $ ctxGetStylesheet ctx name = applyComputedQName compQName ctx fullcontent = applyAttribSets [] attribSets ctx ++ applyTemplate template ctx @@ -270,23 +269,23 @@ createElement :: QName -> UriMapping -> NSAliasing -> [XmlTree] -> XmlTree createElement name uris aliases fullcontent = mkElement name (nsAttrs ++ distinctAttribs) content - where + where nsAttrs = uriMap2Attrs $ aliasUriMapping aliases uris - distinctAttribs = nubBy eqAttr $ reverse attribs + distinctAttribs = nubBy eqAttr $ reverse attribs (attribs, content) = span (isAttr) fullcontent - eqAttr node1 node2 = equivQName (fromJust $ getAttrName node1) (fromJust $ getAttrName node2) + eqAttr node1 node2 = equivQName (fromJust $ getAttrName node1) (fromJust $ getAttrName node2) applyAttribute :: Template -> Context -> [XmlTree] applyAttribute (TemplAttribute compQName template) ctx = return $ mkAttr qName content - where + where qName = applyComputedQName compQName ctx content = applyTemplate template ctx applyAttribute _ _ = [] - + applyText :: Template -> Context -> [XmlTree] applyText (TemplText s) _ = [mkText s] @@ -302,7 +301,7 @@ applyComment :: Template -> Context -> [XmlTree] -applyComment (TemplComment content) ctx = +applyComment (TemplComment content) ctx = return $ mkCmt $ format $ collectTextnodes $ applyTemplate content ctx where format "" = "" -- could probably move to hxt...? @@ -316,7 +315,7 @@ applyProcInstr (TemplProcInstr nameExpr template) ctx = return $ mkPi (mkName name) [mkText . format . collectTextnodes . applyTemplate template $ ctx] where - name = applyStringExpr nameExpr ctx + 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 @@ -328,7 +327,7 @@ applyApplTempl :: Template -> Context -> [XmlTree] applyApplTempl (TemplApply expr mode args sorting) ctx = applyMatchRulesToEntireContext params rules mode sortedCtx - where + where params = createParamSet args ctx sortedCtx = applySorting sorting ctx nodes nodes = maybe (getChildrenNT $ ctxGetNode ctx) @@ -340,7 +339,7 @@ applyImports :: Template -> Context -> [XmlTree] -applyImports (TemplApplyImports) ctx= +applyImports (TemplApplyImports) ctx= applyMatchRules Map.empty rules mode ctx where rules = getRuleImports currRule @@ -365,12 +364,12 @@ 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 + | 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 @@ -383,19 +382,19 @@ = concatMap expandRoot . xPValue2XmlTrees . evalXPathExpr expr where expandRoot node - | isRoot node = getChildren node - | otherwise = return node + | isRoot node = getChildren node + | otherwise = return node applyCopyOf _ = const [] -- ------------------------------------------------------------ applyTemplate :: Template -> Context -> [XmlTree] -applyTemplate = applyTemplate' +applyTemplate = applyTemplate' {- just for debugging applyTemplate t ctx - = trace msg2 $ res + = trace msg2 $ res where res = applyTemplate' t $ trace msg1 ctx msg1 = unlines [ "applyTemplate begin" @@ -424,13 +423,13 @@ 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' (TemplVariable _) = const [] -- trace ("Warning: Unreacheable variable: " ++ show (getVarName v)) const [] -- ------------------------------------------------------------ -- "Main" : applyStylesheetWParams :: XPathParams -> CompiledStylesheet -> XmlTree -> [XmlTree] -applyStylesheetWParams inputParams cs@(CompStylesheet matchRules _ vars _ strips _) rawDoc = +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 @@ -445,7 +444,7 @@ -- calling named- and applying match-rules applyMatchRulesToChildren :: ParamSet -> [MatchRule] -> (Maybe ExName) -> Context -> [XmlTree] -applyMatchRulesToChildren args rules mode ctx = +applyMatchRulesToChildren args rules mode ctx = applyMatchRulesToEntireContext args rules mode childCtx where childCtx = ctxSetNodes (getChildrenNT $ ctxGetNode ctx) ctx @@ -455,8 +454,8 @@ 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) +applyMatchRules args (rule:rules) mode ctx = + maybe (applyMatchRules args rules mode ctx) id (applyMatchRule args rule mode ctx) @@ -470,33 +469,33 @@ instantiateMatchRule :: ParamSet -> MatchRule -> Context -> [XmlTree] instantiateMatchRule args (MatRule _ _ _ _ params content) ctx = applyTemplate content ctxNew - where + where ctxNew = incRecDepth $ processParameters params args $ clearLocalVariables ctx instantiateNamedRule :: ParamSet -> NamedRule -> Context -> [XmlTree] instantiateNamedRule args (NamRule _ params content) ctx = applyTemplate content ctxNew - where + 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 + | 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 @@ -505,7 +504,7 @@ -- created local variable to the context processLocalVariable :: Variable -> ParamSet -> Context -> Context -processLocalVariable var@(MkVar _ name _) arguments ctx = +processLocalVariable var@(MkVar _ name _) arguments ctx = addVariableBinding name val ctx where val = evalVariableWParamSet arguments ctx var @@ -517,9 +516,9 @@ evalVariableWParamSet :: ParamSet -> Context -> Variable -> XPathValue evalVariableWParamSet ps ctx (MkVar isPar name exprOrRtf) | isPar - = maybe (resultFromVar exprOrRtf) id $ Map.lookup name ps + = maybe (resultFromVar exprOrRtf) id $ Map.lookup name ps | otherwise - = resultFromVar exprOrRtf + = resultFromVar exprOrRtf where resultFromVar (Left expr) = evalXPathExpr expr ctx resultFromVar (Right rtf) = evalRtf rtf (show (recDepth ctx) ++ " " ++ show name) ctx @@ -540,25 +539,25 @@ 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 = +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 = +applySorting sortKeys ctx nodes = ctxSetNodes resultOrder ctx where resultOrder = snd $ unzip sortedKVs @@ -580,14 +579,14 @@ applySortKey (SortK expr typeATV orderATV) ctx | typ /= "number" && - typ /= "text" - = error $ "unsupported type in xsl:sort: " ++ typ + 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 + = error $ "order in xsl:sort element must be ascending or descending. Found: " ++ ordering | otherwise - = (extractFct, cmpFct) + = (extractFct, cmpFct) where isNum = typ == "number" isDesc = ordering == "descending" @@ -595,27 +594,27 @@ typ = applyStringExpr typeATV ctx extractFct ctx' - = let - val = applyStringExpr expr ctx' - in + = 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 isDesc then invertOrd else id ) . ( if isNum then cmpNum a else cmpString a ) cmpNum (Left n1) (Left n2) - = compare n1 n2 + = compare n1 n2 cmpNum _ _ - = error "internal error in cmpNum in applySortKey" + = 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... + = compare (map toLower s1) (map toLower s2) -- The text comparison still needs to be improved... cmpString _ _ - = error "internal error in cmpString in applySortKey" + = error "internal error in cmpString in applySortKey" invertOrd :: Ordering -> Ordering invertOrd EQ = EQ @@ -629,20 +628,20 @@ fixupNS = compressNS . disambigNS compressNS :: XmlTree -> XmlTree -compressNS = +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) + isImportant n = not (isNsAttr n) || not ((localPart $ fromJust $ getAttrName n) `Map.member` uris) disambigNS :: XmlTree -> XmlTree -disambigNS = +disambigNS = mapTreeCtx step $ Map.fromAscList [("xml", xmlNamespace), ("xmlns", xmlnsNamespace)] where step uris node @@ -652,8 +651,8 @@ | otherwise = (uris, node) disambigElem :: UriMapping -> XNode -> (UriMapping, XNode) -disambigElem nsMap element = - (newNsMap, XTag +disambigElem nsMap element = + (newNsMap, XTag (remapNsName newNsMap $ fromJust $ getElemName element) $ map (changeName $ remapNsName newNsMap) $ fromJust $ getAttrl element ) where @@ -663,7 +662,7 @@ (element : map getNode (fromJust $ getAttrl element)) newPrefs = filter (`notElem` oldPrefs) ["ns" ++ show i | i <- [(1::Int)..]] oldPrefs = Map.keys nsMap - oldUris = Map.elems nsMap + oldUris = Map.elems nsMap remapNsName :: UriMapping -> QName -> QName remapNsName nsMap name @@ -672,8 +671,8 @@ ( isJust luUri && fromJust luUri == nsUri - ) = name - | otherwise = mkQName newPref (localPart name) nsUri + ) = name + | otherwise = mkQName newPref (localPart name) nsUri {- if maybe (nsUri=="") (== nsUri) luUri then name @@ -682,7 +681,7 @@ -} where luUri = Map.lookup (namePrefix name) nsMap - newPref = head $ (++ (error $ "int. error: No prefix for " ++ show name ++ " " ++ show nsMap ++ " " ++ show luUri ++ " " ++ show nsUri)) + 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 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 @@ -51,8 +51,8 @@ -- Namespace functions , ExName(ExName) -- String (local) -> String (uri) -> ExName , mkExName -- QName -> ExName - , exLocal -- ExName -> String - , exUri -- ExName -> String + , 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) @@ -85,59 +85,59 @@ import Control.Arrow.ListArrow import Control.Arrow.ArrowList -import Text.XML.HXT.Arrow.XmlArrow ( xshow - ) +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.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.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 + , 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 - ) + , 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 @@ -150,38 +150,38 @@ , 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.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.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. +-- "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 = +mapTreeCtx f c tree = mkTree b $ map (mapTreeCtx f cN) $ getChildren tree - where + where (cN, b) = f c $ getNode tree filterTree :: Tree t => (a -> Bool) -> t a -> Maybe (t a) @@ -190,19 +190,19 @@ else Nothing where node = getNode tree --- "filter" on a tree with a context. +-- "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 + if b then Just $ mkTree node $ mapMaybe (filterTreeCtx p cN) $ getChildren tree else Nothing - where + 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)) +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) @@ -211,12 +211,12 @@ unzipTree :: Functor t => t (a,b) -> (t a, t b) unzipTree = fmap fst &&& fmap snd -showTrees :: [XmlTree] -> String +showTrees :: [XmlTree] -> String showTrees ts - = concat + = concat (runLA (xshow (constL ts)) $ undefined) ---------------------------- +--------------------------- -- Xml Functions collectTextnodes :: [XmlTree] -> String @@ -239,7 +239,7 @@ tryFetchAttribute node qn | isElem node = - if null candidates + if null candidates then Nothing else if length candidates > 1 @@ -247,8 +247,8 @@ else Just $ collectTextnodes $ getChildren $ head candidates - | otherwise = Nothing - where + | otherwise = Nothing + where candidates = filter (isAttrType qn) $ fromJust $ getAttrl node fetchAttributeWDefault :: XmlNode n => n -> QName -> String -> String @@ -264,14 +264,14 @@ setAttribute qn val node | isElem node = setElemAttrl (newA : attrs) node | otherwise = error $ "setAttribute on none-element node" -- how print an XmlNode... - where + 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) @@ -288,11 +288,11 @@ parseExName :: UriMapping -> String -> ExName parseExName uris str - | noPrefix = ExName str "" - | otherwise = ExName loc $ lookupPrefix uris prefix + | noPrefix = ExName str "" + | otherwise = ExName loc $ lookupPrefix uris prefix where - noPrefix = null loc - loc = drop 1 loc' + noPrefix = null loc + loc = drop 1 loc' (prefix, loc') = span (/= ':') str -- Mapping from namespace-Prefixes to namespace-URIs @@ -379,7 +379,7 @@ -- 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 = +splitMatchByPrio = map compress . groupBy eq . sortBy cmp . map (computePriority &&& id) . splitExpr where eq x y = fst x == fst y @@ -393,7 +393,7 @@ computeNTestPriority :: NodeTest -> Float computeNTestPriority (PI _) = 0.0 computeNTestPriority (TypeTest _) = -0.5 -computeNTestPriority (NameTest nt) +computeNTestPriority (NameTest nt) | namePrefix nt /= "" && localPart nt == "*" = -0.25 | localPart nt == "*" = -0.5 @@ -406,13 +406,13 @@ isMatchExpr (FctExpr "key" [LiteralExpr _, LiteralExpr _]) = True isMatchExpr _ = False ---------------------------- +--------------------------- -- Misc: fromJustErr :: String -> Maybe a -> a -fromJustErr msg = maybe (error msg) id +fromJustErr msg = maybe (error msg) id readWDefault :: Read a => a -> String -> a readWDefault a str = fst $ head $ reads str ++ [(a, "")] ---------------------------- +--------------------------- diff --git a/src/Text/XML/HXT/XSLT/Compilation.hs b/src/Text/XML/HXT/XSLT/Compilation.hs --- a/src/Text/XML/HXT/XSLT/Compilation.hs +++ b/src/Text/XML/HXT/XSLT/Compilation.hs @@ -15,7 +15,7 @@ -- ------------------------------------------------------------ -module Text.XML.HXT.XSLT.Compilation +module Text.XML.HXT.XSLT.Compilation ( prepareXSLTDocument -- :: XmlTree -> XmlTree , assembleStylesheet -- :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet ) @@ -25,10 +25,10 @@ import Data.Maybe import Data.List -import qualified Data.Map as Map hiding ( Map ) -import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Data.Map ( Map ) -import Text.ParserCombinators.Parsec.Prim ( runParser ) +import Text.ParserCombinators.Parsec.Prim ( runParser ) import Text.XML.HXT.XSLT.Common import Text.XML.HXT.XSLT.Names @@ -38,7 +38,7 @@ infixl 9 >< -(><) :: XmlNode n => (UriMapping -> a ) -> n -> a +(><) :: XmlNode n => (UriMapping -> a ) -> n -> a f >< node = f $ getUriMap node @@ -46,9 +46,9 @@ parseExpr :: UriMapping -> String -> Expr parseExpr uris selectStr - = either (error.show) id parseResult + = either (error.show) id parseResult where - parseResult = runParser parseXPath (toNsEnv . Map.toList $ uris) ("select-expr:"++selectStr) selectStr + parseResult = runParser parseXPath (toNsEnv . Map.toList $ uris) ("select-expr:"++selectStr) selectStr parseSelect :: UriMapping -> String -> SelectExpr parseSelect uris @@ -67,13 +67,13 @@ = if isMatchExpr expr then MatchExpr expr else error $ str ++ " is not a legal match-expression" - where + where expr = parseExpr uris str -- -------------------------- parseAVT :: UriMapping -> String -> StringExpr -parseAVT uris str = +parseAVT uris str = StringExpr $ concatExpr $ splitAVT str "" where @@ -88,7 +88,7 @@ splitAVT ('}':_) _ = error $ "deserted '}' in AVT." splitAVT (x:xs) acc = splitAVT xs $ x:acc - acc2lit :: String -> [Expr] + acc2lit :: String -> [Expr] acc2lit "" = [] acc2lit acc = [mkLiteralExpr $ reverse acc] @@ -98,7 +98,7 @@ compileComputedQName :: XmlTree -> ComputedQName compileComputedQName node = (CompQName> Template -compileElement node = +compileElement node = TemplElement compQName Map.empty attribSets template - where + where compQName = compileComputedQName node attribSets = UsedAttribSets $ parseExNames> Template -compileAttribute node = +compileAttribute node = TemplAttribute (compileComputedQName node) $ compileTemplate (getChildren node) -- compiles xsl:text compileText :: XmlTree -> Template compileText = TemplText . collectTextnodes . getChildren --- compiles textNode +-- compiles textNode compileTextnode :: XmlTree -> Template compileTextnode = TemplText . fromJust . getText compileValueOf :: XmlTree -> Template -compileValueOf node = +compileValueOf node = TemplValueOf $ parseStringExpr> Template compileComment = TemplComment . compileTemplate . getChildren compileProcInstr :: XmlTree -> Template -compileProcInstr node = +compileProcInstr node = TemplProcInstr name content where name = parseAVT> Template compileLiteralResultElement node = TemplElement compQName nsUris attribSets content - where + where nsUris = extractAddUris node compQName = LiteralQName $ fromJust $ getElemName node attribSets = UsedAttribSets $ parseExNames> XmlTree -> Maybe Template -compileLREAttribute uris node = - if isSpecial +compileLREAttribute uris node = + if isSpecial then Nothing - else Just $ TemplAttribute (LiteralQName name) val - where + else Just $ TemplAttribute (LiteralQName name) val + where isSpecial = namespaceUri name `elem` [xsltUri, xmlnsNamespace] name = fromJust $ getAttrName node val = TemplValueOf $ parseAVT uris $ collectTextnodes $ getChildren node @@ -245,12 +245,12 @@ -- ----------------------------------- compileTemplate :: [XmlTree] -> Template -compileTemplate [node] = +compileTemplate [node] = if isElem node - then let elemName = fromJust $ getElemName node in + 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 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 @@ -285,9 +285,9 @@ assembleStylesheet :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet assembleStylesheet xslNode imports = CompStylesheet matchRules namedRules variables attsets strips aliases - where + where -- entire contents: - (namedRules, + (namedRules, matchRules) = assembleRules ruleElems importedMatchRules importedNamedRules variables = assembleVariables varElems importedVariables attsets = assembleAttrSets attsetElems importedAttribSets @@ -315,8 +315,8 @@ assembleRules nodes importedMatches importedProcs = (resProcs, resMatches) where - - -- matches: + + -- matches: resMatches = localMatches ++ importedMatches localMatches = reverse $ sortBy cmp matches cmp rulA rulB = compare (getRulePrio rulA) (getRulePrio rulB) @@ -330,7 +330,7 @@ -- compile all xsl:template's: (procs, matches) = catMaybes *** concat $ unzip $ map (compileRule importedMatches) nodes -assembleVariables :: [XmlTree] -> [(Map ExName Variable)] -> (Map ExName Variable) +assembleVariables :: [XmlTree] -> [(Map ExName Variable)] -> (Map ExName Variable) assembleVariables varElems = Map.unions . (compileVariables varElems:) assembleAttrSets :: [XmlTree] -> [Map ExName [AttributeSet]] -> Map ExName [AttributeSet] @@ -365,20 +365,20 @@ compileRule :: [MatchRule] -> XmlTree -> (Maybe NamedRule, [MatchRule]) compileRule imports node = - if isNothing match && isNothing name + 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 + else if isJust mode && isNothing match then error "Error: Bogus mode attribute on none-match rule is illegal" - else if isJust priority && isNothing match + else if isJust priority && isNothing match then error "Error: Bogus priority attribute on none-match rule is illegal" - else + else ( liftM (\n -> NamRule n params template) name , concat $ maybeToList $ liftM (assembleMatchRule priority mode imports params template) match - ) + ) where match = liftM (parseMatch> Variable compileVariable node = MkVar modus name exprOrRtf - where + where modus = isElemType xsltParam node name = parseExName> (String, String) -compileAlias node = +compileAlias node = (fetchAttribute node xsltStylesheetPrefix, fetchAttribute node xsltResultPrefix) -- ----------------------------------- -- Document level preprocessing -prepareXSLTDocument :: XmlTree -> XmlTree -prepareXSLTDocument = expandExEx . expandNSDecls . stripStylesheet . removePiCmt +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)) @@ -482,7 +482,7 @@ then (xsltExlcudeResultPrefixes , xsltExtensionElementPrefixes ) else (xsltExlcudeResultPrefixesLRE, xsltExtensionElementPrefixesLRE) --- parse a prefix list, create a list of uris: +-- parse a prefix list, create a list of uris: -- "pre1 pre2 pre3" -> ["pre1.uri","pre2.uri","pre3.uri"] parsePreList :: UriMapping -> String -> [String] @@ -492,7 +492,7 @@ -- Extraction of contextual Information from an XML-Node extractAddUris :: XmlTree -> UriMapping -extractAddUris node = +extractAddUris node = (Map.filter (`notElem` exclUris))> [MatchRule] @@ -62,7 +61,7 @@ -- ------------------- -- Match-Rules: -data MatchRule = +data MatchRule = MatRule MatchExpr Float -- priority (Maybe ExName) -- mode @@ -73,8 +72,8 @@ 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 + = "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 @@ -96,13 +95,13 @@ getRuleName (NamRule name _ _) = name -- ------------------- --- Variables +-- Variables -data Variable = MkVar +data Variable = MkVar Bool -- modus: False => xsl:variable, True => xsl:param ExName -- name (Either Expr Template) -- select-expression or result tree fragment - deriving Show + deriving Show getVarName :: Variable -> ExName getVarName (MkVar _ name _) = name @@ -122,7 +121,7 @@ -- ------------------- -- Whitespace-stripping -type NTest = ExName +type NTest = ExName parseNTest :: UriMapping -> String -> NTest parseNTest = parseExName @@ -139,7 +138,7 @@ -- 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 = +lookupStrip1 name spec = if isJust nameMatch then nameMatch else if isJust prefMatch then prefMatch else if isJust globMatch then globMatch @@ -150,7 +149,7 @@ globMatch = Map.lookup (ExName "*" "" ) spec feedSpaces :: Bool -> [NTest] -> Strips -> Strips -feedSpaces strip tests = +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 @@ -168,15 +167,15 @@ = stripSpaces isStrip True where isStrip strip' node - = not (isElemType xsltText node) - && - ( maybe strip' (=="default") $ tryFetchAttribute node xmlSpace ) + = not (isElemType xsltText node) + && + ( maybe strip' (=="default") $ tryFetchAttribute node xmlSpace ) stripSpaces :: (Bool -> XNode -> Bool) -> Bool -> XmlTree -> XmlTree -stripSpaces f def = +stripSpaces f def = fromJustErr "stripSpaces (internal error)" . filterTreeCtx step def where - step strip node + step strip node | isElem node = (f strip node, True) | isWhitespaceNode node = (strip , not strip) | otherwise = (strip , True) @@ -200,10 +199,10 @@ lookupAlias :: NSAliasing -> QName -> QName lookupAlias nsm qn - = mkQName (namePrefix qn) (localPart 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) @@ -211,14 +210,14 @@ -- Templates: data Template - = TemplComposite [Template] + = TemplComposite [Template] | TemplForEach SelectExpr [SortKey] Template | TemplChoose [When] -- otherwise will be represented by in the abstract Syntax | TemplMessage Bool -- halt? - Template -- content + Template -- content | TemplElement ComputedQName UriMapping -- Namespaces which *must* be added - UsedAttribSets -- + UsedAttribSets -- Template -- content | TemplAttribute ComputedQName Template -- content @@ -227,7 +226,7 @@ | TemplComment Template | TemplProcInstr StringExpr -- name Template -- content - | TemplApply (Maybe SelectExpr) + | TemplApply (Maybe SelectExpr) (Maybe ExName) -- mode (Map ExName Variable) -- passed arguments [SortKey] @@ -247,7 +246,7 @@ deriving Show data When - = WhenPart TestExpr Template + = WhenPart TestExpr Template deriving Show data ComputedQName diff --git a/src/Text/XML/HXT/XSLT/Names.hs b/src/Text/XML/HXT/XSLT/Names.hs --- a/src/Text/XML/HXT/XSLT/Names.hs +++ b/src/Text/XML/HXT/XSLT/Names.hs @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: Names.hs,v 1.2 2006/11/11 15:36:05 hxml Exp $ Names and constants for HXSLT @@ -21,11 +20,11 @@ import Text.XML.HXT.XSLT.Common -xsltPrefix :: String -xsltPrefix = "xsl" +xsltPrefix :: String +xsltPrefix = "xsl" -xsltUri :: String -xsltUri = "http://www.w3.org/1999/XSL/Transform" +xsltUri :: String +xsltUri = "http://www.w3.org/1999/XSL/Transform" mkXsltName :: String -> QName mkXsltName name = mkQName xsltPrefix name xsltUri @@ -63,7 +62,7 @@ , xsltSort , xsltStripSpace , xsltPreserveSpace - , xsltNamespaceAlias :: QName + , xsltNamespaceAlias :: QName xsltTransform = mkXsltName "transform" xsltStylesheet = mkXsltName "stylesheet" @@ -114,11 +113,11 @@ , xsltResultPrefix , xsltVersion , xsltExlcudeResultPrefixes - , xsltExtensionElementPrefixes :: QName + , xsltExtensionElementPrefixes :: QName -xsltTerminate = mkXsltAttribName "terminate" -xsltSelect = mkXsltAttribName "select" -xsltTest = mkXsltAttribName "test" +xsltTerminate = mkXsltAttribName "terminate" +xsltSelect = mkXsltAttribName "select" +xsltTest = mkXsltAttribName "test" xsltName = mkXsltAttribName "name" xsltNamespace = mkXsltAttribName "namespace" xsltUseAttributeSets = mkXsltAttribName "use-attribute-sets" @@ -139,14 +138,14 @@ xsltUseAttributeSetsLRE , xsltVersionLRE , xsltExlcudeResultPrefixesLRE - , xsltExtensionElementPrefixesLRE :: QName + , xsltExtensionElementPrefixesLRE :: QName -xsltUseAttributeSetsLRE = mkXsltName "use-attribute-sets" +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 :: QName xmlSpace = mkQName "xml" "space" xmlNamespace 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 @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: XsltArrows.hs,v 1.1 2006/11/11 15:36:05 hxml Exp $ The HXT arrow interface for the XSLT module @@ -30,19 +29,10 @@ ) where -import Prelude hiding ( catch ) - import Control.Exception - ( SomeException - , catch - , evaluate ) - -import Control.Arrow.ListArrows + ( evaluate ) -import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.ReadDocument +import Text.XML.HXT.Core import Text.XML.HXT.XSLT.Names @@ -61,50 +51,36 @@ -- | arrow for applying a pure partial function, catch the error case and issue the error -arrWithCatch :: (a -> b) -> IOSArrow a b +arrWithCatch :: (a -> b) -> IOSArrow a b arrWithCatch f - = arrIO (applyf f) - >>> - ( (applyA (arr issueErr) >>> none) - ||| - this - ) + = arrIO (evaluate . f) + `catchA` + issueExc "arrWithCatch" -applyf :: (a -> b) -> a -> IO (Either String b) -applyf f x - = catch' ( do - res <- evaluate ( f x ) - return . Right $ res - ) - (\ e -> return . Left . ("XSLT: " ++) . show $ e) - where - catch' :: IO a -> (SomeException -> IO a) -> IO a - catch' = catch - -- ------------------------------------------------------------ -- | lift prepareXSLTDocument -prepareXSLTDoc :: IOSArrow XmlTree XmlTree +prepareXSLTDoc :: IOSArrow XmlTree XmlTree prepareXSLTDoc = ( arrWithCatch prepareXSLTDocument - >>> - traceDoc "prepareXSLTDocument" + >>> + traceDoc "prepareXSLTDocument" ) `when` documentStatusOk -- | read an XSLT stylesheet -readXSLTDoc :: Attributes -> IOSArrow String XmlTree +readXSLTDoc :: SysConfigList -> IOSArrow String XmlTree readXSLTDoc options = readFromDocument (options ++ defaultOptions) where defaultOptions - = [ (a_check_namespaces, v_1) - , (a_validate, v_0) - , (a_preserve_comment, v_0) - ] + = [ withCheckNamespaces yes + , withValidate no + , withPreserveComment no + ] -- | Normalize stylesheet, expand includes, select imports and assemble the rules @@ -112,156 +88,156 @@ compileSSTWithIncludeStack incStack = traceMsg 2 "compile stylesheet" >>> - getChildren -- remove document root + getChildren -- remove document root >>> - isElem -- select XSLT root element + 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 - ) - ) + [ 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 - ) + :-> ( 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) + 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 - ) + = 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 :: [String] -> IOSArrow String XmlTree readSSTWithIncludeStack incStack = ifP (`elem` incStack) ( (issueErr $< arr recursiveInclude) >>> none ) ( readXSLTDoc [] - >>> - prepareXSLTDoc - ) + >>> + prepareXSLTDoc + ) where recursiveInclude uri - = "XSLT error: " - ++ show uri ++ " is recursively imported/included." + = "XSLT error: " + ++ show uri ++ " is recursively imported/included." ++ concatMap (("\n imported/included from: " ++) . show) incStack -compileSSTFromUriWithIncludeStack :: [String] -> IOSArrow String CompiledStylesheet +compileSSTFromUriWithIncludeStack :: [String] -> IOSArrow String CompiledStylesheet compileSSTFromUriWithIncludeStack incStack = comp $< this where comp uri - = readSSTWithIncludeStack incStack - >>> - compileSSTWithIncludeStack (uri:incStack) + = readSSTWithIncludeStack incStack + >>> + compileSSTWithIncludeStack (uri:incStack) -expandIncludes :: [String] -> IOSArrow XmlTree XmlTree +expandIncludes :: [String] -> IOSArrow XmlTree XmlTree expandIncludes incStack = isElem >>> ( ( expandInclude $< getXsltAttrValue xsltHRef ) `when` - isXsltInclude + isXsltInclude ) where expandInclude href - = ( constA href - >>> - readSSTWithIncludeStack incStack - >>> - getChildren - >>> - isElem - >>> - choiceA - [ isXsltLREstylesheet - :-> xsltlre2template + = ( constA href + >>> + readSSTWithIncludeStack incStack + >>> + getChildren + >>> + isElem + >>> + choiceA + [ isXsltLREstylesheet + :-> xsltlre2template - , isXsltStylesheetElem - :-> ( getChildren - >>> - expandIncludes (href:incStack) - ) + , isXsltStylesheetElem + :-> ( getChildren + >>> + expandIncludes (href:incStack) + ) - , this + , 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) +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) +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 +hasXsltAttr :: ArrowXml a => QName -> a XmlTree XmlTree +hasXsltAttr qn = ( getAttrl >>> isXsltAttr qn ) + `guards` + this -isXsltInclude :: ArrowXml a => a XmlTree XmlTree -isXsltInclude = isXsltElem xsltInclude +isXsltInclude :: ArrowXml a => a XmlTree XmlTree +isXsltInclude = isXsltElem xsltInclude -isXsltImport :: ArrowXml a => a XmlTree XmlTree -isXsltImport = isXsltElem xsltImport +isXsltImport :: ArrowXml a => a XmlTree XmlTree +isXsltImport = isXsltElem xsltImport -isXsltLREstylesheet :: ArrowXml a => a XmlTree XmlTree -isXsltLREstylesheet = hasXsltAttr xsltVersionLRE +isXsltLREstylesheet :: ArrowXml a => a XmlTree XmlTree +isXsltLREstylesheet = hasXsltAttr xsltVersionLRE -isXsltStylesheetElem :: ArrowXml a => a XmlTree XmlTree -isXsltStylesheetElem = ( isXsltElem xsltTransform - <+> - isXsltElem xsltStylesheet - ) +isXsltStylesheetElem :: ArrowXml a => a XmlTree XmlTree +isXsltStylesheetElem = ( isXsltElem xsltTransform + <+> + isXsltElem xsltStylesheet + ) >>> - hasXsltAttr xsltVersion + hasXsltAttr xsltVersion -getXsltAttrValue :: ArrowXml a => QName -> a XmlTree String -getXsltAttrValue qn = getAttrl >>> isXsltAttr qn >>> xshow getChildren +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] +xsltlre2template :: ArrowXml a => a XmlTree XmlTree +xsltlre2template = mkqelem xsltTemplate [sqattr xsltMatch "/"] [this] -xsltlre2stylesheet :: ArrowXml a => a XmlTree XmlTree -xsltlre2stylesheet = mkqelem xsltTransform [] [ this >>> xsltlre2template ] +xsltlre2stylesheet :: ArrowXml a => a XmlTree XmlTree +xsltlre2stylesheet = mkqelem xsltTransform [] [ this >>> xsltlre2template ] -- -checkApplySST :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree +checkApplySST :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree checkApplySST appl = ( isRoot - >>> - replaceChildren appl - >>> - traceDoc "XSLT stylesheet applied" - >>> - setDocumentStatusFromSystemState "applying XSLT stylesheet" + >>> + replaceChildren appl + >>> + traceDoc "XSLT stylesheet applied" + >>> + setDocumentStatusFromSystemState "applying XSLT stylesheet" ) `orElse` issueErr "XSLT: complete document with root node required for stylesheet application" @@ -272,7 +248,7 @@ -- XSLT imports and includes are evaluated and the rules are normalized and prepared -- for easy application. -xsltCompileStylesheet :: IOSArrow XmlTree CompiledStylesheet +xsltCompileStylesheet :: IOSArrow XmlTree CompiledStylesheet xsltCompileStylesheet = prepareXSLTDoc >>> @@ -283,15 +259,15 @@ -- 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 [] +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 :: CompiledStylesheet -> IOSArrow XmlTree XmlTree xsltApplyStylesheet css = checkApplySST (arrWithCatch (applyStylesheet css) >>. concat) @@ -302,11 +278,11 @@ -- 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 :: 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) +xsltApplyStylesheetWParams :: Map ExName Expr -> CompiledStylesheet -> IOSArrow XmlTree XmlTree +xsltApplyStylesheetWParams wp css = arrL (applyStylesheetWParams wp css) -}