Data/TreeMap/Strict/Zipper.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# OPTIONS_GHC -fno-warn-tabs #-}
   4
   5 module Data.TreeMap.Strict.Zipper where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (Monad(..), (>=>))
   9 import Data.Bool (Bool)
  10 import Data.Data (Data)
  11 import Data.Eq (Eq)
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Maybe (Maybe(..), maybe)
  16 import Data.NonNull (nuncons)
  17 import Data.Ord (Ord(..))
  18 import Data.Tuple (fst)
  19 import Data.Typeable (Typeable)
  20 import Text.Show (Show(..))
  21 import qualified Data.List as List
  22 import qualified Data.Map.Strict as Map
  23
  24 import Data.TreeMap.Strict (TreeMap(..), Node(..), Path)
  25 import qualified Data.TreeMap.Strict as TreeMap
  26
  27 -- * Type 'Zipper'
  28 data Zipper k a
  29  =   Zipper
  30  {   zipper_path :: [Cursor k a]
  31  ,   zipper_curr :: TreeMap k a
  32  } deriving (Data, Eq, Show, Typeable)
  33
  34 zipper :: TreeMap k a -> Zipper k a
  35 zipper = Zipper []
  36
  37 root :: Ord k => Zipper k a -> TreeMap k a
  38 root = zipper_curr . List.last . axis_ancestor_or_self
  39
  40 zipath :: Zipper k a -> [k]
  41 zipath z =
  42         fst . cursor_self <$>
  43         List.reverse (zipper_path z)
  44
  45 current :: Zipper k a -> TreeMap k a
  46 current = zipper_curr
  47
  48 -- * Type 'Cursor'
  49 data Cursor k a
  50  =   Cursor
  51  {   cursor_precedings :: TreeMap k a
  52  ,   cursor_self       :: (k, Node k a)
  53  ,   cursor_followings :: TreeMap k a
  54  } deriving (Data, Eq, Show, Typeable)
  55
  56 -- * Axis
  57 type Axis k a = Zipper k a -> [Zipper k a]
  58 type AxisAlt f k a = Zipper k a -> f (Zipper k a)
  59
  60 -- | Collect all 'Zipper's along a given axis,
  61 --   including the first 'Zipper'.
  62 axis_collect :: (z -> Maybe z) -> z -> [z]
  63 axis_collect f z = z : maybe [] (axis_collect f) (f z)
  64
  65 -- | Collect all 'Zipper's along a given axis,
  66 --   excluding the first 'Zipper'.
  67 axis_collect_without_self :: (z -> Maybe z) -> z -> [z]
  68 axis_collect_without_self f z = maybe [] (axis_collect f) (f z)
  69
  70 -- ** Axis @self@
  71 axis_self :: Zipper k a -> Node k a
  72 axis_self z =
  73         case z of
  74          Zipper{ zipper_path=
  75                  Cursor{cursor_self=(_, nod)}
  76                  : _ } -> nod
  77          _ -> TreeMap.nodeEmpty
  78
  79 -- ** Axis @child@
  80 axis_child :: Ord k => Axis k a
  81 axis_child z =
  82         axis_child_first z >>=
  83         axis_collect axis_following_sibling_nearest
  84
  85 axis_child_lookup
  86  :: (Ord k, Alternative f)
  87  => k -> AxisAlt f k a
  88 axis_child_lookup k (Zipper path (TreeMap m)) =
  89         case Map.splitLookup k m of
  90          (_, Nothing, _) -> empty
  91          (ps, Just s, fs) ->
  92                 pure Zipper
  93                  { zipper_path = Cursor (TreeMap ps) (k, s) (TreeMap fs) : path
  94                  , zipper_curr = TreeMap.node_descendants s
  95                  }
  96
  97 axis_child_lookups :: (Ord k, Alternative f, Monad f) => Path k -> AxisAlt f k a
  98 axis_child_lookups p =
  99         case nuncons p of
 100          (k, Nothing) -> axis_child_lookup k
 101          (k, Just p') -> axis_child_lookup k >=> axis_child_lookups p'
 102
 103 axis_child_first :: Alternative f => AxisAlt f k a
 104 axis_child_first (Zipper path (TreeMap m)) =
 105         case Map.minViewWithKey m of
 106          Nothing -> empty
 107          Just ((k', s'), fs') ->
 108                 pure Zipper
 109                  { zipper_path = Cursor TreeMap.empty (k', s') (TreeMap fs') : path
 110                  , zipper_curr = TreeMap.node_descendants s'
 111                  }
 112
 113 axis_child_last :: Alternative f => AxisAlt f k a
 114 axis_child_last (Zipper path (TreeMap m)) =
 115         case Map.maxViewWithKey m of
 116          Nothing -> empty
 117          Just ((k', s'), ps') ->
 118                 pure Zipper
 119                  { zipper_path = Cursor (TreeMap ps') (k', s') TreeMap.empty : path
 120                  , zipper_curr = TreeMap.node_descendants s'
 121                  }
 122
 123 -- ** Axis @ancestor@
 124 axis_ancestor :: Ord k => Axis k a
 125 axis_ancestor = axis_collect_without_self zipper_parent
 126
 127 axis_ancestor_or_self :: Ord k => Axis k a
 128 axis_ancestor_or_self = axis_collect zipper_parent
 129
 130 -- ** Axis @descendant@
 131 axis_descendant_or_self :: Ord k => Axis k a
 132 axis_descendant_or_self =
 133         collect_child []
 134         where
 135                 collect_child acc z =
 136                         z : maybe acc
 137                          (collect_foll acc)
 138                          (axis_child_first z)
 139                 collect_foll  acc z =
 140                         collect_child
 141                          (maybe acc
 142                                  (collect_foll acc)
 143                                  (axis_following_sibling_nearest z)
 144                          ) z
 145
 146 axis_descendant_or_self_reverse :: Ord k => Axis k a
 147 axis_descendant_or_self_reverse z =
 148         z : List.concatMap
 149          axis_descendant_or_self_reverse
 150          (List.reverse $ axis_child z)
 151
 152 axis_descendant :: Ord k => Axis k a
 153 axis_descendant = List.tail . axis_descendant_or_self
 154
 155 -- ** Axis @preceding@
 156 axis_preceding_sibling_nearest :: (Ord k, Alternative f) => AxisAlt f k a
 157 axis_preceding_sibling_nearest (Zipper path _curr) =
 158         case path of
 159          [] -> empty
 160          Cursor (TreeMap ps) (k, s) (TreeMap fs):steps ->
 161                 case Map.maxViewWithKey ps of
 162                  Nothing -> empty
 163                  Just ((k', s'), ps') ->
 164                         pure Zipper
 165                          { zipper_path = Cursor (TreeMap ps')
 166                                                      (k', s')
 167                                                      (TreeMap $ Map.insert k s fs)
 168                                          : steps
 169                          , zipper_curr = TreeMap.node_descendants s'
 170                          }
 171
 172 axis_preceding_sibling :: Ord k => Axis k a
 173 axis_preceding_sibling = axis_collect_without_self axis_preceding_sibling_nearest
 174
 175 axis_preceding :: Ord k => Axis k a
 176 axis_preceding =
 177         axis_ancestor_or_self >=>
 178         axis_preceding_sibling >=>
 179         axis_descendant_or_self_reverse
 180
 181 -- ** Axis @following@
 182 axis_following_sibling_nearest :: (Ord k, Alternative f) => AxisAlt f k a
 183 axis_following_sibling_nearest (Zipper path _curr) =
 184         case path of
 185          [] -> empty
 186          Cursor (TreeMap ps) (k, s) (TreeMap fs):steps ->
 187                 case Map.minViewWithKey fs of
 188                  Nothing -> empty
 189                  Just ((k', s'), fs') ->
 190                         pure Zipper
 191                          { zipper_path = Cursor (TreeMap $ Map.insert k s ps)
 192                                                      (k', s')
 193                                                      (TreeMap fs')
 194                                          : steps
 195                          , zipper_curr = TreeMap.node_descendants s'
 196                          }
 197
 198 axis_following_sibling :: Ord k => Axis k a
 199 axis_following_sibling = axis_collect_without_self axis_following_sibling_nearest
 200
 201 axis_following :: Ord k => Axis k a
 202 axis_following =
 203         axis_ancestor_or_self >=>
 204         axis_following_sibling >=>
 205         axis_descendant_or_self
 206
 207 -- ** Axis @parent@
 208 zipper_parent :: (Ord k, Alternative f) => AxisAlt f k a
 209 zipper_parent (Zipper path curr) =
 210         case path of
 211          [] -> empty
 212          Cursor (TreeMap ps) (k, s) (TreeMap fs):steps ->
 213                 let nod = TreeMap.node (TreeMap.node_value s) curr in
 214                 pure Zipper
 215                  { zipper_path = steps
 216                  , zipper_curr = TreeMap $ Map.union ps $ Map.insert k nod fs
 217                  }
 218
 219 -- ** Filter
 220 axis_filter :: (Axis k a) -> (Zipper k a -> Bool) -> (Axis k a)
 221 axis_filter axis p z = List.filter p (axis z)
 222 infixl 5 `axis_filter`
 223
 224 axis_at :: Alternative f => (Axis k a) -> Int -> (AxisAlt f k a)
 225 axis_at axis n z = case List.drop n (axis z) of {[] -> empty; a:_ -> pure a}
 226 infixl 5 `axis_at`
 227
 228 zipper_null :: (Axis k a) -> Zipper k a -> Bool
 229 zipper_null axis = List.null . axis