src/Symantic/XML/Tree/Data.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE InstanceSigs #-}
   3 {-# LANGUAGE PatternSynonyms #-}
   4 {-# LANGUAGE StrictData #-}
   5 {-# LANGUAGE ViewPatterns #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Symantic.XML.Tree.Data
   8  ( module Symantic.XML.Tree.Data
   9  , TS.unTree
  10  , TS.subTrees
  11  ) where
  12
  13 import Control.Applicative (Applicative(..))
  14 import Data.Bool
  15 import Data.Either (Either(..))
  16 import Data.Eq (Eq(..))
  17 import Data.Foldable (Foldable(..))
  18 import Data.Function (($), id)
  19 import Data.Functor ((<$>))
  20 import Data.Functor.Identity (Identity(..))
  21 import Data.Maybe (Maybe(..))
  22 import Data.Monoid (Monoid(..))
  23 import Data.Ord (Ord(..))
  24 import Data.Semigroup (Semigroup(..))
  25 import Prelude (error)
  26 import Text.Show (Show(..))
  27 import qualified Data.HashMap.Strict as HM
  28 import qualified Data.Sequence as Seq
  29 import qualified Data.Text.Lazy as TL
  30 import qualified Data.TreeSeq.Strict as TS
  31
  32 import Symantic.Base
  33 import Symantic.XML.Language
  34 import Symantic.XML.RelaxNG.Language
  35 import Symantic.XML.Write
  36 import Symantic.XML.Tree.Source
  37
  38 -- * Type 'Tree'
  39 type Tree src = TS.Tree (src (Node (src EscapedAttr)))
  40
  41 -- ** Type 'Trees'
  42 type Trees src = TS.Trees (src (Node (src EscapedAttr)))
  43
  44 pattern Tree0 :: a -> TS.Tree a
  45 pattern Tree0 a <- TS.Tree a (null -> True)
  46   where Tree0 a = TS.Tree a Seq.empty
  47
  48 -- ** Type 'Node'
  49 data Node attr
  50    = NodeElem    QName (HM.HashMap QName attr) -- ^ Node.
  51    | NodePI      PName TL.Text -- ^ Leaf (except for @<?xml?>@ which has 'NodePI' children.
  52    | NodeText    EscapedText   -- ^ Leaf.
  53    | NodeComment TL.Text       -- ^ Leaf.
  54    | NodeCDATA   TL.Text       -- ^ Leaf.
  55    deriving (Eq, Ord, Show)
  56
  57 -- * Type 'TreeData'
  58 newtype TreeData params k
  59  =      TreeData
  60  {    unTreeData :: ( HM.HashMap QName (Identity EscapedAttr) ->
  61                       TL.Text ->
  62                       Trees Identity -> k
  63                     ) -> params }
  64
  65 tree :: TreeData callers (Trees Identity) -> callers
  66 tree (TreeData callers) = callers (\_as _txt ts -> ts)
  67
  68 type SourcedTree  src = Tree  (Sourced src)
  69 type SourcedTrees src = Trees (Sourced src)
  70 type FileSourcedTree  = SourcedTree  (FileSource Offset)
  71 type FileSourcedTrees = SourcedTrees (FileSource Offset)
  72
  73 -- | Unify two 'Trees', merging border 'NodeText's if any.
  74 union ::
  75  Semigroup (Sourced src EscapedText) =>
  76  SourcedTrees src -> SourcedTrees src -> SourcedTrees src
  77 union x y =
  78   case (Seq.viewr x, Seq.viewl y) of
  79    (xs Seq.:> x0, y0 Seq.:< ys) ->
  80     case (x0,y0) of
  81      (  Tree0 (Sourced sx (NodeText tx))
  82       , Tree0 (Sourced sy (NodeText ty)) ) ->
  83       xs `union`
  84       Seq.singleton (Tree0 $ (NodeText <$>) $
  85         Sourced sx tx <> Sourced sy ty) `union`
  86       ys
  87      _ -> x <> y
  88    (Seq.EmptyR, _) -> y
  89    (_, Seq.EmptyL) -> x
  90
  91 unions ::
  92  Semigroup (Sourced src EscapedText) =>
  93  Foldable f => f (SourcedTrees src) -> SourcedTrees src
  94 unions = foldl' union mempty
  95
  96 instance Emptyable TreeData where
  97   empty = TreeData (\k -> k mempty mempty mempty)
  98 instance Unitable TreeData where
  99   unit = TreeData (\k () -> k mempty mempty mempty)
 100 instance Voidable TreeData where
 101   void a (TreeData x) = TreeData (`x` a)
 102 instance Dimapable TreeData where
 103   dimap _a2b b2a (TreeData x) = TreeData $ \k b ->
 104     x k (b2a b)
 105 instance Dicurryable TreeData where
 106   dicurry (_::proxy args) _construct destruct (TreeData x) = TreeData $ \k r ->
 107     uncurryN @args (x k) (destruct r)
 108 instance Composable TreeData where
 109   TreeData x <.> TreeData y = TreeData $ \k ->
 110     x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)))
 111 instance Tupable TreeData where
 112   TreeData x <:> TreeData y = TreeData $ \k (a,b) ->
 113     x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)) b) a
 114 instance Eitherable TreeData where
 115   TreeData x <+> TreeData y = TreeData $ \k -> \case
 116    Left  a -> x k a
 117    Right b -> y k b
 118 instance Constant TreeData where
 119   constant _a = TreeData $ \k _a -> k mempty mempty mempty
 120 instance Optionable TreeData where
 121   option = id
 122   optional (TreeData x) = TreeData $ \k ->
 123     \case
 124      Nothing -> k mempty mempty mempty
 125      Just a -> x k a
 126 {-
 127 instance Routable TreeData where
 128   TreeData x <!> TreeData y = TreeData $ \k ->
 129     x k :!: y k
 130 -}
 131 instance Repeatable TreeData where
 132   many0 (TreeData x) = TreeData $ \k -> \case
 133    [] -> k mempty mempty mempty
 134    a:as -> x (\ax vx tx ->
 135     unTreeData (many0 (TreeData x))
 136      (\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a
 137   many1 (TreeData x) = TreeData $ \k -> \case
 138    [] -> k mempty mempty mempty
 139    a:as -> x (\ax vx tx ->
 140     unTreeData (many1 (TreeData x))
 141      (\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a
 142 instance Textable TreeData where
 143   type TextConstraint TreeData a = EncodeText a
 144   text = TreeData $ \k v ->
 145     let t = encodeText v in
 146     k mempty t $ pure $
 147       TS.Tree (Identity (NodeText (escapeText t))) mempty
 148 instance XML TreeData where
 149   namespace _nm _ns = empty
 150   element n (TreeData x) = TreeData $ \k ->
 151     x $ \as _txt ts ->
 152       k mempty mempty $ pure $
 153         TS.Tree (Identity (NodeElem n as)) ts
 154   attribute n (TreeData x) = TreeData $ \k ->
 155     x $ \as txt _ts ->
 156       k (HM.insert n (Identity (escapeAttr txt)) as) mempty mempty
 157   literal lit = TreeData $ \k ->
 158     k mempty lit $ pure $
 159       TS.Tree (Identity (NodeText (escapeText lit))) mempty
 160   pi n = TreeData $ \k v ->
 161     k mempty mempty $ pure $
 162       TS.Tree (Identity (NodePI n v)) mempty
 163   comment = TreeData $ \k v ->
 164     k mempty mempty $ pure $
 165       TS.Tree (Identity (NodeComment v)) mempty
 166   cdata = TreeData $ \k v ->
 167     k mempty mempty $ pure $
 168       TS.Tree (Identity (NodeCDATA v)) mempty
 169 instance Permutable TreeData where
 170   type Permutation TreeData = TreeDataPerm TreeData
 171   permutable = unTreeDataPerm
 172   perm = TreeDataPerm
 173   noPerm = TreeDataPerm empty
 174   permWithDefault _a = TreeDataPerm
 175 instance Definable TreeData where
 176   define _n = id
 177 instance RelaxNG TreeData where
 178   elementMatch nc x = TreeData $ \k n ->
 179     if matchNameClass nc n
 180     then error "elementMatch: given QName does not match expected NameClass"
 181     else unTreeData (element n x) k
 182   attributeMatch nc x = TreeData $ \k n ->
 183     if matchNameClass nc n
 184     then error "attributeMatch: given QName does not match expected NameClass"
 185     else unTreeData (attribute n x) k
 186
 187 -- ** Type 'TreeDataPerm'
 188 newtype TreeDataPerm repr xml k
 189  =      TreeDataPerm
 190  {    unTreeDataPerm :: repr xml k }
 191 instance Transformable (TreeDataPerm repr) where
 192   type UnTrans (TreeDataPerm repr) = repr
 193   noTrans = TreeDataPerm
 194   unTrans = unTreeDataPerm
 195 instance Dimapable (TreeDataPerm TreeData)
 196 instance Composable (TreeDataPerm TreeData)
 197 instance Tupable (TreeDataPerm TreeData)