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_following_first
 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 @descendant@
 154 axis_descendant_or_self :: Axis k a
 155 axis_descendant_or_self =
 156         collect_child []
 157         where
 158         collect_child acc c =
 159                 c : maybe acc
 160                  (collect_following_first acc)
 161                  (axis_child_first c)
 162         collect_following_first acc c =
 163                 collect_child
 164                  (maybe acc
 165                          (collect_following_first acc)
 166                          (axis_following_first c)
 167                  ) c
 168
 169 axis_descendant_or_self_reverse :: Axis k a
 170 axis_descendant_or_self_reverse c =
 171         c :
 172         List.concatMap
 173          axis_descendant_or_self_reverse
 174          (List.reverse $ axis_child c)
 175
 176 axis_descendant :: Axis k a
 177 axis_descendant = List.tail . axis_descendant_or_self
 178
 179 -- ** Axis @preceding@
 180 axis_preceding_first :: Alternative f => AxisAlt f k a
 181 axis_preceding_first (Cursor ps t fs :| cs) =
 182         case Seq.viewr ps of
 183          EmptyR -> empty
 184          rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
 185
 186 axis_preceding_sibling :: Axis k a
 187 axis_preceding_sibling = axis_repeat_without_self axis_preceding_first
 188
 189 axis_preceding :: Axis k a
 190 axis_preceding =
 191         axis_ancestor_or_self >=>
 192         axis_preceding_sibling >=>
 193         axis_descendant_or_self_reverse
 194
 195 -- ** Axis @following@
 196 axis_following_first :: Alternative f => AxisAlt f k a
 197 axis_following_first (Cursor ps t fs :| cs) =
 198         case Seq.viewl fs of
 199          EmptyL -> empty
 200          l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
 201
 202 axis_following_sibling :: Axis k a
 203 axis_following_sibling = axis_repeat_without_self axis_following_first
 204
 205 axis_following :: Axis k a
 206 axis_following =
 207         axis_ancestor_or_self >=>
 208         axis_following_sibling >=>
 209         axis_descendant_or_self
 210
 211 -- ** Axis @parent@
 212 axis_parent :: Alternative f => AxisAlt f k a
 213 axis_parent (Cursor ps t fs :| cs) =
 214         case cs of
 215          Cursor ps' (TreeN k _) fs' : cs' ->
 216                 pure $ Cursor ps' (TreeN k $ (ps |> t) <> fs) fs' :| cs'
 217          _ -> empty
 218
 219 -- * Utilities
 220 nodesTree :: Tree k a -> Trees k a
 221 nodesTree Tree0{}       = mempty
 222 nodesTree (TreeN _k ts) = ts
 223
 224 listHead :: Alternative f => [a] -> f a
 225 listHead []    = empty
 226 listHead (a:_) = pure a