diff --git a/HaXml.cabal b/HaXml.cabal --- a/HaXml.cabal +++ b/HaXml.cabal @@ -1,5 +1,5 @@ name: HaXml -version: 1.24 +version: 1.24.1 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace @@ -76,63 +76,63 @@ else build-depends: base < 2 || >= 3, bytestring extensions: CPP, ExistentialQuantification - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" nhc98-options: -K10M Executable Canonicalise GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: Canonicalise.hs Executable CanonicaliseLazy GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: CanonicaliseLazy.hs Executable Xtract GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: Xtract.hs Executable Validate GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: Validate.hs Executable MkOneOf GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: MkOneOf.hs Executable DtdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: DtdToHaskell.hs Executable XsdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: XsdToHaskell.hs Executable FpMLToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src - cpp-options: -DMAJOR=1 -DMINOR=24 + cpp-options: -DVERSION="\"1.24.1\"" Main-Is: FpMLToHaskell.hs build-depends: directory diff --git a/src/Text/XML/HaXml.hs b/src/Text/XML/HaXml.hs --- a/src/Text/XML/HaXml.hs +++ b/src/Text/XML/HaXml.hs @@ -33,5 +33,5 @@ -- | The version of the library. version :: String -version = show MAJOR.MINOR +version = VERSION -- expect cpp to fill in value diff --git a/src/Text/XML/HaXml/Combinators.hs b/src/Text/XML/HaXml/Combinators.hs --- a/src/Text/XML/HaXml/Combinators.hs +++ b/src/Text/XML/HaXml/Combinators.hs @@ -32,9 +32,10 @@ -- $recursive , deep, deepest, multi -- ** Interior editing. - , when, guards, chip, inplace, foldXml + , when, guards, chip, inplace, recursivelyInPlace, foldXml -- ** Constructive filters. - , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs + -- $constructive + , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs, addAttribute -- * C-like conditionals. -- $cond @@ -278,7 +279,14 @@ inplace f c@(CElem (Elem name as _) i) = [ CElem (Elem name as (f c)) i ] inplace _f c = [c] +-- | Recursively process an element in place. That is, the filter is +-- applied to the element itself, then recursively to the results of the +-- filter, all the way to the bottom, then the original element rebuilt +-- around the final results. +recursivelyInPlace :: CFilter i -> CFilter i +recursivelyInPlace f = inplace (recursivelyInPlace f `o` f) + -- | Recursive application of filters: a fold-like operator. Defined -- as @f `o` chip (foldXml f)@. foldXml :: CFilter i -> CFilter i @@ -288,6 +296,10 @@ -- CONSTRUCTIVE CONTENT FILTERS +-- +-- $constructive +-- The constructive filters are primitive filters for building new elements, +-- or editing existing elements. -- | Build an element with the given tag name - its content is the results -- of the given list of filters. @@ -321,9 +333,80 @@ where as' = map (\(n,v)-> (N n, AttValue [Left v])) as replaceAttrs _ _ = [] +-- | Add the desired attribute name and value to the topmost element, +-- without changing the element in any other way. +addAttribute :: String -> String -> CFilter a +addAttribute name val (CElem (Elem n as cs) i) = + [CElem (Elem n (a:as) cs) i] + where a = (N name, AttValue [Left val]) +addAttribute _ _ _ = [] + -- LABELLING +-- $labelling +-- LabelFilters are a way of annotating the results of a filter operation +-- with some arbitrary values drawn from the tree values. Typically, the +-- annotations are then consumed by a label-processing filter (of +-- type @a -> CFilter@). This is useful way of passing information between +-- sections of the tree as you process it. An example may help to explain. +-- +-- Let's say we want to add an attribute to every node of the tree, +-- containing a textual representation of its path from the root, +-- e.g. "/foo/bar/quux". Where there are multiple identically-tagged elements +-- under the same parent node of the original tree, we expect them to have +-- a distinguishing attribute called "name". +-- +-- Step one. Given the path prefix to this node, how do we add the "xpath" +-- attribute? +-- +-- > annotateOne :: String -> CFilter a +-- > annotateOne prefix = +-- > (f `oo` ((tagged `x` attributed "name") (attr "name"))) +-- > |>| +-- > (g `oo` (tagged keep)) +-- > where +-- > f (tag,att) = addAttribute "xpath" (prefix++"/"++tag++"["++att++"]") +-- > g tag = addAttribute "xpath" (prefix++"/"++tag)@ +-- +-- First, the @attr "name"@ filter distinguishes whether this node contains +-- the attribute, hence choosing whether the left or right branch of the +-- @|>|@ is taken. If the attribute is /not/ present, then the LabelFilter +-- @tagged keep@ selects the current node, and annotates it with the +-- tagname of the element. The @oo@ applies the label-consuming function @g@ +-- to the result, and this injects the "xpath" attribute by suffixing +-- the tagname to the known path prefix. +-- +-- If the "name" attribute /is/ present, then there are /two/ labelling filters +-- applied to the current node, annotating it with the pair of its tag +-- and the value of the attribute "name". The label-consuming function @f@ is +-- applied to the pair with @oo@, to inject the "xpath" attribute with a more +-- complex representation of its path. +-- +-- Step two. Recursively apply the annotation throughout the tree. +-- +-- > labelAllPaths :: CFilter a +-- > labelAllPaths = allPaths `o` initialise +-- > where +-- > initialise = annotateOne "/" +-- > +-- > allPaths :: CFilter a +-- > allPaths = inplace ( allPaths +-- > `o` +-- > (\prefix-> annotateOne prefix `o` children) +-- > `oo` +-- > (attributed "xpath" keep) +-- > ) +-- +-- In order to apply @annotateOne@ to any node, we need to know the path +-- prefix thus far into the tree. So, we read the "xpath" attribute from +-- the current node (assumed to have already been processed) as a +-- LabelFilter, then consume the label by passing it to @annotateOne@ on +-- the children of the current node. Using @inplace@ rebuilds the processed +-- children into the current node, after recursively dealing with their +-- children. + + -- | A LabelFilter is like a CFilter except that it pairs up a polymorphic -- value (label) with each of its results. diff --git a/src/Text/XML/HaXml/Wrappers.hs b/src/Text/XML/HaXml/Wrappers.hs --- a/src/Text/XML/HaXml/Wrappers.hs +++ b/src/Text/XML/HaXml/Wrappers.hs @@ -31,10 +31,10 @@ fix2Args = do args <- getArgs when ("--version" `elem` args) $ do - putStrLn $ "part of HaXml-"++show MAJOR.MINOR + putStrLn $ "part of HaXml-"++ VERSION exitWith ExitSuccess when ("--help" `elem` args) $ do - putStrLn $ "See http://haskell.org/HaXml" + putStrLn $ "See http://projects.haskell.org/HaXml" exitWith ExitSuccess case length args of 0 -> return ("-", "-")