Data/TreeSeq/Strict/Zipper.hs

   1 module Data.TreeSeq.Strict.Zipper where
   2
   3 import Control.Applicative (Applicative(..), Alternative(..))
   4 import Control.Monad (Monad(..), (>=>))
   5 import Data.Bool
   6 import Data.Eq (Eq)
   7 import Data.Function (($), (.))
   8 import Data.Functor ((<$>))
   9 import Data.Int (Int)
  10 import Data.List.NonEmpty (NonEmpty(..))
  11 import Data.Maybe (Maybe(..), maybe)
  12 import Data.Monoid (Monoid(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
  15 import Data.Typeable (Typeable)
  16 import Prelude (undefined)
  17 import Text.Show (Show(..))
  18 import qualified Data.List as List
  19 import qualified Data.List.NonEmpty as NonEmpty
  20 import qualified Data.Sequence as Seq
  21
  22 import Data.TreeSeq.Strict (Trees, Tree(..))
  23
  24 safeHead :: Alternative f => [a] -> f a
  25 safeHead []    = empty
  26 safeHead (a:_) = pure a
  27
  28 nodesTree :: Tree k a -> Trees k a
  29 nodesTree Tree0{}       = mempty
  30 nodesTree (TreeN _k ts) = ts
  31
  32 -- * Type 'Zipper'
  33 type Zipper k a = NonEmpty (Node k a)
  34
  35 zipper :: Tree k a -> Zipper k a
  36 zipper t = Node mempty t mempty :| []
  37
  38 zippers :: Trees k a -> [Zipper k a]
  39 zippers ts = ns >>= axis_collect axis_following_first
  40         where ns =
  41                 case Seq.viewl ts of
  42                  EmptyL -> empty
  43                  l :< ls -> pure $ Node mempty l ls :| []
  44
  45 zipper_root :: Zipper k a -> Tree k a
  46 zipper_root =
  47         zip_self .
  48         NonEmpty.head .
  49         List.last .
  50         axis_ancestor_or_self
  51
  52 path :: Zipper k x -> [k]
  53 path ns =
  54         List.reverse $
  55         NonEmpty.toList ns >>= \n ->
  56                 case zip_self n of
  57                  TreeN k _ -> [k]
  58                  Tree0{}   -> []
  59
  60 current :: Zipper k a -> Tree k a
  61 current (Node _ t _ :| _) = t
  62
  63 at :: Alternative f =>
  64       Axis k a -> Int ->
  65       (Zipper k a -> f (Zipper k a))
  66 at axis i n =
  67         case List.drop i (axis n) of
  68          []  -> empty
  69          a:_ -> pure a
  70 infixl 5 `at`
  71
  72 null :: Axis k a -> Zipper k a -> Bool
  73 null axis = List.null . axis
  74
  75 -- ** Type 'Node'
  76 data Node k a
  77  =   Node
  78  {   zip_prec :: Trees k a
  79  ,   zip_self :: Tree  k a
  80  ,   zip_foll :: Trees k a
  81  } deriving (Eq, Show, Typeable)
  82
  83 -- * Type 'Axis'
  84 type Axis k a = Zipper k a -> [Zipper k a]
  85
  86 -- ** Type 'AxisAlt'
  87 -- | Like 'Axis', but generalized with 'Alternative'.
  88 --
  89 -- Useful to return a 'Maybe' instead of a list.
  90 type AxisAlt f k a = Alternative f => Zipper k a -> f (Zipper k a)
  91
  92 -- | Collect all 'Zipper's along a given axis,
  93 --   including the first 'Zipper'.
  94 axis_collect :: (n -> Maybe n) -> n -> [n]
  95 axis_collect f n = n : maybe [] (axis_collect f) (f n)
  96
  97 -- | Collect all 'Zipper's along a given axis,
  98 --   excluding the first 'Zipper'.
  99 axis_collect_without_self :: (n -> Maybe n) -> n -> [n]
 100 axis_collect_without_self f n = maybe [] (axis_collect f) (f n)
 101
 102 -- ** Axis self
 103 axis_self :: Applicative f => Zipper k a -> f (Tree k a)
 104 axis_self (Node _ t _ :| _) = pure t
 105
 106 -- ** Axis child
 107 axis_child :: Axis k a
 108 axis_child n =
 109         axis_child_first n >>=
 110         axis_collect axis_following_first
 111
 112 axis_child_lookup_first :: (k -> Bool) -> AxisAlt f k a
 113 axis_child_lookup_first fk n = safeHead $ axis_child_lookup fk n
 114
 115 axis_child_lookup :: (k -> Bool) -> Axis k a
 116 axis_child_lookup fk ns@(Node _ps t _fs :| _) =
 117         (<$> Seq.findIndicesL flt cs) $ \i ->
 118                 let (ps, ps') = Seq.splitAt i cs in
 119                 case Seq.viewl ps' of
 120                  EmptyL -> undefined
 121                  l :< ls -> Node ps l ls :| NonEmpty.toList ns
 122         where
 123         cs = nodesTree t
 124         flt (TreeN k _) = fk k
 125         flt Tree0{}     = False
 126
 127 axis_child_first :: AxisAlt f k a
 128 axis_child_first ns@(Node _ps t _fs :| _) =
 129         case Seq.viewl $ nodesTree t of
 130          EmptyL -> empty
 131          l :< ls -> pure $ Node mempty l ls :| NonEmpty.toList ns
 132
 133 axis_child_last :: AxisAlt f k a
 134 axis_child_last ns@(Node _ps t _fs :| _) =
 135         case Seq.viewr $ nodesTree t of
 136          EmptyR -> empty
 137          rs :> r -> pure $ Node rs r mempty :| NonEmpty.toList ns
 138
 139 -- ** Axis ancestor
 140 axis_ancestor :: Axis k a
 141 axis_ancestor = axis_collect_without_self axis_parent
 142
 143 axis_ancestor_or_self :: Axis k a
 144 axis_ancestor_or_self = axis_collect axis_parent
 145
 146 -- ** Axis descendant
 147 axis_descendant_or_self :: Axis k a
 148 axis_descendant_or_self =
 149         collect_child []
 150         where
 151         collect_child acc n =
 152                 n : maybe acc
 153                  (collect_following_first acc)
 154                  (axis_child_first n)
 155         collect_following_first acc n =
 156                 collect_child
 157                  (maybe acc
 158                          (collect_following_first acc)
 159                          (axis_following_first n)
 160                  ) n
 161
 162 axis_descendant_or_self_reverse :: Axis k a
 163 axis_descendant_or_self_reverse n =
 164         n :
 165         List.concatMap
 166          axis_descendant_or_self_reverse
 167          (List.reverse $ axis_child n)
 168
 169 axis_descendant :: Axis k a
 170 axis_descendant = List.tail . axis_descendant_or_self
 171
 172 -- ** Axis preceding
 173 axis_preceding_first :: AxisAlt f k a
 174 axis_preceding_first (Node ps t fs :| ns) =
 175         case Seq.viewr ps of
 176          EmptyR -> empty
 177          rs :> r -> pure $ Node rs r (t <| fs) :| ns
 178
 179 axis_preceding_sibling :: Axis k a
 180 axis_preceding_sibling = axis_collect_without_self axis_preceding_first
 181
 182 axis_preceding :: Axis k a
 183 axis_preceding =
 184         axis_ancestor_or_self >=>
 185         axis_preceding_sibling >=>
 186         axis_descendant_or_self_reverse
 187
 188 -- ** Axis following
 189 axis_following_first :: AxisAlt f k a
 190 axis_following_first (Node ps t fs :| ns) =
 191         case Seq.viewl fs of
 192          EmptyL -> empty
 193          l :< ls -> pure $ Node (ps |> t) l ls :| ns
 194
 195 axis_following_sibling :: Axis k a
 196 axis_following_sibling = axis_collect_without_self axis_following_first
 197
 198 axis_following :: Axis k a
 199 axis_following =
 200         axis_ancestor_or_self >=>
 201         axis_following_sibling >=>
 202         axis_descendant_or_self
 203
 204 -- ** Axis parent
 205 axis_parent :: AxisAlt f k a
 206 axis_parent (Node ps t fs :| ns) =
 207         case ns of
 208          Node ps' (TreeN k _) fs' : ns' ->
 209                 pure $ Node ps' (TreeN k $ (ps |> t) <> fs) fs' :| ns'
 210          _ -> empty
 211
 212 -- ** Filter
 213 axis_filter :: Axis k a -> (Zipper k a -> Bool) -> Axis k a
 214 axis_filter axis p n = List.filter p (axis n)
 215 infixl 5 `axis_filter`