--------------------------------------------
-- | 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 :: a -> [a]
keep = \x :: a
x->[a
x]
none :: a->[b]
none :: a -> [b]
none = \x :: a
x->[]

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

-- | Select the @n@'th positional result of a filter.
position :: Int -> CFilter i -> CFilter i
position :: Int -> CFilter i -> CFilter i
position n :: Int
n f :: CFilter i
f = (\cs :: [Content i]
cs-> [[Content i]
cs[Content i] -> Int -> Content i
forall a. [a] -> Int -> a
!!Int
n]) ([Content i] -> [Content i]) -> CFilter i -> CFilter i
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 :: CFilter i
elm x :: Content i
x@(CElem _ _) = [Content i
x]
elm _             = []

txt :: CFilter i
txt x :: Content i
x@(CString _ _ _) = [Content i
x]
txt x :: Content i
x@(CRef _ _)      = [Content i
x]
txt _                 = []

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

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

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

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



-- 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 :: String -> (String -> CFilter i) -> CFilter i
find key :: String
key cont :: String -> CFilter i
cont c :: Content i
c@(CElem (Elem _ as :: [Attribute]
as _) _) = String -> CFilter i
cont (AttValue -> String
forall a. Show a => a -> String
show (QName -> [Attribute] -> AttValue
forall a c. Eq a => a -> [(a, c)] -> c
lookfor (String -> QName
N String
key) [Attribute]
as)) Content i
c
  where lookfor :: a -> [(a, c)] -> c
lookfor x :: a
x = c -> Maybe c -> c
forall a. a -> Maybe a -> a
fromMaybe (String -> c
forall a. HasCallStack => String -> a
error ("missing attribute: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
key)) (Maybe c -> c) -> ([(a, c)] -> Maybe c) -> [(a, c)] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [(a, c)] -> Maybe 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 :: String -> (String -> CFilter i) -> CFilter i -> CFilter i
iffind  key :: String
key  yes :: String -> CFilter i
yes no :: CFilter i
no c :: Content i
c@(CElem (Elem _ as :: [Attribute]
as _) _) =
  case (QName -> [Attribute] -> Maybe AttValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> QName
N String
key) [Attribute]
as) of
    Nothing               -> CFilter i
no Content i
c
    (Just v :: AttValue
v@(AttValue _)) -> String -> CFilter i
yes (AttValue -> String
forall a. Show a => a -> String
show AttValue
v) Content i
c
iffind _key :: String
_key _yes :: String -> CFilter i
_yes no :: CFilter i
no other :: 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 :: (String -> CFilter i) -> CFilter i -> CFilter i
ifTxt  yes :: String -> CFilter i
yes _no :: CFilter i
_no c :: Content i
c@(CString _ s :: String
s _) = String -> CFilter i
yes String
s Content i
c
ifTxt _yes :: String -> CFilter i
_yes  no :: CFilter i
no c :: 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])
p :: a -> [b]
p ?> :: (a -> [b]) -> ThenElse (a -> [b]) -> a -> [b]
?> (f :: a -> [b]
f :> g :: a -> [b]
g) = \c :: a
c-> if (Bool -> Bool
not(Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([b] -> Bool) -> (a -> [b]) -> a -> Bool
forall 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
f :: CFilter i
f o :: CFilter i -> CFilter i -> CFilter i
`o` g :: CFilter i
g = CFilter i -> [Content i] -> [Content i]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CFilter i
f ([Content i] -> [Content i]) -> CFilter i -> CFilter i
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 :: (a -> [b]) -> (a -> [b]) -> a -> [b]
union = ([b] -> [b] -> [b]) -> (a -> [b]) -> (a -> [b]) -> a -> [b]
forall a b d c. (a -> b -> d) -> (c -> a) -> (c -> b) -> c -> d
lift [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++)		-- in Haskell 98:   union = lift List.union
  where
    lift :: (a->b->d) -> (c->a) -> (c->b) -> c -> d
    lift :: (a -> b -> d) -> (c -> a) -> (c -> b) -> c -> d
lift f :: a -> b -> d
f g :: c -> a
g h :: c -> b
h = \x :: 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 :: [a -> [b]] -> a -> [b]
cat [] = [b] -> a -> [b]
forall a b. a -> b -> a
const []
cat fs :: [a -> [b]]
fs = ((a -> [b]) -> (a -> [b]) -> a -> [b]) -> [a -> [b]] -> a -> [b]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (a -> [b]) -> (a -> [b]) -> a -> [b]
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 :: (a -> c) -> (c -> a -> b) -> a -> b
andThen f :: a -> c
f g :: c -> a -> b
g = \x :: 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 :: CFilter i -> CFilter i
childrenBy f :: CFilter i
f = CFilter i
f CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
forall i. CFilter i
children

-- | Directional choice:
--   in @f |>| g@ give g-productions only if no f-productions
(|>|) :: (a->[b]) -> (a->[b]) -> (a->[b])
f :: a -> [b]
f |>| :: (a -> [b]) -> (a -> [b]) -> a -> [b]
|>| g :: a -> [b]
g = \x :: a
x-> let fx :: [b]
fx = a -> [b]
f a
x in if [b] -> Bool
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
f :: CFilter i
f with :: CFilter i -> CFilter i -> CFilter i
`with` g :: CFilter i
g = (Content i -> Bool) -> [Content i] -> [Content i]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Content i -> Bool) -> Content i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Content i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([Content i] -> Bool) -> CFilter i -> Content i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CFilter i
g) ([Content i] -> [Content i]) -> CFilter i -> CFilter i
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
f :: CFilter i
f without :: CFilter i -> CFilter i -> CFilter i
`without` g :: CFilter i
g = (Content i -> Bool) -> [Content i] -> [Content i]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Content i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([Content i] -> Bool) -> CFilter i -> Content i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CFilter i
g) ([Content i] -> [Content i]) -> CFilter i -> CFilter i
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
f :: CFilter i
f /> :: CFilter i -> CFilter i -> CFilter i
/> g :: CFilter i
g = CFilter i
g CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
forall i. CFilter i
children CFilter i -> CFilter i -> CFilter i
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
f :: CFilter i
f </ :: CFilter i -> CFilter i -> CFilter i
</ g :: CFilter i
g = CFilter i
f CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`with` (CFilter i
g CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
forall i. CFilter i
children)

-- | Join an element-matching filter with a text-only filter
et :: (String->CFilter i) -> CFilter i -> CFilter i
et :: (String -> CFilter i) -> CFilter i -> CFilter i
et f :: String -> CFilter i
f g :: CFilter i
g = (String -> CFilter i
f (String -> CFilter i) -> LabelFilter i String -> CFilter i
forall a i. (a -> CFilter i) -> LabelFilter i a -> CFilter i
`oo` CFilter i -> LabelFilter i String
forall i. CFilter i -> LabelFilter i String
tagged CFilter i
forall i. CFilter i
elm)
            CFilter i -> CFilter i -> CFilter i
forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>|
         (CFilter i
g CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
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 :: [CFilter i] -> CFilter i
path fs :: [CFilter i]
fs = (CFilter i -> CFilter i -> CFilter i)
-> CFilter i -> [CFilter i] -> CFilter i
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((CFilter i -> CFilter i -> CFilter i)
-> CFilter i -> CFilter i -> CFilter i
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
o)) CFilter i
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 :: CFilter i -> CFilter i
deep f :: CFilter i
f     = CFilter i
f CFilter i -> CFilter i -> CFilter i
forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>| (CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
deep CFilter i
f CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
forall i. CFilter i
children)
deepest :: CFilter i -> CFilter i
deepest f :: CFilter i
f  = (CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
deepest CFilter i
f CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
forall i. CFilter i
children) CFilter i -> CFilter i -> CFilter i
forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
|>| CFilter i
f
multi :: CFilter i -> CFilter i
multi f :: CFilter i
f    = CFilter i
f CFilter i -> CFilter i -> CFilter i
forall a b. (a -> [b]) -> (a -> [b]) -> a -> [b]
`union` (CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
multi CFilter i
f CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
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
f :: CFilter i
f when :: CFilter i -> CFilter i -> CFilter i
`when` g :: CFilter i
g       = CFilter i
g CFilter i -> ThenElse (CFilter i) -> CFilter i
forall a b. (a -> [b]) -> ThenElse (a -> [b]) -> a -> [b]
?> CFilter i
f CFilter i -> CFilter i -> ThenElse (CFilter i)
forall a. a -> a -> ThenElse a
:> CFilter i
forall a. a -> [a]
keep
g :: CFilter i
g guards :: CFilter i -> CFilter i -> CFilter i
`guards` f :: CFilter i
f     = CFilter i
g CFilter i -> ThenElse (CFilter i) -> CFilter i
forall a b. (a -> [b]) -> ThenElse (a -> [b]) -> a -> [b]
?> CFilter i
f CFilter i -> CFilter i -> ThenElse (CFilter i)
forall a. a -> a -> ThenElse a
:> CFilter i
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 :: CFilter i -> CFilter i
chip  f :: CFilter i
f (CElem (Elem n :: QName
n as :: [Attribute]
as cs :: [Content i]
cs) i :: i
i) = [ Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n [Attribute]
as (CFilter i -> [Content i] -> [Content i]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CFilter i
f [Content i]
cs)) i
i ]
chip _f :: CFilter i
_f c :: 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 :: CFilter i -> CFilter i
inplace  f :: CFilter i
f c :: Content i
c@(CElem (Elem name :: QName
name as :: [Attribute]
as _) i :: i
i) = [ Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
name [Attribute]
as (CFilter i
f Content i
c)) i
i ]
inplace _f :: CFilter i
_f c :: 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 :: CFilter i -> CFilter i
recursivelyInPlace f :: CFilter i
f = CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
inplace (CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
recursivelyInPlace CFilter i
f CFilter i -> CFilter i -> CFilter i
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 :: CFilter i -> CFilter i
foldXml f :: CFilter i
f = CFilter i
f CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
chip (CFilter i -> CFilter i
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 :: String -> [CFilter i] -> CFilter i
mkElem h :: String
h cfs :: [CFilter i]
cfs = \t :: Content i
t-> [ Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (String -> QName
N String
h) [] ([CFilter i] -> CFilter i
forall a b. [a -> [b]] -> a -> [b]
cat [CFilter i]
cfs Content i
t)) i
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 :: String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr h :: String
h as :: [(String, CFilter i)]
as cfs :: [CFilter i]
cfs = \t :: Content i
t-> [ Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (String -> QName
N String
h) (((String, CFilter i) -> Attribute)
-> [(String, CFilter i)] -> [Attribute]
forall a b. (a -> b) -> [a] -> [b]
map (Content i -> (String, CFilter i) -> Attribute
forall i. Content i -> (String, CFilter i) -> Attribute
attr Content i
t) [(String, CFilter i)]
as) ([CFilter i] -> CFilter i
forall a b. [a -> [b]] -> a -> [b]
cat [CFilter i]
cfs Content i
t))
                                   i
forall a. HasCallStack => a
undefined ]
  where attr :: Content i -> (String, CFilter i) -> Attribute
attr t :: Content i
t (n :: String
n,vf :: CFilter i
vf) =
            let v :: String
v = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
s | (CString _ s :: String
s _) <- (CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
deep CFilter i
forall i. CFilter i
txt CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o` CFilter i
vf) Content i
t ]
            in  (String -> QName
N String
n, [Either String Reference] -> AttValue
AttValue [String -> Either String Reference
forall a b. a -> Either a b
Left String
v])

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

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

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

-- | Replace the attributes of an element (leaving tag the same).
replaceAttrs :: [(String,String)] -> CFilter i
replaceAttrs :: [(String, String)] -> CFilter i
replaceAttrs as :: [(String, String)]
as (CElem (Elem n :: QName
n _ cs :: [Content i]
cs) i :: i
i) = [Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n [Attribute]
as' [Content i]
cs) i
i]
    where as' :: [Attribute]
as' = ((String, String) -> Attribute)
-> [(String, String)] -> [Attribute]
forall a b. (a -> b) -> [a] -> [b]
map (\(n :: String
n,v :: String
v)-> (String -> QName
N String
n, [Either String Reference] -> AttValue
AttValue [String -> Either String Reference
forall a b. a -> Either a b
Left String
v])) [(String, String)]
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 :: String -> String -> CFilter a
addAttribute name :: String
name val :: String
val (CElem (Elem n :: QName
n   as :: [Attribute]
as   cs :: [Content a]
cs) i :: a
i) =
                      [Element a -> a -> Content a
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content a] -> Element a
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n (Attribute
aAttribute -> [Attribute] -> [Attribute]
forall a. a -> [a] -> [a]
:[Attribute]
as) [Content a]
cs) a
i]
  where a :: Attribute
a = (String -> QName
N String
name, [Either String Reference] -> AttValue
AttValue [String -> Either String Reference
forall a b. a -> Either a b
Left String
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.
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
f :: a -> CFilter i
f oo :: (a -> CFilter i) -> LabelFilter i a -> CFilter i
`oo` g :: LabelFilter i a
g = ((a, Content i) -> [Content i]) -> [(a, Content i)] -> [Content i]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((a -> CFilter i) -> (a, Content i) -> [Content i]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> CFilter i
f) ([(a, Content i)] -> [Content i]) -> LabelFilter i a -> CFilter i
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))
f :: CFilter i -> LabelFilter i a
f x :: (CFilter i -> LabelFilter i a)
-> (CFilter i -> LabelFilter i b)
-> CFilter i
-> LabelFilter i (a, b)
`x` g :: CFilter i -> LabelFilter i b
g = \cf :: CFilter i
cf c :: Content i
c-> let gs :: [b]
gs = ((b, Content i) -> b) -> [(b, Content i)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, Content i) -> b
forall a b. (a, b) -> a
fst (CFilter i -> LabelFilter i b
g CFilter i
cf Content i
c)
                      fs :: [a]
fs = ((a, Content i) -> a) -> [(a, Content i)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Content i) -> a
forall a b. (a, b) -> a
fst (CFilter i -> LabelFilter i a
f CFilter i
cf Content i
c)
                  in [(a, b)] -> [Content i] -> [((a, b), Content i)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [b] -> [(a, b)]
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 :: CFilter i -> LabelFilter i Int
numbered f :: CFilter i
f = [Int] -> [Content i] -> [(Int, Content i)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] ([Content i] -> [(Int, Content i)])
-> CFilter i -> LabelFilter i Int
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 :: String -> CFilter i -> String -> LabelFilter i String
interspersed a :: String
a f :: CFilter i
f b :: String
b =
  (\xs :: [Content i]
xs-> [String] -> [Content i] -> [(String, Content i)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> String -> [String]
forall a. Int -> a -> [a]
replicate ([Content i] -> Int
forall a. [a] -> Int
len [Content i]
xs) String
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
b]) [Content i]
xs) ([Content i] -> [(String, Content i)])
-> CFilter i -> LabelFilter i String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter i
f
  where
  len :: [a] -> Int
len [] = 0
  len xs :: [a]
xs = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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 :: CFilter i -> LabelFilter i String
tagged f :: CFilter i
f = (Content i -> String) -> CFilter i -> LabelFilter i String
forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted Content i -> String
forall i. Content i -> String
name CFilter i
f
  where name :: Content i -> String
name (CElem (Elem n :: QName
n _ _) _) = QName -> String
printableName QName
n
        name _                      = ""

-- | 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 :: String -> CFilter i -> LabelFilter i String
attributed key :: String
key f :: CFilter i
f = (Content i -> String) -> CFilter i -> LabelFilter i String
forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted Content i -> String
forall i. Content i -> String
att CFilter i
f
  where att :: Content i -> String
att (CElem (Elem _ as :: [Attribute]
as _) _) =
            case (QName -> [Attribute] -> Maybe AttValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> QName
N String
key) [Attribute]
as) of
              Nothing  -> ""
              (Just v :: AttValue
v@(AttValue _)) -> AttValue -> String
forall a. Show a => a -> String
show AttValue
v
        att _ = ""

-- | 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 :: CFilter i -> LabelFilter i (Maybe String)
textlabelled f :: CFilter i
f = (Content i -> Maybe String)
-> CFilter i -> LabelFilter i (Maybe String)
forall i a. (Content i -> a) -> CFilter i -> LabelFilter i a
extracted Content i -> Maybe String
forall i. Content i -> Maybe String
text CFilter i
f
  where text :: Content i -> Maybe String
text (CString _ s :: String
s _) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
        text _               = Maybe String
forall a. Maybe a
Nothing

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