Data/TreeSeq/Strict/Zipper.hs

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