module Text.XML.WraXML.Element where
import qualified Text.XML.Basic.Tag as Tag
import qualified Text.XML.Basic.Attribute as Attr
import qualified Text.XML.Basic.Name as Name
import qualified Data.Accessor.Basic as Accessor
import Data.Foldable as Foldable(Foldable(foldMap))
import Data.Traversable as Traversable(Traversable(traverse))
import Control.Applicative (Applicative, )
import qualified Control.Applicative as App
import Data.Monoid (mconcat, )
import qualified Text.XML.Basic.Format as Format
data T name str =
Cons {
name_ :: Tag.Name name,
attributes_ :: [Attr.T name str]
} deriving (Show)
type Filter name str = T name str -> T name str
cons ::
(Name.Tag name, Name.Attribute name) =>
Tag.Name name -> [Attr.T name str] -> T name str
cons = Cons
name :: Accessor.T (T name str) (Tag.Name name)
name = Accessor.fromSetGet (\n p -> p{name_ = n}) name_
attributes :: Accessor.T (T name str) [Attr.T name str]
attributes = Accessor.fromSetGet (\n p -> p{attributes_ = n}) attributes_
checkName :: (Tag.Name name -> Bool) -> (T name str -> Bool)
checkName p (Cons tagName _) = p tagName
checkAttributes :: ([Attr.T name str] -> Bool) -> (T name str -> Bool)
checkAttributes p (Cons _ attrs) = p attrs
instance Functor (T name) where
fmap f (Cons tagName attrs) =
Cons tagName (Attr.mapValues f attrs)
lift ::
(Tag.Name name -> [Attr.T name str] -> (Tag.Name name, [Attr.T name str])) ->
(Filter name str)
lift f (Cons tagName attrs) =
uncurry Cons (f tagName attrs)
processAttrs ::
(Name.Tag name, Name.Attribute name) =>
(Tag.Name name -> Bool) ->
([Attr.T name str] -> [Attr.T name str]) ->
(Filter name str)
processAttrs p f =
lift (\tagName ->
(,) tagName . if p tagName then f else id)
processAttrValue ::
(Name.Tag name, Name.Attribute name) =>
(Tag.Name name, Attr.Name name) ->
(str -> str) ->
(Filter name str)
processAttrValue (tagName,attrName) f =
processAttrs (tagName ==)
(Attr.adjustOn (attrName ==) f)
processAttrValueCond ::
(Name.Tag name, Name.Attribute name) =>
(Tag.Name name, Attr.Name name) ->
([Attr.T name str] -> Bool) ->
(str -> str) ->
(Filter name str)
processAttrValueCond (tagName,attrName) cond f =
processAttrs (tagName ==)
(\attrs -> Attr.adjustOn (attrName ==)
(if cond attrs then f else id)
attrs)
instance Foldable (T name) where
foldMap f (Cons _tagName attrs) =
mconcat $ map (foldMap f) attrs
instance Traversable (T name) where
traverse f (Cons tagName attrs) =
App.liftA (Cons tagName) (Attr.mapValuesA f attrs)
processAttrsA ::
(Name.Tag name, Name.Attribute name, Applicative m) =>
(Tag.Name name -> Bool) ->
([Attr.T name str] -> m [Attr.T name str]) ->
(T name str -> m (T name str))
processAttrsA p f =
liftA (\tagName ->
App.liftA ((,) tagName) .
if p tagName then f else App.pure)
processAttrValueA ::
(Name.Tag name, Name.Attribute name, Applicative m) =>
(Tag.Name name, Attr.Name name) ->
(str -> m str) ->
(T name str -> m (T name str))
processAttrValueA (tagName,attrName) f =
processAttrsA (tagName==)
(Attr.adjustOnA (attrName==) f)
processAttrValueCondA ::
(Name.Tag name, Name.Attribute name, Applicative m) =>
(Tag.Name name, Attr.Name name) ->
([Attr.T name str] -> Bool) ->
(str -> m str) ->
(T name str -> m (T name str))
processAttrValueCondA (tagName,attrName) cond f =
processAttrsA (tagName==)
(\attrs -> Attr.adjustOnA (attrName==)
(if cond attrs then f else App.pure)
attrs)
liftA ::
(Name.Tag name, Name.Attribute name, Applicative m) =>
(Tag.Name name -> [Attr.T name str] ->
m (Tag.Name name, [Attr.T name str])) ->
(T name str -> m (T name str))
liftA f (Cons tagName attrs) =
App.liftA (uncurry Cons) (f tagName attrs)
format ::
(Name.Tag name, Name.Attribute name, Format.C string) =>
(Tag.Name name -> Bool) -> ShowS -> T name string -> [ShowS] -> ShowS
format isCondensed trailingSlash (Cons tagName attrs) formatSubTrees =
let t = Name.toString tagName
in if isCondensed tagName
then Format.angle
(showString t . Attr.formatListBlankHead attrs
. trailingSlash)
else Format.angle
(showString t . Attr.formatListBlankHead attrs)
. foldr (.) id formatSubTrees
. Format.angle (Format.slash . showString t)