lib/Hcompta/Lib/TreeMap/Zipper.hs

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