Data/TreeSeq/Strict/Zipper.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# OPTIONS_GHC -fno-warn-tabs #-}
   4 module Data.TreeSeq.Strict.Zipper where
   5
   6 import Control.Applicative (Applicative(..), Alternative(..))
   7 import Control.Monad (Monad(..), (>=>))
   8 import Data.Bool
   9 import Data.Eq (Eq)
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.Int (Int)
  13 import Data.Maybe (Maybe(..), maybe)
  14 import Data.Monoid (Monoid(..))
  15 import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.Typeable (Typeable)
  18 import Prelude (undefined)
  19 import Text.Show (Show(..))
  20 import qualified Data.Sequence as Seq
  21 import qualified Data.List as List
  22
  23 import Data.TreeSeq.Strict (Trees, Tree(..))
  24
  25 safeHead :: Alternative f => [a] -> f a
  26 safeHead []    = empty
  27 safeHead (a:_) = pure a
  28
  29 nodesTree :: Tree k a -> Trees k a
  30 nodesTree Tree0{}       = mempty
  31 nodesTree (TreeN _k ts) = ts
  32
  33 keyTree :: Tree k a -> k
  34 keyTree (TreeN k _) = k
  35 keyTree Tree0{}     = undefined
  36
  37 -- * Type 'Zipper'
  38 data Zipper k a
  39  =   Zipper
  40  {   zipper_path :: [Zipper_Step k a]
  41  ,   zipper_curr :: Trees k a
  42  } deriving (Eq, Show, Typeable)
  43
  44 zipper :: Trees k a -> Zipper k a
  45 zipper = Zipper []
  46
  47 zipper_root :: Zipper k a -> Trees k a
  48 zipper_root = zipper_curr . List.last . zipper_ancestor_or_self
  49
  50 path_of_zipper :: Zipper k x -> [k]
  51 path_of_zipper z =
  52         keyTree . zipper_step_self <$>
  53         List.reverse (zipper_path z)
  54
  55 -- * Type 'Zipper_Step'
  56 data Zipper_Step k a
  57  =   Zipper_Step
  58  {   zipper_step_prec :: Trees k a
  59  ,   zipper_step_self :: Tree  k a
  60  ,   zipper_step_foll :: Trees k a
  61  } deriving (Eq, Show, Typeable)
  62
  63 -- * Axis
  64 -- | Collect all 'Zipper's along a given axis,
  65 --   including the first 'Zipper'.
  66 zipper_collect :: (z -> Maybe z) -> z -> [z]
  67 zipper_collect f z = z : maybe [] (zipper_collect f) (f z)
  68
  69 -- | Collect all 'Zipper's along a given axis,
  70 --   excluding the first 'Zipper'.
  71 zipper_collect_without_self :: (z -> Maybe z) -> z -> [z]
  72 zipper_collect_without_self f z = maybe [] (zipper_collect f) (f z)
  73
  74 -- ** Axis self
  75 zipper_self :: Zipper k a -> [Tree k a]
  76 zipper_self (Zipper (Zipper_Step _ t _ : _) _) = [t]
  77 zipper_self _ = []
  78
  79 -- ** Axis child
  80 zipper_child :: Zipper k a -> [Zipper k a]
  81 zipper_child z =
  82         zipper_child_first z >>=
  83         zipper_collect zipper_foll
  84
  85 zipper_child_lookup ::
  86  Alternative f =>
  87  (k -> Bool) -> Zipper k a -> f (Zipper k a)
  88 zipper_child_lookup fk z = safeHead $ zipper_childs_lookup fk z
  89
  90 zipper_childs_lookup ::
  91  (k -> Bool) -> Zipper k a -> [Zipper k a]
  92 zipper_childs_lookup fk (Zipper path ts) =
  93         (<$> Seq.findIndicesL (\case TreeN k _ -> fk k; Tree0{} -> False) ts) $ \i ->
  94                 let (ps, ps') = Seq.splitAt i ts in
  95                 case Seq.viewl ps' of
  96                  EmptyL -> undefined
  97                  t :< fs ->
  98                         Zipper
  99                          { zipper_path = Zipper_Step ps t fs : path
 100                          , zipper_curr = nodesTree t
 101                          }
 102
 103 zipper_child_first :: Alternative f => Zipper k a -> f (Zipper k a)
 104 zipper_child_first (Zipper path trees) =
 105         case Seq.viewl trees of
 106          EmptyL -> empty
 107          t :< ts -> pure $ Zipper
 108                  { zipper_path = Zipper_Step mempty t ts : path
 109                  , zipper_curr = nodesTree t
 110                  }
 111
 112 zipper_child_last :: Alternative f => Zipper k a -> f (Zipper k a)
 113 zipper_child_last (Zipper path trees) =
 114         case Seq.viewr trees of
 115          EmptyR -> empty
 116          ts :> t -> pure $ Zipper
 117                  { zipper_path = Zipper_Step ts t mempty : path
 118                  , zipper_curr = nodesTree t
 119                  }
 120
 121 -- ** Axis ancestor
 122 zipper_ancestor :: Zipper k a -> [Zipper k a]
 123 zipper_ancestor = zipper_collect_without_self zipper_parent
 124
 125 zipper_ancestor_or_self :: Zipper k a -> [Zipper k a]
 126 zipper_ancestor_or_self = zipper_collect zipper_parent
 127
 128 -- ** Axis descendant
 129 zipper_descendant_or_self :: Zipper k a -> [Zipper k a]
 130 zipper_descendant_or_self =
 131         collect_child []
 132         where
 133                 collect_child acc z =
 134                         z : maybe acc
 135                          (collect_foll acc)
 136                          (zipper_child_first z)
 137                 collect_foll  acc z =
 138                         collect_child
 139                          (maybe acc
 140                                  (collect_foll acc)
 141                                  (zipper_foll z)
 142                          ) z
 143
 144 zipper_descendant_or_self_reverse :: Zipper k a -> [Zipper k a]
 145 zipper_descendant_or_self_reverse z =
 146         z : List.concatMap
 147          zipper_descendant_or_self_reverse
 148          (List.reverse $ zipper_child z)
 149
 150 zipper_descendant :: Zipper k a -> [Zipper k a]
 151 zipper_descendant = List.tail . zipper_descendant_or_self
 152
 153 -- ** Axis preceding
 154 zipper_prec :: Alternative f => Zipper k a -> f (Zipper k a)
 155 zipper_prec (Zipper [] _curr) = empty
 156 zipper_prec (Zipper (Zipper_Step ps c fs : path) _curr) =
 157         case Seq.viewr ps of
 158          EmptyR -> empty
 159          ts :> t -> pure Zipper
 160                  { zipper_path = Zipper_Step ts t (c <| fs) : path
 161                  , zipper_curr = nodesTree t
 162                  }
 163
 164 zipper_preceding :: Zipper k a -> [Zipper k a]
 165 zipper_preceding =
 166         zipper_ancestor_or_self >=>
 167         zipper_preceding_sibling >=>
 168         zipper_descendant_or_self_reverse
 169
 170 zipper_preceding_sibling :: Zipper k a -> [Zipper k a]
 171 zipper_preceding_sibling = zipper_collect_without_self zipper_prec
 172
 173 -- ** Axis following
 174 zipper_foll :: Alternative f => Zipper k a -> f (Zipper k a)
 175 zipper_foll (Zipper [] _curr) = empty
 176 zipper_foll (Zipper (Zipper_Step ps c fs:path) _curr) =
 177         case Seq.viewl fs of
 178          EmptyL -> empty
 179          t :< ts -> pure $ Zipper
 180                  { zipper_path = Zipper_Step (ps |> c) t ts : path
 181                  , zipper_curr = nodesTree t
 182                  }
 183
 184 zipper_following :: Zipper k a -> [Zipper k a]
 185 zipper_following =
 186         zipper_ancestor_or_self >=>
 187         zipper_following_sibling >=>
 188         zipper_descendant_or_self
 189
 190 zipper_following_sibling :: Zipper k a -> [Zipper k a]
 191 zipper_following_sibling = zipper_collect_without_self zipper_foll
 192
 193 -- ** Axis parent
 194 zipper_parent :: Alternative f => Zipper k a -> f (Zipper k a)
 195 zipper_parent (Zipper [] _) = empty
 196 zipper_parent (Zipper (Zipper_Step ps c fs : path) curr) =
 197         pure Zipper
 198          { zipper_path = path
 199          , zipper_curr = (ps |> m) <> fs
 200          }
 201         where
 202         m = case c of
 203          TreeN k _ -> TreeN k curr
 204          Tree0{} -> undefined
 205
 206 -- ** Filter
 207 zipper_filter ::
 208  (Zipper k a -> [Zipper k a]) ->
 209  (Zipper k a -> Bool) ->
 210  (Zipper k a -> [Zipper k a])
 211 zipper_filter axis p z = List.filter p (axis z)
 212 infixl 5 `zipper_filter`
 213
 214 zipper_at ::
 215  Alternative f =>
 216  (Zipper k a -> [Zipper k a]) -> Int ->
 217  (Zipper k a -> f (Zipper k a))
 218 zipper_at axis n z =
 219         case List.drop n (axis z) of
 220          []  -> empty
 221          a:_ -> pure a
 222 infixl 5 `zipper_at`
 223
 224 zipper_null ::
 225  (Zipper k a -> [Zipper k a]) ->
 226  Zipper k a -> Bool
 227 zipper_null axis = List.null . axis