undo k and keep position in editor

src/GF/Data/Zipper.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:11 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.8 $
+-- > CVS $Date: 2005/06/11 20:27:05 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.9 $
 --
 -- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
 -----------------------------------------------------------------------------
@@ -35,6 +35,8 @@ module GF.Data.Zipper (-- * types
 	       goRoot,
 	       goLast,
 	       goPosition,
+	       getPosition,
+	       keepPosition,
 	       -- * added some utilities
 	       traverseCollect,
 	       scanTree,
@@ -160,6 +162,18 @@ goPosition p = go p . goRoot where
   go []     s = return s
   go (p:ps) s = goDown s >>= apply p goRight >>= go ps
 
+getPosition :: Loc a -> [Int]
+getPosition = reverse . getp where 
+  getp (Loc (t,p)) = case p of
+    Top -> []
+    Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p'))
+
+keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a))
+keepPosition f s = do
+  let p = getPosition s
+  s' <- f s
+  goPosition p s'
+
 apply :: Monad m => Int -> (a -> m a) -> a -> m a
 apply n f a = case n of
   0 -> return a

src/GF/Shell/CommandL.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/10 15:59:58 $ 
+-- > CVS $Date: 2005/06/11 20:27:05 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
+-- > CVS $Revision: 1.19 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -119,7 +119,8 @@ pCommandMsg s = (m,pCommandWords $ words c) where
     "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm
     "f" : "structured" : _ -> CAddOption showStruct --- hmmm
     "f" : s : _   -> CAddOption (filterString s)
-    "u" : _       -> CUndo
+    "u" : i : _   -> CUndo (readIntArg i)
+    "u" : _       -> CUndo 1
     "d" : _       -> CDelete
     "ac" : _      -> CAddClip
     "pc": i : _   -> CRemoveClip (readIntArg i)

src/GF/Shell/Commands.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/10 15:59:58 $ 
+-- > CVS $Date: 2005/06/11 20:27:05 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.38 $
+-- > CVS $Revision: 1.39 $
 --
 -- temporary hacks for GF 2.0
 --
@@ -92,7 +92,7 @@ data Command =
  | CDelete
  | CAddClip
  | CRemoveClip Int
- | CUndo
+ | CUndo Int
  | CView
  | CMenu
  | CQuit
@@ -241,11 +241,11 @@ execECommand env c = case c of
                           t  <- string2ref gr s
                           s' <- refineWithAtom der cgr t x
                           uniqueRefinements cgr s'
-  CWrapWithFun (f,i) -> action2commandNext $ wrapWithFun cgr (qualif f, i)
-  CChangeHead f      -> action2commandNext $ changeFunHead cgr (qualif f)
-  CPeelHead (f,i)    -> action2commandNext $ peelFunHead cgr (qualif f,i)
+  CWrapWithFun (f,i) -> action2commandKeep $ wrapWithFun cgr (qualif f, i)
+  CChangeHead f      -> action2commandKeep $ changeFunHead cgr (qualif f)
+  CPeelHead (f,i)    -> action2commandKeep $ peelFunHead cgr (qualif f,i)
 
-  CAlphaConvert s    -> action2commandNext $ \x ->
+  CAlphaConvert s    -> action2commandKeep $ \x ->
                           string2varPair s >>= \xy -> alphaConvert cgr xy x
 
   CRefineWithTree s  -> action2commandNext $ \x -> 
@@ -283,10 +283,10 @@ execECommand env c = case c of
 
   CAddOption o       -> changeStOptions (addOption o)
   CRemoveOption o    -> changeStOptions (removeOption o)
-  CDelete            -> action2commandNext $ deleteSubTree cgr
+  CDelete            -> action2commandKeep $ deleteSubTree cgr
   CAddClip           -> \s -> (addtoClip (actTree (stateSState s))) s
   CRemoveClip n      -> \s -> (removeClip n) s
-  CUndo              -> undoCommand
+  CUndo n            -> undoCommand n
   CMenu              -> \s -> changeMsg (menuState env s) s
   CView              -> changeView
   CHelp h            -> changeMsg [h env]

src/GF/UseGrammar/Session.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/10 15:59:59 $ 
+-- > CVS $Date: 2005/06/11 20:27:05 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.10 $
+-- > CVS $Revision: 1.11 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -21,6 +21,7 @@ import GF.UseGrammar.Editing
 import GF.Compile.ShellState ---- grammar
 
 import GF.Data.Operations
+import GF.Data.Zipper (keepPosition) ---
 
 -- First version 8/2001. Adapted to GFC with modules 19/6/2003.
 -- Nothing had to be changed, which is a sign of good modularity.
@@ -118,9 +119,15 @@ action2command act state = case act (stateSState state) of
 action2commandNext :: Action -> ECommand -- move to next meta after execution
 action2commandNext act = action2command (\s -> act s >>= goNextMetaIfCan)
 
-undoCommand :: ECommand
-undoCommand ss@[_] = changeMsg ["cannot go back"] ss
-undoCommand (_:ss) = changeMsg ["successful undo"] ss
+action2commandKeep :: Action -> ECommand -- keep old position after execution
+action2commandKeep act = action2command (\s -> keepPosition act s)
+
+undoCommand :: Int -> ECommand
+undoCommand n ss =
+  let k = length ss in
+  if k < n 
+     then changeMsg ["cannot go all the way back"] []
+     else changeMsg ["successful undo"] (drop n ss)
 
 selectCand :: CGrammar -> Int -> ECommand
 selectCand gr i state = err (\m -> changeMsg [m] state) id $ do
@@ -149,7 +156,7 @@ replaceByTrees gr trees = case trees of
 
 replaceByEditCommand :: StateGrammar -> String -> ECommand
 replaceByEditCommand gr co = 
-  action2command $
+  action2commandKeep $
   maybe return ($ gr) $
   lookupCustom customEditCommand (strCI co)