diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs index 66859f9ca..a4491f76e 100644 --- a/src/GF/Data/Zipper.hs +++ b/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 diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs index 63f4c4258..df65492c3 100644 --- a/src/GF/Shell/CommandL.hs +++ b/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) diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs index 99a7130e9..de2ff9a96 100644 --- a/src/GF/Shell/Commands.hs +++ b/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] diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs index 4aabe9f60..4271a0034 100644 --- a/src/GF/UseGrammar/Session.hs +++ b/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)