--------------------------------------------
-- | This module defines the notion of filters and filter combinators
--   for processing XML documents.
--
--   These XML transformation combinators are described in the paper
--   ``Haskell and XML: Generic Combinators or Type-Based Translation?''
--   Malcolm Wallace and Colin Runciman, Proceedings ICFP'99.
--------------------------------------------
module Text.XML.HaXml.Combinators
  (-- * The content filter type.
    CFilter

   -- * Simple filters.
   -- ** Selection filters.
   -- $selection
  , keep, none, children, childrenBy, position

   -- ** Predicate filters.
   -- $pred
  , elm, txt, tag, attr, attrval, tagWith

   -- ** Search filters.
  , find, iffind, ifTxt

   -- * Filter combinators
   -- ** Basic combinators.
  , o, union, cat, andThen
  , (|>|), with, without
  , (/>), (</), et
  , path
   -- ** Recursive search.
   -- $recursive
  , deep, deepest, multi
   -- ** Interior editing.
  , when, guards, chip, inplace, recursivelyInPlace, foldXml
   -- ** Constructive filters.
   -- $constructive
  , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs, addAttribute

   -- * C-like conditionals.
   -- $cond
  , ThenElse(..), (?>)

   -- * Filters with labelled results.
  , LabelFilter
   -- ** Using and combining labelled filters.
  , oo, x
   -- ** Some label-generating filters.
  , numbered, interspersed, tagged, attributed, textlabelled, extracted

  ) where


import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
import Data.Maybe (fromMaybe)

infixl 6 `with`, `without`
infixr 5 `o`, `oo`, `union`, `andThen`          -- , `orelse`
infixl 5 />, </, |>|
infixr 4 `when`, `guards`
infixr 3 ?>, :>



-- THE CONTENT FILTER TYPE

-- | All document transformations are /content filters/.
--   A filter takes a single XML 'Content' value and returns a sequence
--   of 'Content' values, possibly empty.
type CFilter i  = Content i -> [Content i]



-- BASIC SELECTION FILTERS
-- $selection
-- In the algebra of combinators, @none@ is the zero, and @keep@ the identity.
-- (They have a more general type than just CFilter.)
keep :: a->[a]
keep :: forall a. a -> [a]
keep a
x = [a
x]
none :: a->[b]
none :: forall a b. a -> [b]
none a
_ = []

-- | Throw away current node, keep just the (unprocessed) children.
children :: CFilter i
children :: forall i. CFilter i
children (CElem (Elem QName
_ [Attribute]
_ [Content i]
cs) i
_) = [Content i]
cs
children Content i
_ = []

-- | Select the @n@'th positional result of a filter.
position :: Int -> CFilter i -> CFilter i
position :: forall i. Int -> CFilter i -> CFilter i
position Int
n CFilter i
f = (\[Content i]
cs-> [[Content i]
csforall a. [a] -> Int -> a
!!Int
n]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f



-- BASIC PREDICATE FILTERS
-- $pred
-- These filters either keep or throw away some content based on
-- a simple test.  For instance, @elm@ keeps only a tagged element,
-- @txt@ keeps only non-element text, @tag@ keeps only an element
-- with the named tag, @attr@ keeps only an element with the named
-- attribute, @attrval@ keeps only an element with the given
-- attribute value, @tagWith@ keeps only an element whose tag name
-- satisfies the given predicate.

elm, txt   :: CFilter i
tag        :: String -> CFilter i
attr       :: String -> CFilter i
attrval    :: Attribute -> CFilter i
tagWith    :: (String->Bool) -> CFilter i

elm :: forall i. CFilter i
elm x :: Content i
x@(CElem Element i
_ i
_) = [Content i
x]
elm Content i
_             = []

txt :: forall i. CFilter i
txt x :: Content i
x@(CString Bool
_ CharData
_ i
_) = [Content i
x]
txt x :: Content i
x@(CRef Reference
_ i
_)      = [Content i
x]
txt Content i
_                 = []

tag :: forall i. CharData -> CFilter i
tag CharData
t x :: Content i
x@(CElem (Elem QName
n [Attribute]
_ [Content i]
_) i
_) | CharData
tforall a. Eq a => a -> a -> Bool
==QName -> CharData
printableName QName
n  = [Content i
x]
tag CharData
_ Content i
_  = []

tagWith :: forall i. (CharData -> Bool) -> CFilter i
tagWith CharData -> Bool
p x :: Content i
x@(CElem (Elem QName
n [Attribute]
_ [Content i]
_) i
_) | CharData -> Bool
p (QName -> CharData
printableName QName
n)  = [Content i
x]
tagWith CharData -> Bool
_ Content i
_  = []

attr :: forall i. CharData -> CFilter i
attr CharData
n x :: Content i
x@(CElem (Elem QName
_ [Attribute]
as [Content i]
_) i
_) | CharData
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map (QName -> CharData
printableNameforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) [Attribute]
as  = [Content i
x]
attr CharData
_ Content i
_  = []

attrval :: forall i. Attribute -> CFilter i
attrval Attribute
av x :: Content i
x@(CElem (Elem QName
_ [Attribute]
as [Content i]
_) i
_) | Attribute
av forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute]
as  = [Content i
x]
attrval Attribute
_  Content i
_  = []



-- SEARCH FILTERS

-- | For a mandatory attribute field, @find key cont@ looks up the value of
--   the attribute name @key@, and applies the continuation @cont@ to
--   the value.
find :: String -> (String->CFilter i) -> CFilter i
find :: forall i. CharData -> (CharData -> CFilter i) -> CFilter i
find CharData
key CharData -> CFilter i
cont c :: Content i
c@(CElem (Elem QName
_ [Attribute]
as [Content i]
_) i
_) = CharData -> CFilter i
cont (forall a. Show a => a -> CharData
show (forall {a} {c}. Eq a => a -> [(a, c)] -> c
lookfor (CharData -> QName
N CharData
key) [Attribute]
as)) Content i
c
  where lookfor :: a -> [(a, c)] -> c
lookfor a
x = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => CharData -> a
error (CharData
"missing attribute: "forall a. [a] -> [a] -> [a]
++CharData
key)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x
-- 'lookfor' has the more general type :: (Eq a,Show a) => a -> [(a,b)] -> b

-- | When an attribute field may be absent, use @iffind key yes no@ to lookup
--   its value.  If the attribute is absent, it acts as the @no@ filter,
--   otherwise it applies the @yes@ filter.
iffind :: String -> (String->CFilter i) -> CFilter i -> CFilter i
iffind :: forall i.
CharData -> (CharData -> CFilter i) -> CFilter i -> CFilter i
iffind  CharData
key  CharData -> CFilter i
yes CFilter i
no c :: Content i
c@(CElem (Elem QName
_ [Attribute]
as [Content i]
_) i
_) =
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (CharData -> QName
N CharData
key) [Attribute]
as of
    Maybe AttValue
Nothing               -> CFilter i
no Content i
c
    (Just v :: AttValue
v@(AttValue [Either CharData Reference]
_)) -> CharData -> CFilter i
yes (forall a. Show a => a -> CharData
show AttValue
v) Content i
c
iffind CharData
_key CharData -> CFilter i
_yes CFilter i
no Content i
other = CFilter i
no Content i
other

-- | @ifTxt yes no@ processes any textual content with the @yes@ filter,
--   but otherwise is the same as the @no@ filter.
ifTxt :: (String->CFilter i) -> CFilter i -> CFilter i
ifTxt :: forall i. (CharData -> CFilter i) -> CFilter i -> CFilter i
ifTxt  CharData -> CFilter i
yes CFilter i
_no c :: Content i
c@(CString Bool
_ CharData
s i
_) = CharData -> CFilter i
yes CharData
s Content i
c
ifTxt CharData -> CFilter i
_yes  CFilter i
no Content i
c                 = CFilter i
no Content i
c



-- C-LIKE CONDITIONALS
--
-- $cond
-- These definitions provide C-like conditionals, lifted to the filter level.
--
-- The @(cond ? yes : no)@ style in C becomes @(cond ?> yes :> no)@ in Haskell.

-- | Conjoin the two branches of a conditional.
data ThenElse a = a :> a

-- | Select between the two branches of a joined conditional.
(?>) :: (a->[b]) -> ThenElse (a->[b]) -> (a->[b])
a -> [b]
p ?> :: forall a b. (a -> [b]) -> ThenElse (a -> [b]) -> a -> [b]
?> (a -> [b]
f :> a -> [b]
g) = \a
c-> if (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
nullforall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> [b]
p) a
c then a -> [b]
f a
c else a -> [b]
g a
c



-- FILTER COMBINATORS


-- | Sequential (/Irish/,/backwards/) composition
o :: CFilter i -> CFilter i -> CFilter i
CFilter i
f o :: forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
g = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CFilter i
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
g

-- | Binary parallel composition.  Each filter uses a copy of the input,
-- rather than one filter using the result of the other.
--   (Has a more general type than just CFilter.)
union :: (a->[b]) -> (a->[b]) -> (a->[b])
union :: forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
union = forall a b d c. (a -> b -> d) -> (c -> a) -> (c -> b) -> c -> d
lift forall a. [a] -> [a] -> [a]
(++)               -- in Haskell 98:   union = lift List.union
  where
    lift :: (a->b->d) -> (c->a) -> (c->b) -> c -> d
    lift :: forall a b d c. (a -> b -> d) -> (c -> a) -> (c -> b) -> c -> d
lift a -> b -> d
f c -> a
g c -> b
h c
x = a -> b -> d
f (c -> a
g c
x) (c -> b
h c
x)

-- | Glue a list of filters together.  (A list version of union;
--   also has a more general type than just CFilter.)
cat :: [a->[b]] -> (a->[b])
--   Specification: cat fs = \e-> concat [ f e | f <- fs ]
--   more efficient implementation below:
cat :: forall a b. [a -> [b]] -> a -> [b]
cat [] = forall a b. a -> b -> a
const []
cat [a -> [b]]
fs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
union [a -> [b]]
fs

-- | A special form of filter composition where the second filter
--   works over the same data as the first, but also uses the
--   first's result.
andThen :: (a->c) -> (c->a->b) -> (a->b)
andThen :: forall a c b. (a -> c) -> (c -> a -> b) -> a -> b
andThen a -> c
f c -> a -> b
g a
x = c -> a -> b
g (a -> c
f a
x) a
x                    -- lift g f id

-- | Process children using specified filters.
childrenBy :: CFilter i -> CFilter i
childrenBy :: forall i. CFilter i -> CFilter i
childrenBy CFilter i
f = CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
children

-- | Directional choice:
--   in @f |>| g@ give g-productions only if no f-productions
(|>|) :: (a->[b]) -> (a->[b]) -> (a->[b])
a -> [b]
f |>| :: forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>| a -> [b]
g = \a
x-> let fx :: [b]
fx = a -> [b]
f a
x in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
fx then a -> [b]
g a
x else [b]
fx
--      f |>| g  =  f ?> f :> g

-- | Pruning: in @f `with` g@,
--   keep only those f-productions which have at least one g-production
with :: CFilter i -> CFilter i -> CFilter i
CFilter i
f with :: forall i. CFilter i -> CFilter i -> CFilter i
`with` CFilter i
g = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
nullforall b c a. (b -> c) -> (a -> b) -> a -> c
.CFilter i
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f

-- | Pruning: in @f `without` g@,
--   keep only those f-productions which have no g-productions
without :: CFilter i -> CFilter i -> CFilter i
CFilter i
f without :: forall i. CFilter i -> CFilter i -> CFilter i
`without` CFilter i
g = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
nullforall b c a. (b -> c) -> (a -> b) -> a -> c
.CFilter i
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f

-- | Pronounced /slash/, @f \/> g@ means g inside f
(/>) :: CFilter i -> CFilter i -> CFilter i
CFilter i
f /> :: forall i. CFilter i -> CFilter i -> CFilter i
/> CFilter i
g = CFilter i
g forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
children forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
f

-- | Pronounced /outside/, @f \<\/ g@ means f containing g
(</) :: CFilter i -> CFilter i -> CFilter i
CFilter i
f </ :: forall i. CFilter i -> CFilter i -> CFilter i
</ CFilter i
g = CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`with` (CFilter i
g forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
children)

-- | Join an element-matching filter with a text-only filter
et :: (String->CFilter i) -> CFilter i -> CFilter i
et :: forall i. (CharData -> CFilter i) -> CFilter i -> CFilter i
et CharData -> CFilter i
f CFilter i
g = (CharData -> CFilter i
f forall a i. (a -> CFilter i) -> LabelFilter i a -> CFilter i
`oo` forall i. CFilter i -> LabelFilter i CharData
tagged forall i. CFilter i
elm)
            forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>|
         (CFilter i
g forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
txt)

-- | Express a list of filters like an XPath query, e.g.
--   @path [children, tag \"name1\", attr \"attr1\", children, tag \"name2\"]@
--   is like the XPath query @\/name1[\@attr1]\/name2@.
path :: [CFilter i] -> CFilter i
path :: forall i. [CFilter i] -> CFilter i
path [CFilter i]
fs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall i. CFilter i -> CFilter i -> CFilter i
o) forall a. a -> [a]
keep [CFilter i]
fs


-- RECURSIVE SEARCH
-- $recursive
-- Recursive search has three variants: @deep@ does a breadth-first
-- search of the tree, @deepest@ does a depth-first search, @multi@ returns
-- content at all tree-levels, even those strictly contained within results
-- that have already been returned.
deep, deepest, multi :: CFilter i -> CFilter i
deep :: forall i. CFilter i -> CFilter i
deep CFilter i
f     = CFilter i
f forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>| (forall i. CFilter i -> CFilter i
deep CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
children)
deepest :: forall i. CFilter i -> CFilter i
deepest CFilter i
f  = (forall i. CFilter i -> CFilter i
deepest CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
children) forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>| CFilter i
f
multi :: forall i. CFilter i -> CFilter i
multi CFilter i
f    = CFilter i
f forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
`union` (forall i. CFilter i -> CFilter i
multi CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i
children)

-- | Interior editing:
--   @f `when` g@ applies @f@ only when the predicate @g@ succeeds,
--   otherwise the content is unchanged.
when   :: CFilter i -> CFilter i -> CFilter i
-- | Interior editing:
--   @g `guards` f@ applies @f@ only when the predicate @g@ succeeds,
--   otherwise the content is discarded.
guards :: CFilter i -> CFilter i -> CFilter i
CFilter i
f when :: forall i. CFilter i -> CFilter i -> CFilter i
`when` CFilter i
g       = CFilter i
g forall a b. (a -> [b]) -> ThenElse (a -> [b]) -> a -> [b]
?> CFilter i
f forall a. a -> a -> ThenElse a
:> forall a. a -> [a]
keep
CFilter i
g guards :: forall i. CFilter i -> CFilter i -> CFilter i
`guards` CFilter i
f     = CFilter i
g forall a b. (a -> [b]) -> ThenElse (a -> [b]) -> a -> [b]
?> CFilter i
f forall a. a -> a -> ThenElse a
:> forall a b. a -> [b]
none       -- = f `o` (keep `with` g)

-- | Process CHildren In Place.  The filter is applied to any children
--   of an element content, and the element rebuilt around the results.
chip :: CFilter i -> CFilter i
chip :: forall i. CFilter i -> CFilter i
chip  CFilter i
f (CElem (Elem QName
n [Attribute]
as [Content i]
cs) i
i) = [ forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n [Attribute]
as (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CFilter i
f [Content i]
cs)) i
i ]
chip CFilter i
_f Content i
c = [Content i
c]
-- chip f = inplace (f `o` children)

-- | Process an element In Place.  The filter is applied to the element
--   itself, and then the original element rebuilt around the results.
inplace :: CFilter i -> CFilter i
inplace :: forall i. CFilter i -> CFilter i
inplace  CFilter i
f c :: Content i
c@(CElem (Elem QName
name [Attribute]
as [Content i]
_) i
i) = [ forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
name [Attribute]
as (CFilter i
f Content i
c)) i
i ]
inplace CFilter i
_f Content i
c = [Content i
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 :: forall i. CFilter i -> CFilter i
recursivelyInPlace CFilter i
f = forall i. CFilter i -> CFilter i
inplace (forall i. CFilter i -> CFilter i
recursivelyInPlace CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
f)


-- | Recursive application of filters: a fold-like operator.  Defined
--   as @f `o` chip (foldXml f)@.
foldXml :: CFilter i -> CFilter i
foldXml :: forall i. CFilter i -> CFilter i
foldXml CFilter i
f = CFilter i
f forall i. CFilter i -> CFilter i -> CFilter i
`o` forall i. CFilter i -> CFilter i
chip (forall i. CFilter i -> CFilter i
foldXml CFilter i
f)




-- 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.
mkElem :: String -> [CFilter i] -> CFilter i
mkElem :: forall i. CharData -> [CFilter i] -> CFilter i
mkElem CharData
h [CFilter i]
cfs Content i
t = [ forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (CharData -> QName
N CharData
h) [] (forall a b. [a -> [b]] -> a -> [b]
cat [CFilter i]
cfs Content i
t)) forall a. HasCallStack => a
undefined ]

-- | Build an element with the given name, attributes, and content.
mkElemAttr :: String -> [(String,CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr :: forall i.
CharData -> [(CharData, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr CharData
h [(CharData, CFilter i)]
as [CFilter i]
cfs = \Content i
t-> [ forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (CharData -> QName
N CharData
h) (forall a b. (a -> b) -> [a] -> [b]
map (forall {i}. Content i -> (CharData, CFilter i) -> Attribute
attr Content i
t) [(CharData, CFilter i)]
as) (forall a b. [a -> [b]] -> a -> [b]
cat [CFilter i]
cfs Content i
t))
                                   forall a. HasCallStack => a
undefined ]
  where attr :: Content i -> (CharData, CFilter i) -> Attribute
attr Content i
t (CharData
n,CFilter i
vf) =
            let v :: CharData
v = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ CharData
s | (CString Bool
_ CharData
s i
_) <- (forall i. CFilter i -> CFilter i
deep forall i. CFilter i
txt forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
vf) Content i
t ]
            in  (CharData -> QName
N CharData
n, [Either CharData Reference] -> AttValue
AttValue [forall a b. a -> Either a b
Left CharData
v])

-- | Build some textual content.
literal :: String -> CFilter i
literal :: forall i. CharData -> CFilter i
literal CharData
s = forall a b. a -> b -> a
const [forall i. Bool -> CharData -> i -> Content i
CString Bool
False CharData
s forall a. HasCallStack => a
undefined]

-- | Build some CDATA content.
cdata :: String -> CFilter i
cdata :: forall i. CharData -> CFilter i
cdata CharData
s = forall a b. a -> b -> a
const [forall i. Bool -> CharData -> i -> Content i
CString Bool
True CharData
s forall a. HasCallStack => a
undefined]

-- | Rename an element tag (leaving attributes in place).
replaceTag :: String -> CFilter i
replaceTag :: forall i. CharData -> CFilter i
replaceTag CharData
n (CElem (Elem QName
_ [Attribute]
as [Content i]
cs) i
i) = [forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (CharData -> QName
N CharData
n) [Attribute]
as [Content i]
cs) i
i]
replaceTag CharData
_ Content i
_ = []

-- | Replace the attributes of an element (leaving tag the same).
replaceAttrs :: [(String,String)] -> CFilter i
replaceAttrs :: forall i. [(CharData, CharData)] -> CFilter i
replaceAttrs [(CharData, CharData)]
as (CElem (Elem QName
n [Attribute]
_ [Content i]
cs) i
i) = [forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n [Attribute]
as' [Content i]
cs) i
i]
    where as' :: [Attribute]
as' = forall a b. (a -> b) -> [a] -> [b]
map (\(CharData
n,CharData
v)-> (CharData -> QName
N CharData
n, [Either CharData Reference] -> AttValue
AttValue [forall a b. a -> Either a b
Left CharData
v])) [(CharData, CharData)]
as
replaceAttrs [(CharData, CharData)]
_  Content i
_ = []

-- | 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 :: forall a. CharData -> CharData -> CFilter a
addAttribute CharData
name CharData
val (CElem (Elem QName
n   [Attribute]
as   [Content a]
cs) a
i) =
                      [forall i. Element i -> i -> Content i
CElem (forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n (Attribute
aforall a. a -> [a] -> [a]
:[Attribute]
as) [Content a]
cs) a
i]
  where a :: Attribute
a = (CharData -> QName
N CharData
name, [Either CharData Reference] -> AttValue
AttValue [forall a b. a -> Either a b
Left CharData
val])
addAttribute CharData
_ CharData
_ Content a
_ = []



-- 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.
type LabelFilter i a = Content i -> [(a,Content i)]

-- | Compose a label-processing filter with a label-generating filter.
oo :: (a->CFilter i) -> LabelFilter i a -> CFilter i
a -> CFilter i
f oo :: forall a i. (a -> CFilter i) -> LabelFilter i a -> CFilter i
`oo` LabelFilter i a
g = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> CFilter i
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelFilter i a
g

{-
-- | Process the information labels (very nearly monadic bind).
oo :: (b -> CFilter b c) -> CFilter a b -> CFilter a c
f `oo` g = concatMap info . g
    where info c@(CElem _ i)     = f i c
          info c@(CString _ _ i) = f i c
          info c@(CRef _ i)      = f i c
          info c                 = [c]
-}

-- | Combine labels.  Think of this as a pair-wise zip on labels.
--   e.g. @(numbered `x` tagged)@
x :: (CFilter i->LabelFilter i a) -> (CFilter i->LabelFilter i b) ->
       (CFilter i->LabelFilter i (a,b))
CFilter i -> LabelFilter i a
f x :: forall i a b.
(CFilter i -> LabelFilter i a)
-> (CFilter i -> LabelFilter i b)
-> CFilter i
-> LabelFilter i (a, b)
`x` CFilter i -> LabelFilter i b
g = \CFilter i
cf Content i
c-> let gs :: [b]
gs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (CFilter i -> LabelFilter i b
g CFilter i
cf Content i
c)
                      fs :: [a]
fs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (CFilter i -> LabelFilter i a
f CFilter i
cf Content i
c)
                  in forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. [a] -> [b] -> [(a, b)]
zip [a]
fs [b]
gs) (CFilter i
cf Content i
c)


-- Some basic label-generating filters.

-- | Number the results from 1 upwards.
numbered :: CFilter i -> LabelFilter i Int
numbered :: forall i. CFilter i -> LabelFilter i Int
numbered CFilter i
f = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f

-- | In @interspersed a f b@, label each result of @f@ with the string @a@,
--   except for the last one which is labelled with the string @b@.
interspersed :: String -> CFilter i -> String -> LabelFilter i String
interspersed :: forall i.
CharData -> CFilter i -> CharData -> LabelFilter i CharData
interspersed CharData
a CFilter i
f CharData
b =
  (\[Content i]
xs-> forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Int -> a -> [a]
replicate (forall {a}. [a] -> Int
len [Content i]
xs) CharData
a forall a. [a] -> [a] -> [a]
++ [CharData
b]) [Content i]
xs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f
  where
  len :: [a] -> Int
len [] = Int
0
  len [a]
xs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Num a => a -> a -> a
- Int
1

-- | Label each element in the result with its tag name.  Non-element
--   results get an empty string label.
tagged :: CFilter i -> LabelFilter i String
tagged :: forall i. CFilter i -> LabelFilter i CharData
tagged CFilter i
f = forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted forall {i}. Content i -> CharData
name CFilter i
f
  where name :: Content i -> CharData
name (CElem (Elem QName
n [Attribute]
_ [Content i]
_) i
_) = QName -> CharData
printableName QName
n
        name Content i
_                      = CharData
""

-- | Label each element in the result with the value of the named attribute.
--   Elements without the attribute, and non-element results, get an
--   empty string label.
attributed :: String -> CFilter i -> LabelFilter i String
attributed :: forall i. CharData -> CFilter i -> LabelFilter i CharData
attributed CharData
key CFilter i
f = forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted forall {i}. Content i -> CharData
att CFilter i
f
  where att :: Content i -> CharData
att (CElem (Elem QName
_ [Attribute]
as [Content i]
_) i
_) =
            case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (CharData -> QName
N CharData
key) [Attribute]
as of
              Maybe AttValue
Nothing  -> CharData
""
              (Just v :: AttValue
v@(AttValue [Either CharData Reference]
_)) -> forall a. Show a => a -> CharData
show AttValue
v
        att Content i
_ = CharData
""

-- | Label each textual part of the result with its text.  Element
--   results get an empty string label.
textlabelled :: CFilter i -> LabelFilter i (Maybe String)
textlabelled :: forall i. CFilter i -> LabelFilter i (Maybe CharData)
textlabelled CFilter i
f = forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted forall {i}. Content i -> Maybe CharData
text CFilter i
f
  where text :: Content i -> Maybe CharData
text (CString Bool
_ CharData
s i
_) = forall a. a -> Maybe a
Just CharData
s
        text Content i
_               = forall a. Maybe a
Nothing

-- | Label each content with some information extracted from itself.
extracted :: (Content i->a) -> CFilter i -> LabelFilter i a
extracted :: forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted Content i -> a
proj CFilter i
f = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Content i
c->[(Content i -> a
proj Content i
c, Content i
c)]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f



{-
-- MISC

-- | I haven't yet remembered \/ worked out what this does.
combine :: (Read a,Show a) => ([a]->a) -> LabelFilter String -> CFilter
combine f lf = \c-> [ CString False (show (f [ read l | (l,_) <- lf c ])) ]
-}


{- OLD STUFF - OBSOLETE
-- Keep an element by its numbered position (starting at 1).
position :: Int -> [Content] -> [Content]
position n | n>0  = (:[]) . (!!(n-1))
           | otherwise = const []

-- Chop and remove the root portions of trees to depth n.
layer :: Int -> [Content] -> [Content]
layer n = apply n (concatMap lay)
  where lay (CElem (Elem _ _ cs)) = cs
        lay _ = []
        apply 0 f xs = xs
        apply n f xs = apply (n-1) f (f xs)

combine :: (Read a, Show a) => ([a]->a) -> [Content] -> [Content]
combine f = \cs-> [ CString False (show (f [ read s | CString _ s <- cs ])) ]
-}