{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.XML.Tree.Data
( module Symantic.XML.Tree.Data
, TS.unTree
, TS.subTrees
) where
import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), id)
import Data.Functor ((<$>))
import Data.Functor.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Prelude (error)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
import Symantic.Base
import Symantic.XML.Language
import Symantic.XML.RelaxNG.Language
import Symantic.XML.Write
import Symantic.XML.Tree.Source
type Tree src = TS.Tree (src (Node (src EscapedAttr)))
type Trees src = TS.Trees (src (Node (src EscapedAttr)))
pattern Tree0 :: a -> TS.Tree a
pattern Tree0 a <- TS.Tree a (null -> True)
where Tree0 a = TS.Tree a Seq.empty
data Node attr
= NodeElem QName (HM.HashMap QName attr)
| NodePI PName TL.Text
| NodeText EscapedText
| NodeComment TL.Text
| NodeCDATA TL.Text
deriving (Eq, Ord, Show)
newtype TreeData params k
= TreeData
{ unTreeData :: ( HM.HashMap QName (Identity EscapedAttr) ->
TL.Text ->
Trees Identity -> k
) -> params }
tree :: TreeData callers (Trees Identity) -> callers
tree (TreeData callers) = callers (\_as _txt ts -> ts)
type SourcedTree src = Tree (Sourced src)
type SourcedTrees src = Trees (Sourced src)
type FileSourcedTree = SourcedTree (FileSource Offset)
type FileSourcedTrees = SourcedTrees (FileSource Offset)
union ::
Semigroup (Sourced src EscapedText) =>
SourcedTrees src -> SourcedTrees src -> SourcedTrees src
union x y =
case (Seq.viewr x, Seq.viewl y) of
(xs Seq.:> x0, y0 Seq.:< ys) ->
case (x0,y0) of
( Tree0 (Sourced sx (NodeText tx))
, Tree0 (Sourced sy (NodeText ty)) ) ->
xs `union`
Seq.singleton (Tree0 $ (NodeText <$>) $
Sourced sx tx <> Sourced sy ty) `union`
ys
_ -> x <> y
(Seq.EmptyR, _) -> y
(_, Seq.EmptyL) -> x
unions ::
Semigroup (Sourced src EscapedText) =>
Foldable f => f (SourcedTrees src) -> SourcedTrees src
unions = foldl' union mempty
instance Emptyable TreeData where
empty = TreeData (\k -> k mempty mempty mempty)
instance Unitable TreeData where
unit = TreeData (\k () -> k mempty mempty mempty)
instance Voidable TreeData where
void a (TreeData x) = TreeData (`x` a)
instance Dimapable TreeData where
dimap _a2b b2a (TreeData x) = TreeData $ \k b ->
x k (b2a b)
instance Dicurryable TreeData where
dicurry (_::proxy args) _construct destruct (TreeData x) = TreeData $ \k r ->
uncurryN @args (x k) (destruct r)
instance Composable TreeData where
TreeData x <.> TreeData y = TreeData $ \k ->
x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)))
instance Tupable TreeData where
TreeData x <:> TreeData y = TreeData $ \k (a,b) ->
x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)) b) a
instance Eitherable TreeData where
TreeData x <+> TreeData y = TreeData $ \k -> \case
Left a -> x k a
Right b -> y k b
instance Constant TreeData where
constant _a = TreeData $ \k _a -> k mempty mempty mempty
instance Optionable TreeData where
option = id
optional (TreeData x) = TreeData $ \k ->
\case
Nothing -> k mempty mempty mempty
Just a -> x k a
instance Repeatable TreeData where
many0 (TreeData x) = TreeData $ \k -> \case
[] -> k mempty mempty mempty
a:as -> x (\ax vx tx ->
unTreeData (many0 (TreeData x))
(\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a
many1 (TreeData x) = TreeData $ \k -> \case
[] -> k mempty mempty mempty
a:as -> x (\ax vx tx ->
unTreeData (many1 (TreeData x))
(\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a
instance Textable TreeData where
type TextConstraint TreeData a = EncodeText a
text = TreeData $ \k v ->
let t = encodeText v in
k mempty t $ pure $
TS.Tree (Identity (NodeText (escapeText t))) mempty
instance XML TreeData where
namespace _nm _ns = empty
element n (TreeData x) = TreeData $ \k ->
x $ \as _txt ts ->
k mempty mempty $ pure $
TS.Tree (Identity (NodeElem n as)) ts
attribute n (TreeData x) = TreeData $ \k ->
x $ \as txt _ts ->
k (HM.insert n (Identity (escapeAttr txt)) as) mempty mempty
literal lit = TreeData $ \k ->
k mempty lit $ pure $
TS.Tree (Identity (NodeText (escapeText lit))) mempty
pi n = TreeData $ \k v ->
k mempty mempty $ pure $
TS.Tree (Identity (NodePI n v)) mempty
comment = TreeData $ \k v ->
k mempty mempty $ pure $
TS.Tree (Identity (NodeComment v)) mempty
cdata = TreeData $ \k v ->
k mempty mempty $ pure $
TS.Tree (Identity (NodeCDATA v)) mempty
instance Permutable TreeData where
type Permutation TreeData = TreeDataPerm TreeData
permutable = unTreeDataPerm
perm = TreeDataPerm
noPerm = TreeDataPerm empty
permWithDefault _a = TreeDataPerm
instance Definable TreeData where
define _n = id
instance RelaxNG TreeData where
elementMatch nc x = TreeData $ \k n ->
if matchNameClass nc n
then error "elementMatch: given QName does not match expected NameClass"
else unTreeData (element n x) k
attributeMatch nc x = TreeData $ \k n ->
if matchNameClass nc n
then error "attributeMatch: given QName does not match expected NameClass"
else unTreeData (attribute n x) k
newtype TreeDataPerm repr xml k
= TreeDataPerm
{ unTreeDataPerm :: repr xml k }
instance Transformable (TreeDataPerm repr) where
type UnTrans (TreeDataPerm repr) = repr
noTrans = TreeDataPerm
unTrans = unTreeDataPerm
instance Dimapable (TreeDataPerm TreeData)
instance Composable (TreeDataPerm TreeData)
instance Tupable (TreeDataPerm TreeData)