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 {
      forall name str. T name str -> Name name
name_       :: Tag.Name name,
      forall name str. T name str -> [T name str]
attributes_ :: [Attr.T name str]
   } deriving (Int -> T name str -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall name str.
(Attribute name, Show name, Show str) =>
Int -> T name str -> ShowS
forall name str.
(Attribute name, Show name, Show str) =>
[T name str] -> ShowS
forall name str.
(Attribute name, Show name, Show str) =>
T name str -> String
showList :: [T name str] -> ShowS
$cshowList :: forall name str.
(Attribute name, Show name, Show str) =>
[T name str] -> ShowS
show :: T name str -> String
$cshow :: forall name str.
(Attribute name, Show name, Show str) =>
T name str -> String
showsPrec :: Int -> T name str -> ShowS
$cshowsPrec :: forall name str.
(Attribute name, Show name, Show str) =>
Int -> T name str -> ShowS
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 :: forall name str.
(Tag name, Attribute name) =>
Name name -> [T name str] -> T name str
cons = forall name str. Name name -> [T name str] -> T name str
Cons

name :: Accessor.T (T name str) (Tag.Name name)
name :: forall name str. T (T name str) (Name name)
name = forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\Name name
n T name str
p -> T name str
p{name_ :: Name name
name_ = Name name
n}) forall name str. T name str -> Name name
name_

attributes :: Accessor.T (T name str) [Attr.T name str]
attributes :: forall name str. T (T name str) [T name str]
attributes = forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\[T name str]
n T name str
p -> T name str
p{attributes_ :: [T name str]
attributes_ = [T name str]
n}) forall name str. T name str -> [T name str]
attributes_


-- * tests

checkName :: (Tag.Name name -> Bool) -> (T name str -> Bool)
checkName :: forall name str. (Name name -> Bool) -> T name str -> Bool
checkName Name name -> Bool
p (Cons Name name
tagName [T name str]
_) = Name name -> Bool
p Name name
tagName

checkAttributes :: ([Attr.T name str] -> Bool) -> (T name str -> Bool)
checkAttributes :: forall name str. ([T name str] -> Bool) -> T name str -> Bool
checkAttributes [T name str] -> Bool
p (Cons Name name
_ [T name str]
attrs) = [T name str] -> Bool
p [T name str]
attrs


-- * modification

instance Functor (T name) where
   fmap :: forall a b. (a -> b) -> T name a -> T name b
fmap a -> b
f (Cons Name name
tagName [T name a]
attrs) =
      forall name str. Name name -> [T name str] -> T name str
Cons Name name
tagName (forall str0 str1 name.
(str0 -> str1) -> [T name str0] -> [T name str1]
Attr.mapValues a -> b
f [T name a]
attrs)


lift ::
   (Tag.Name name -> [Attr.T name str] -> (Tag.Name name, [Attr.T name str])) ->
   (Filter name str)
lift :: forall name str.
(Name name -> [T name str] -> (Name name, [T name str]))
-> Filter name str
lift Name name -> [T name str] -> (Name name, [T name str])
f (Cons Name name
tagName [T name str]
attrs) =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall name str. Name name -> [T name str] -> T name str
Cons (Name name -> [T name str] -> (Name name, [T name str])
f Name name
tagName [T name str]
attrs)


-- | process the attribute list of a specific tag
processAttrs ::
   (Name.Tag name, Name.Attribute name) =>
   (Tag.Name name -> Bool) ->
   ([Attr.T name str] -> [Attr.T name str]) ->
   (Filter name str)
processAttrs :: forall name str.
(Tag name, Attribute name) =>
(Name name -> Bool)
-> ([T name str] -> [T name str]) -> Filter name str
processAttrs Name name -> Bool
p [T name str] -> [T name str]
f =
   forall name str.
(Name name -> [T name str] -> (Name name, [T name str]))
-> Filter name str
lift (\Name name
tagName ->
      (,) Name name
tagName forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Name name -> Bool
p Name name
tagName then [T name str] -> [T name str]
f else forall a. a -> a
id)

processAttrValue ::
   (Name.Tag name, Name.Attribute name) =>
   (Tag.Name name, Attr.Name name) ->
   (str -> str) ->
   (Filter name str)
processAttrValue :: forall name str.
(Tag name, Attribute name) =>
(Name name, Name name) -> (str -> str) -> Filter name str
processAttrValue (Name name
tagName,Name name
attrName) str -> str
f =
   forall name str.
(Tag name, Attribute name) =>
(Name name -> Bool)
-> ([T name str] -> [T name str]) -> Filter name str
processAttrs (Name name
tagName forall a. Eq a => a -> a -> Bool
==)
      (forall name string.
(Name name -> Bool)
-> (string -> string) -> [T name string] -> [T name string]
Attr.adjustOn (Name name
attrName forall a. Eq a => a -> a -> Bool
==) str -> str
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 :: forall name str.
(Tag name, Attribute name) =>
(Name name, Name name)
-> ([T name str] -> Bool) -> (str -> str) -> Filter name str
processAttrValueCond (Name name
tagName,Name name
attrName) [T name str] -> Bool
cond str -> str
f =
   forall name str.
(Tag name, Attribute name) =>
(Name name -> Bool)
-> ([T name str] -> [T name str]) -> Filter name str
processAttrs (Name name
tagName forall a. Eq a => a -> a -> Bool
==)
      (\[T name str]
attrs -> forall name string.
(Name name -> Bool)
-> (string -> string) -> [T name string] -> [T name string]
Attr.adjustOn (Name name
attrName forall a. Eq a => a -> a -> Bool
==)
         (if [T name str] -> Bool
cond [T name str]
attrs then str -> str
f else forall a. a -> a
id)
         [T name str]
attrs)



instance Foldable (T name) where
   foldMap :: forall m a. Monoid m => (a -> m) -> T name a -> m
foldMap a -> m
f (Cons Name name
_tagName [T name a]
attrs) =
      forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [T name a]
attrs

instance Traversable (T name) where
   traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> T name a -> f (T name b)
traverse a -> f b
f (Cons Name name
tagName [T name a]
attrs) =
      forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
App.liftA (forall name str. Name name -> [T name str] -> T name str
Cons Name name
tagName) (forall (f :: * -> *) str0 str1 name.
Applicative f =>
(str0 -> f str1) -> [T name str0] -> f [T name str1]
Attr.mapValuesA a -> f b
f [T name a]
attrs)



-- * monadic modification

-- | process the attribute list of a specific tag
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 :: forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name -> Bool)
-> ([T name str] -> m [T name str]) -> T name str -> m (T name str)
processAttrsA Name name -> Bool
p [T name str] -> m [T name str]
f =
   forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name -> [T name str] -> m (Name name, [T name str]))
-> T name str -> m (T name str)
liftA (\Name name
tagName ->
      forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
App.liftA ((,) Name name
tagName) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      if Name name -> Bool
p Name name
tagName then [T name str] -> m [T name str]
f else forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name, Name name)
-> (str -> m str) -> T name str -> m (T name str)
processAttrValueA (Name name
tagName,Name name
attrName) str -> m str
f =
   forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name -> Bool)
-> ([T name str] -> m [T name str]) -> T name str -> m (T name str)
processAttrsA (Name name
tagNameforall a. Eq a => a -> a -> Bool
==)
      (forall (f :: * -> *) name string.
Applicative f =>
(Name name -> Bool)
-> (string -> f string) -> [T name string] -> f [T name string]
Attr.adjustOnA (Name name
attrNameforall a. Eq a => a -> a -> Bool
==) str -> m str
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 :: forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name, Name name)
-> ([T name str] -> Bool)
-> (str -> m str)
-> T name str
-> m (T name str)
processAttrValueCondA (Name name
tagName,Name name
attrName) [T name str] -> Bool
cond str -> m str
f =
   forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name -> Bool)
-> ([T name str] -> m [T name str]) -> T name str -> m (T name str)
processAttrsA (Name name
tagNameforall a. Eq a => a -> a -> Bool
==)
      (\[T name str]
attrs -> forall (f :: * -> *) name string.
Applicative f =>
(Name name -> Bool)
-> (string -> f string) -> [T name string] -> f [T name string]
Attr.adjustOnA (Name name
attrNameforall a. Eq a => a -> a -> Bool
==)
         (if [T name str] -> Bool
cond [T name str]
attrs then str -> m str
f else forall (f :: * -> *) a. Applicative f => a -> f a
App.pure)
         [T name str]
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 :: forall name (m :: * -> *) str.
(Tag name, Attribute name, Applicative m) =>
(Name name -> [T name str] -> m (Name name, [T name str]))
-> T name str -> m (T name str)
liftA Name name -> [T name str] -> m (Name name, [T name str])
f (Cons Name name
tagName [T name str]
attrs) =
   forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
App.liftA (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall name str. Name name -> [T name str] -> T name str
Cons) (Name name -> [T name str] -> m (Name name, [T name str])
f Name name
tagName [T name str]
attrs)



-- * format

format ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   (Tag.Name name -> Bool) -> ShowS -> T name string -> [ShowS] -> ShowS
format :: forall name string.
(Tag name, Attribute name, C string) =>
(Name name -> Bool) -> ShowS -> T name string -> [ShowS] -> ShowS
format Name name -> Bool
isCondensed ShowS
trailingSlash (Cons Name name
tagName [T name string]
attrs) [ShowS]
formatSubTrees =
   let t :: String
t = forall name. C name => name -> String
Name.toString Name name
tagName
   in  if Name name -> Bool
isCondensed Name name
tagName
         then ShowS -> ShowS
Format.angle
               (String -> ShowS
showString String
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name string.
(Attribute name, C string) =>
[T name string] -> ShowS
Attr.formatListBlankHead [T name string]
attrs
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trailingSlash)
         else ShowS -> ShowS
Format.angle
               (String -> ShowS
showString String
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name string.
(Attribute name, C string) =>
[T name string] -> ShowS
Attr.formatListBlankHead [T name string]
attrs)
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [ShowS]
formatSubTrees
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> ShowS
Format.angle (ShowS
Format.slash forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
t)