Data/TreeSeq/Strict/Zipper.hs

   1 module Data.TreeSeq.Strict.Zipper where
   2
   3 import Control.Arrow (Kleisli(..))
   4 import Control.Applicative (Applicative(..), Alternative(..))
   5 import Control.Monad (Monad(..), (>=>))
   6 import Data.Bool
   7 import Data.Eq (Eq)
   8 import Data.Function (($), (.))
   9 import Data.Functor ((<$>))
  10 import Data.Int (Int)
  11 import Data.List.NonEmpty (NonEmpty(..))
  12 import Data.Maybe (Maybe(..), maybe, mapMaybe)
  13 import Data.Monoid (Monoid(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
  16 import Data.Typeable (Typeable)
  17 import Prelude (undefined)
  18 import Text.Show (Show(..))
  19 import qualified Data.List as List
  20 import qualified Data.List.NonEmpty as NonEmpty
  21 import qualified Data.Sequence as Seq
  22
  23 import Data.TreeSeq.Strict (Trees, Tree(..))
  24
  25 -- * Type 'Zipper'
  26 type Zipper k a = NonEmpty (Cursor k a)
  27
  28 -- | Return a 'Zipper' starting at the given 'Tree'.
  29 zipper :: Tree k a -> Zipper k a
  30 zipper t = Cursor mempty t mempty :| []
  31
  32 -- | Return a 'Zipper' starting at the left-most 'Tree' of the given 'Trees'.
  33 zippers :: Trees k a -> [Zipper k a]
  34 zippers ts =
  35         case Seq.viewl ts of
  36          EmptyL -> empty
  37          l :< ls -> pure $ Cursor mempty l ls :| []
  38
  39 -- | Return the 'Cursor' after zipping the given 'Zipper' upto its last parent.
  40 root :: Zipper k a -> Cursor k a
  41 root = NonEmpty.head . List.last . axis_ancestor_or_self
  42
  43 -- | Return the keys within the 'TreeN' nodes
  44 -- leading to the current 'Cursor' of the given 'Zipper'.
  45 path :: Zipper k x -> [k]
  46 path cs =
  47         List.reverse $
  48         NonEmpty.toList cs >>= \c ->
  49                 case cursor_self c of
  50                  TreeN k _ -> [k]
  51                  Tree0{}   -> []
  52
  53 -- | Return the 'Tree' currently under the 'Cursor'.
  54 current :: Zipper k a -> Tree k a
  55 current (Cursor _ t _ :| _) = t
  56
  57 -- | Return the 'Tree's selected by the given 'Axis' from the given 'Zipper'.
  58 select :: Axis k a -> Zipper k a -> [Tree k a]
  59 select axis c = cursor_self . NonEmpty.head <$> axis c
  60
  61 -- | Return the filtered values selected by the given 'Axis' from the given 'Zipper'.
  62 filter :: Axis k a -> (Zipper k a -> Maybe b) -> Zipper k a -> [b]
  63 filter axis f c = f `mapMaybe` axis c
  64
  65 -- ** Type 'Cursor'
  66 data Cursor k a
  67  =   Cursor
  68  {   cursor_precedings :: Trees k a
  69  ,   cursor_self       :: Tree  k a
  70  ,   cursor_followings :: Trees k a
  71  } deriving (Eq, Show, Typeable)
  72
  73 -- * Type 'Axis'
  74 type Axis k a = Zipper k a -> [Zipper k a]
  75
  76 -- ** Type 'KleisliAxis'
  77 type KleisliAxis k a = Kleisli [] (Zipper k a) (Zipper k a)
  78
  79 -- ** Type 'AxisAlt'
  80 -- | Like 'Axis', but generalized with 'Alternative'.
  81 --
  82 -- Useful to return a 'Maybe' instead of a list.
  83 type AxisAlt f k a = Zipper k a -> f (Zipper k a)
  84
  85 -- ** Axis @repeat@
  86 -- | Collect all 'Zipper's along a given axis,
  87 --   including the first 'Zipper'.
  88 axis_repeat :: AxisAlt Maybe k a -> Axis k a
  89 axis_repeat f c = c : maybe [] (axis_repeat f) (f c)
  90
  91 -- | Collect all 'Zipper's along a given axis,
  92 --   excluding the starting 'Zipper'.
  93 axis_repeat_without_self :: AxisAlt Maybe k a -> Axis k a
  94 axis_repeat_without_self f c = maybe [] (axis_repeat f) (f c)
  95
  96 -- ** Axis @filter@
  97 axis_filter :: Axis k a -> (Zipper k a -> Bool) -> Axis k a
  98 axis_filter axis f c = List.filter f (axis c)
  99 infixl 5 `axis_filter`
 100
 101 -- ** Axis @at@
 102 axis_at :: Alternative f => Axis k a -> Int -> AxisAlt f k a
 103 axis_at axis i c =
 104         case List.drop i $ axis c of
 105          []  -> empty
 106          a:_ -> pure a
 107 infixl 5 `axis_at`
 108
 109 -- ** Axis @self@
 110 axis_self :: Applicative f => AxisAlt f k a
 111 axis_self = pure
 112
 113 -- ** Axis @child@
 114 axis_child :: Axis k a
 115 axis_child c =
 116         axis_child_first c >>=
 117         axis_repeat axis_following1
 118
 119 axis_child_lookup_first :: Alternative f => (k -> Bool) -> AxisAlt f k a
 120 axis_child_lookup_first fk c = listHead $ axis_child_lookup fk c
 121
 122 axis_child_lookup :: (k -> Bool) -> Axis k a
 123 axis_child_lookup fk cs@(Cursor _ps t _fs :| _) =
 124         (<$> Seq.findIndicesL flt ns) $ \i ->
 125                 let (ps, ps') = Seq.splitAt i ns in
 126                 case Seq.viewl ps' of
 127                  EmptyL -> undefined
 128                  l :< ls -> Cursor ps l ls :| NonEmpty.toList cs
 129         where
 130         ns = nodesTree t
 131         flt (TreeN k _) = fk k
 132         flt Tree0{}     = False
 133
 134 axis_child_first :: Alternative f => AxisAlt f k a
 135 axis_child_first cs@(Cursor _ps t _fs :| _) =
 136         case Seq.viewl $ nodesTree t of
 137          EmptyL -> empty
 138          l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList cs
 139
 140 axis_child_last :: Alternative f => AxisAlt f k a
 141 axis_child_last cs@(Cursor _ps t _fs :| _) =
 142         case Seq.viewr $ nodesTree t of
 143          EmptyR -> empty
 144          rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList cs
 145
 146 -- ** Axis @ancestor@
 147 axis_ancestor :: Axis k a
 148 axis_ancestor = axis_repeat_without_self axis_parent
 149
 150 axis_ancestor_or_self :: Axis k a
 151 axis_ancestor_or_self = axis_repeat axis_parent
 152
 153 axis_root :: Alternative f => AxisAlt f k a
 154 axis_root = pure . List.last . axis_ancestor_or_self
 155
 156 -- ** Axis @descendant@
 157 axis_descendant_or_self :: Axis k a
 158 axis_descendant_or_self =
 159         collect_child []
 160         where
 161         collect_child acc c =
 162                 c : maybe acc
 163                  (collect_following_first acc)
 164                  (axis_child_first c)
 165         collect_following_first acc c =
 166                 collect_child
 167                  (maybe acc
 168                          (collect_following_first acc)
 169                          (axis_following1 c)
 170                  ) c
 171
 172 axis_descendant_or_self_reverse :: Axis k a
 173 axis_descendant_or_self_reverse c =
 174         c :
 175         List.concatMap
 176          axis_descendant_or_self_reverse
 177          (List.reverse $ axis_child c)
 178
 179 axis_descendant :: Axis k a
 180 axis_descendant = List.tail . axis_descendant_or_self
 181
 182 -- ** Axis @preceding@
 183 axis_preceding1 :: Alternative f => AxisAlt f k a
 184 axis_preceding1 (Cursor ps t fs :| cs) =
 185         case Seq.viewr ps of
 186          EmptyR  -> empty
 187          rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
 188
 189 axis_preceding_sibling :: Axis k a
 190 axis_preceding_sibling = axis_repeat_without_self axis_preceding1
 191
 192 axis_preceding_sibling_first :: Alternative f => AxisAlt f k a
 193 axis_preceding_sibling_first z@(Cursor ps t fs :| cs) =
 194         case Seq.viewl (ps |> t) of
 195          EmptyL  -> pure z
 196          l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
 197
 198 axis_preceding :: Axis k a
 199 axis_preceding =
 200         axis_ancestor_or_self >=>
 201         axis_preceding_sibling >=>
 202         axis_descendant_or_self_reverse
 203
 204 -- ** Axis @following@
 205 axis_following1 :: Alternative f => AxisAlt f k a
 206 axis_following1 (Cursor ps t fs :| cs) =
 207         case Seq.viewl fs of
 208          EmptyL  -> empty
 209          l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
 210
 211 axis_following_sibling :: Axis k a
 212 axis_following_sibling = axis_repeat_without_self axis_following1
 213
 214 axis_following_sibling_last :: Alternative f => AxisAlt f k a
 215 axis_following_sibling_last z@(Cursor ps t fs :| cs) =
 216         case Seq.viewr (t <| fs) of
 217          EmptyR  -> pure z
 218          rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
 219
 220 axis_following :: Axis k a
 221 axis_following =
 222         axis_ancestor_or_self >=>
 223         axis_following_sibling >=>
 224         axis_descendant_or_self
 225
 226 -- ** Axis @parent@
 227 axis_parent :: Alternative f => AxisAlt f k a
 228 axis_parent (Cursor ps t fs :| cs) =
 229         case cs of
 230          Cursor ps' (TreeN k _) fs' : cs' ->
 231                 pure $ Cursor ps' (TreeN k $ (ps |> t) <> fs) fs' :| cs'
 232          _ -> empty
 233
 234 -- * Utilities
 235 nodesTree :: Tree k a -> Trees k a
 236 nodesTree Tree0{}       = mempty
 237 nodesTree (TreeN _k ts) = ts
 238
 239 listHead :: Alternative f => [a] -> f a
 240 listHead []    = empty
 241 listHead (a:_) = pure a