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_filter_current :: Axis k a -> (Tree k a -> Bool) -> Axis k a
 102 axis_filter_current axis f c = List.filter (f . current) (axis c)
 103 infixl 5 `axis_filter_current`
 104
 105 -- ** Axis @at@
 106 axis_at :: Alternative f => Axis k a -> Int -> AxisAlt f k a
 107 axis_at axis i c =
 108         case List.drop i $ axis c of
 109          []  -> empty
 110          a:_ -> pure a
 111 infixl 5 `axis_at`
 112
 113 -- ** Axis @self@
 114 axis_self :: Applicative f => AxisAlt f k a
 115 axis_self = pure
 116
 117 -- ** Axis @child@
 118 axis_child :: Axis k a
 119 axis_child c =
 120         axis_child_first c >>=
 121         axis_repeat axis_following1
 122
 123 axis_child_lookup_first :: Alternative f => (k -> Bool) -> AxisAlt f k a
 124 axis_child_lookup_first fk c = listHead $ axis_child_lookup fk c
 125
 126 axis_child_lookup :: (k -> Bool) -> Axis k a
 127 axis_child_lookup fk cs@(Cursor _ps t _fs :| _) =
 128         (<$> Seq.findIndicesL flt ns) $ \i ->
 129                 let (ps, ps') = Seq.splitAt i ns in
 130                 case Seq.viewl ps' of
 131                  EmptyL -> undefined
 132                  l :< ls -> Cursor ps l ls :| NonEmpty.toList cs
 133         where
 134         ns = nodesTree t
 135         flt (TreeN k _) = fk k
 136         flt Tree0{}     = False
 137
 138 axis_child_first :: Alternative f => AxisAlt f k a
 139 axis_child_first cs@(Cursor _ps t _fs :| _) =
 140         case Seq.viewl $ nodesTree t of
 141          EmptyL -> empty
 142          l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList cs
 143
 144 axis_child_last :: Alternative f => AxisAlt f k a
 145 axis_child_last cs@(Cursor _ps t _fs :| _) =
 146         case Seq.viewr $ nodesTree t of
 147          EmptyR -> empty
 148          rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList cs
 149
 150 -- ** Axis @ancestor@
 151 axis_ancestor :: Axis k a
 152 axis_ancestor = axis_repeat_without_self axis_parent
 153
 154 axis_ancestor_or_self :: Axis k a
 155 axis_ancestor_or_self = axis_repeat axis_parent
 156
 157 axis_root :: Alternative f => AxisAlt f k a
 158 axis_root = pure . List.last . axis_ancestor_or_self
 159
 160 -- ** Axis @descendant@
 161 axis_descendant_or_self :: Axis k a
 162 axis_descendant_or_self =
 163         collect_child []
 164         where
 165         collect_child acc c =
 166                 c : maybe acc
 167                  (collect_following_first acc)
 168                  (axis_child_first c)
 169         collect_following_first acc c =
 170                 collect_child
 171                  (maybe acc
 172                          (collect_following_first acc)
 173                          (axis_following1 c)
 174                  ) c
 175
 176 axis_descendant_or_self_reverse :: Axis k a
 177 axis_descendant_or_self_reverse c =
 178         c :
 179         List.concatMap
 180          axis_descendant_or_self_reverse
 181          (List.reverse $ axis_child c)
 182
 183 axis_descendant :: Axis k a
 184 axis_descendant = List.tail . axis_descendant_or_self
 185
 186 -- ** Axis @preceding@
 187 axis_preceding1 :: Alternative f => AxisAlt f k a
 188 axis_preceding1 (Cursor ps t fs :| cs) =
 189         case Seq.viewr ps of
 190          EmptyR  -> empty
 191          rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
 192
 193 axis_preceding_sibling :: Axis k a
 194 axis_preceding_sibling = axis_repeat_without_self axis_preceding1
 195
 196 axis_preceding_sibling_first :: Alternative f => AxisAlt f k a
 197 axis_preceding_sibling_first z@(Cursor ps t fs :| cs) =
 198         case Seq.viewl (ps |> t) of
 199          EmptyL  -> pure z
 200          l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
 201
 202 axis_preceding :: Axis k a
 203 axis_preceding =
 204         axis_ancestor_or_self >=>
 205         axis_preceding_sibling >=>
 206         axis_descendant_or_self_reverse
 207
 208 -- ** Axis @following@
 209 axis_following1 :: Alternative f => AxisAlt f k a
 210 axis_following1 (Cursor ps t fs :| cs) =
 211         case Seq.viewl fs of
 212          EmptyL  -> empty
 213          l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
 214
 215 axis_following_sibling :: Axis k a
 216 axis_following_sibling = axis_repeat_without_self axis_following1
 217
 218 axis_following_sibling_last :: Alternative f => AxisAlt f k a
 219 axis_following_sibling_last z@(Cursor ps t fs :| cs) =
 220         case Seq.viewr (t <| fs) of
 221          EmptyR  -> pure z
 222          rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
 223
 224 axis_following :: Axis k a
 225 axis_following =
 226         axis_ancestor_or_self >=>
 227         axis_following_sibling >=>
 228         axis_descendant_or_self
 229
 230 -- ** Axis @parent@
 231 axis_parent :: Alternative f => AxisAlt f k a
 232 axis_parent (Cursor ps t fs :| cs) =
 233         case cs of
 234          Cursor ps' (TreeN k _) fs' : cs' ->
 235                 pure $ Cursor ps' (TreeN k $ (ps |> t) <> fs) fs' :| cs'
 236          _ -> empty
 237
 238 -- * Utilities
 239 nodesTree :: Tree k a -> Trees k a
 240 nodesTree Tree0{}       = mempty
 241 nodesTree (TreeN _k ts) = ts
 242
 243 listHead :: Alternative f => [a] -> f a
 244 listHead []    = empty
 245 listHead (a:_) = pure a