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