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 a = NonEmpty (Cursor a)
  28
  29 -- | Return a 'Zipper' starting at the given 'Tree'.
  30 zipper :: Tree a -> Zipper 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 a -> [Zipper 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 a -> Cursor 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 a -> Trees 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 a -> [a]
  52 zipath z =
  53         List.reverse $
  54         NonEmpty.toList z >>= \c ->
  55                 case cursor_self c of
  56                  Tree a _ -> [a]
  57
  58 -- | Return the 'Tree's selected by the given 'Axis' from the given 'Zipper'.
  59 select :: Axis a -> Zipper a -> [Tree a]
  60 select axis z = cursor_self . NonEmpty.head <$> runAxis axis z
  61
  62 -- | Return the filtered values selected by the given 'Axis' from the given 'Zipper'.
  63 filter :: Axis a -> (Zipper a -> Maybe b) -> Zipper a -> [b]
  64 filter axis f z = f `mapMaybe` runAxis axis z
  65
  66 -- ** Type 'Cursor'
  67 data Cursor a
  68  =   Cursor
  69  {   cursor_preceding_siblings :: Trees a
  70  ,   cursor_self               :: Tree  a
  71  ,   cursor_following_siblings :: Trees a
  72  } deriving (Eq, Show, Typeable)
  73
  74 -- | Return the current 'Cursor' of a 'Zipper'.
  75 cursor :: Zipper a -> Cursor a
  76 cursor = NonEmpty.head
  77
  78 -- | Set the current 'Cursor' of a 'Zipper'.
  79 setCursor :: Zipper a -> Cursor a -> Zipper a
  80 setCursor (_c :| cs) c = c :| cs
  81
  82 -- | Return the 'Tree' currently under the 'Cursor'.
  83 current :: Zipper a -> Tree a
  84 current (Cursor _ t _ :| _) = t
  85
  86 -- ** Type 'Axis'
  87 type Axis a = AxisAlt [] a
  88
  89 runAxis :: Axis a -> Zipper a -> [Zipper a]
  90 runAxis = runKleisli
  91
  92 -- ** Type 'AxisAlt'
  93 -- | Like 'Axis', but generalized with 'Alternative'.
  94 --
  95 -- Useful to return a 'Maybe' instead of a list.
  96 type AxisAlt f a = Kleisli f (Zipper a) (Zipper a)
  97
  98 runAxisAlt :: AxisAlt f a -> Zipper a -> f (Zipper a)
  99 runAxisAlt = runKleisli
 100
 101 -- ** Axis @repeat@
 102 -- | Collect all 'Zipper's along a given axis,
 103 --   including the first 'Zipper'.
 104 axis_repeat :: AxisAlt Maybe a -> Axis a
 105 axis_repeat f = Kleisli $ \z -> z : maybe [] (runAxis $ axis_repeat f) (runAxisAlt f z)
 106
 107 -- | Collect all 'Zipper's along a given axis,
 108 --   excluding the starting 'Zipper'.
 109 axis_repeat_without_self :: AxisAlt Maybe a -> Axis a
 110 axis_repeat_without_self f = Kleisli $ \z -> maybe [] (runAxis $ axis_repeat f) (runAxisAlt f z)
 111
 112 -- ** Axis @filter@
 113 axis_filter :: Axis a -> (Zipper a -> Bool) -> Axis a
 114 axis_filter axis f = Kleisli $ \z -> List.filter f (runAxis axis z)
 115 infixl 5 `axis_filter`
 116
 117 axis_filter_current :: Axis a -> (Tree a -> Bool) -> Axis a
 118 axis_filter_current axis f = Kleisli $ \z -> List.filter (f . current) (runAxis axis z)
 119 infixl 5 `axis_filter_current`
 120
 121 -- ** Axis @first@
 122 axis_first :: Axis a -> Axis a
 123 axis_first axis = Kleisli $ List.take 1 . runAxis axis
 124
 125 -- ** Axis @last@
 126 axis_last :: Axis a -> Axis a
 127 axis_last axis = Kleisli $ List.take 1 . List.reverse . runAxis axis
 128
 129 -- ** Axis @at@
 130 axis_at :: Alternative f => Axis a -> Int -> AxisAlt f a
 131 axis_at axis i = Kleisli $ \z ->
 132         case List.drop i $ runAxis axis z of
 133          []  -> empty
 134          a:_ -> pure a
 135 infixl 5 `axis_at`
 136
 137 -- ** Axis @self@
 138 axis_self :: Applicative f => AxisAlt f a
 139 axis_self = Kleisli pure
 140
 141 -- ** Axis @child@
 142 axis_child :: Axis a
 143 axis_child =
 144         axis_child_first >>>
 145         axis_repeat axis_following_sibling_nearest
 146
 147 axis_child_lookup_first :: Alternative f => (a -> Bool) -> AxisAlt f a
 148 axis_child_lookup_first fa = Kleisli $ listHead . runAxis (axis_child_lookup fa)
 149
 150 axis_child_lookup :: (a -> Bool) -> Axis a
 151 axis_child_lookup f = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
 152         let ns = subTrees t in
 153         (<$> Seq.findIndicesL (f . unTree) ns) $ \i ->
 154                 let (ps, ps') = Seq.splitAt i ns in
 155                 case Seq.viewl ps' of
 156                  EmptyL -> undefined
 157                  l :< ls -> Cursor ps l ls :| NonEmpty.toList z
 158
 159 axis_child_first :: Alternative f => AxisAlt f a
 160 axis_child_first = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
 161         case Seq.viewl $ subTrees t of
 162          EmptyL -> empty
 163          l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList z
 164
 165 axis_child_last :: Alternative f => AxisAlt f a
 166 axis_child_last = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
 167         case Seq.viewr $ subTrees t of
 168          EmptyR -> empty
 169          rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList z
 170
 171 -- ** Axis @ancestor@
 172 axis_ancestor :: Axis a
 173 axis_ancestor = axis_repeat_without_self axis_parent
 174
 175 axis_ancestor_or_self :: Axis a
 176 axis_ancestor_or_self = axis_repeat axis_parent
 177
 178 axis_root :: Alternative f => AxisAlt f a
 179 axis_root = Kleisli $ pure . List.last . runAxis axis_ancestor_or_self
 180
 181 -- ** Axis @descendant@
 182 axis_descendant_or_self :: Axis a
 183 axis_descendant_or_self =
 184         Kleisli $ collect_child []
 185         where
 186         collect_child acc z =
 187                 z : maybe acc
 188                  (collect_following_first acc)
 189                  (runAxisAlt axis_child_first z)
 190         collect_following_first acc z =
 191                 collect_child
 192                  (maybe acc
 193                          (collect_following_first acc)
 194                          (runAxisAlt axis_following_sibling_nearest z)
 195                  ) z
 196
 197 axis_descendant_or_self_reverse :: Axis a
 198 axis_descendant_or_self_reverse = Kleisli go
 199         where go z = z : List.concatMap go (List.reverse $ runAxis axis_child z)
 200
 201 axis_descendant :: Axis a
 202 axis_descendant = Kleisli $ List.tail . runAxis axis_descendant_or_self
 203
 204 -- ** Axis @preceding@
 205 axis_preceding_sibling :: Axis a
 206 axis_preceding_sibling = axis_repeat_without_self axis_preceding_sibling_nearest
 207
 208 axis_preceding_sibling_nearest :: Alternative f => AxisAlt f a
 209 axis_preceding_sibling_nearest = Kleisli $ \(Cursor ps t fs :| cs) ->
 210         case Seq.viewr ps of
 211          EmptyR  -> empty
 212          rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
 213
 214 axis_preceding_sibling_farthest :: Alternative f => AxisAlt f a
 215 axis_preceding_sibling_farthest = Kleisli $ \z@(Cursor ps t fs :| cs) ->
 216         case Seq.viewl (ps |> t) of
 217          EmptyL  -> pure z
 218          l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
 219
 220 axis_preceding :: Axis a
 221 axis_preceding =
 222         axis_ancestor_or_self >>>
 223         axis_preceding_sibling >>>
 224         axis_descendant_or_self_reverse
 225
 226 -- ** Axis @following@
 227 axis_following_sibling :: Axis a
 228 axis_following_sibling = axis_repeat_without_self axis_following_sibling_nearest
 229
 230 axis_following_sibling_nearest :: Alternative f => AxisAlt f a
 231 axis_following_sibling_nearest = Kleisli $ \(Cursor ps t fs :| cs) ->
 232         case Seq.viewl fs of
 233          EmptyL  -> empty
 234          l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
 235
 236 axis_following_sibling_farthest :: Alternative f => AxisAlt f a
 237 axis_following_sibling_farthest = Kleisli $ \z@(Cursor ps t fs :| cs) ->
 238         case Seq.viewr (t <| fs) of
 239          EmptyR  -> pure z
 240          rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
 241
 242 axis_following :: Axis a
 243 axis_following =
 244         axis_ancestor_or_self >>>
 245         axis_following_sibling >>>
 246         axis_descendant_or_self
 247
 248 -- ** Axis @parent@
 249 axis_parent :: Alternative f => AxisAlt f a
 250 axis_parent = Kleisli $ \(Cursor ps t fs :| cs) ->
 251         case cs of
 252          Cursor ps' (Tree a _) fs' : cs' ->
 253                 pure $ Cursor ps' (Tree a $ (ps |> t) <> fs) fs' :| cs'
 254          _ -> empty
 255
 256 -- * Utilities
 257 listHead :: Alternative f => [a] -> f a
 258 listHead []    = empty
 259 listHead (a:_) = pure a