Ticket #90: cbind.diff

System/Console/Haskeline/Command/Completion.hs

@@ -105 +105 @@
         ]
   where
     oneLine = clearMessage >> effect (PrintLines [w]) >> pageCompletions ws
-    clearMessage = effect $ LineChange $ const ([],[])
+    clearMessage = effect $ LineChange Insert $ const ([],[])
 
 printPage :: MonadReader Layout m => [String] -> CmdM m ()
 printPage ls = do

System/Console/Haskeline/Command.hs

@@ -34 +34 @@
 import System.Console.Haskeline.LineState
 import System.Console.Haskeline.Key
 
-data Effect = LineChange (Prefix -> LineChars)
+data Effect = LineChange Mode (Prefix -> LineChars)
               | PrintLines [String]
               | ClearScreen
               | RingBell
 
 lineChange :: LineState s => s -> Effect
-lineChange = LineChange . flip lineChars
+lineChange s = LineChange (mode s) $ flip lineChars s
 
 data KeyMap a = KeyMap {lookupKM :: Key -> Maybe (KeyConsumed a)}
 

System/Console/Haskeline/LineState.hs

@@ -43 +43 @@
                     beforeChar,
                     afterChar,
                     overChar,
+                    Mode(..),
                     -- ** CommandMode
                     CommandMode(..),
                     deleteChar,
@@ -133 +134 @@
                     -> [Grapheme] -- ^ The text to the left of the cursor
                                   -- (including the prefix).
     afterCursor :: s -> [Grapheme] -- ^ The text under and to the right of the cursor.
+    mode ::Â s -> Mode
+
+data Mode = Command | Insert | Arg
+  deriving (Show)
 
 type Prefix = [Grapheme]
 
@@ -172 +177 @@
 instance LineState InsertMode where
     beforeCursor prefix (IMode xs _) = prefix ++ reverse xs
     afterCursor (IMode _ ys) = ys
+    mode _ = Insert
 
 instance Result InsertMode where
     toResult (IMode xs ys) = graphemesToString $ reverse xs ++ ys
@@ -251 +257 @@
     beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs
     afterCursor CEmpty = []
     afterCursor (CMode _ c ys) = c:ys
+    mode _ = Command
 
 instance Result CommandMode where
     toResult CEmpty = ""
@@ -328 +335 @@
     beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") "
                              in beforeCursor pre (argState am) 
     afterCursor = afterCursor . argState
+    mode _ = Arg
 
 instance Result s => Result (ArgMode s) where
     toResult = toResult . argState

System/Console/Haskeline/Prefs.hs

@@ -6 +6 @@
                         BellStyle(..),
                         EditMode(..),
                         HistoryDuplicates(..),
-                        lookupKeyBinding
+                        lookupKeyBinding,
+                        lookupKeyViCBinding
                         ) where
 
 import Data.Char(isSpace,toLower)
@@ -46 +47 @@
                         -- will ring the bell and only display them if the user
                         -- presses @TAB@ again.
                      customBindings :: Map.Map Key [Key],
+                     
+                     customViCBindings :: Map.Map Key [Key],
                         -- (termName, keysequence, key)
                      customKeySequences :: [(Maybe String, String,Key)]
                      }
@@ -76 +79 @@
                       listCompletionsImmediately = True,
                       historyDuplicates = AlwaysAdd,
                       customBindings = Map.empty,
+                      customViCBindings = Map.empty,
                       customKeySequences = []
                     }
 
@@ -98 +102 @@
           ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x})
           ,("historyduplicates", mkSettor $ \x p -> p {historyDuplicates = x})
           ,("bind", addCustomBinding)
+          ,("cbind", addCustomViCBinding)
           ,("keyseq", addCustomKeySequence)
           ]
 
@@ -106 +111 @@
     Just (k:ks) -> p {customBindings = Map.insert k ks (customBindings p)}
     _ -> p
 
+addCustomViCBinding :: String -> Prefs -> Prefs
+addCustomViCBinding str p = case mapM parseKey (words str) of
+    Just (k:ks) -> p {customViCBindings = Map.insert k ks (customViCBindings p)}
+    _ -> p
+
 addCustomKeySequence :: String -> Prefs -> Prefs
 addCustomKeySequence str = maybe id addKS maybeParse
     where
@@ -123 +133 @@
 lookupKeyBinding :: Key -> Prefs -> [Key]
 lookupKeyBinding k = Map.findWithDefault [k] k . customBindings
 
+lookupKeyViCBinding :: Key -> Prefs -> [Key]
+lookupKeyViCBinding k = Map.findWithDefault [k] k . customViCBindings
+
 -- | Read 'Prefs' from a given file.  If there is an error reading the file,
 -- the 'defaultPrefs' will be returned.
 readPrefs :: FilePath -> IO Prefs

System/Console/Haskeline/RunCommand.hs

@@ -23 +23 @@
 runCommandLoop' liftE tops prefix initState cmds getEvent = do
     let s = lineChars prefix initState
     drawLine s
-    readMoreKeys s (fmap (liftM (\x -> (x,[])) . ($ initState)) cmds)
+    readMoreKeys (mode initState) s (fmap (liftM (\x -> (x,[])) . ($ initState)) cmds)
   where
-    readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> n a
-    readMoreKeys s next = do
+    readMoreKeys :: Mode -> LineChars -> KeyMap (CmdM m (a,[Key])) -> n a
+    readMoreKeys m s next@(KeyMap cmd) = do
         event <- handle (\(e::SomeException) -> moveToNextLine s
                                     >> throwIO e) getEvent
+        -- liftIO $ print m
         case event of
                     ErrorEvent e -> moveToNextLine s >> throwIO e
                     WindowResize -> do
                         drawReposition liftE tops s
-                        readMoreKeys s next
+                        readMoreKeys m s next
                     KeyInput ks -> do
-                        bound_ks <- mapM (asks . lookupKeyBinding) ks
-                        loopCmd s $ applyKeysToMap (concat bound_ks) next
+                        bound_ks <- mapM (asks . lookupKey m) ks
+                        loopCmd m s $ applyKeysToMap (concat bound_ks) next
+    -- lookupKey cmd k p = case editMode p of
+    --                       Emacs -> lookupKeyBinding k p
+    --                       Vi    -> lookupViBinding cmd k p
+    lookupKey cmd k p = case cmd of 
+                            Command -> lookupKeyViCBinding k p
+                            Insert  -> lookupKeyBinding k p
+                            Arg     -> lookupKeyViCBinding k p
 
-    loopCmd :: LineChars -> CmdM m (a,[Key]) -> n a
-    loopCmd s (GetKey next) = readMoreKeys s next
+
+    loopCmd :: Mode -> LineChars -> CmdM m (a,[Key]) -> n a
+    loopCmd m s (GetKey next) = readMoreKeys m s next
     -- If there are multiple consecutive LineChanges, only render the diff
     -- to the last one, and skip the rest. This greatly improves speed when
     -- a large amount of text is pasted in at once.
-    loopCmd s (DoEffect (LineChange _)
-                e@(DoEffect (LineChange _) _)) = loopCmd s e
-    loopCmd s (DoEffect e next) = do
+    loopCmd m s (DoEffect (LineChange m' _)
+                e@(DoEffect (LineChange _ _) _)) = loopCmd m' s e
+    loopCmd m s (DoEffect e@(LineChange m' _) next) = do
+                                    t <- drawEffect prefix s e
+                                    loopCmd m' t next
+    loopCmd m s (DoEffect e next) = do
                                     t <- drawEffect prefix s e
-                                    loopCmd t next
-    loopCmd s (CmdM next) = liftE next >>= loopCmd s
-    loopCmd s (Result (x,ks)) = do
+                                    loopCmd m t next
+    loopCmd m s (CmdM next) = liftE next >>= loopCmd m s
+    loopCmd m s (Result (x,ks)) = do
                                     liftIO (saveUnusedKeys tops ks)
                                     moveToNextLine s
                                     return x
@@ -65 +77 @@
 
 drawEffect :: (Term m, MonadReader Prefs m)
     => Prefix -> LineChars -> Effect -> m LineChars
-drawEffect prefix s (LineChange ch) = do
+drawEffect prefix s (LineChange m ch) = do
     let t = ch prefix
     drawLineDiff s t
     return t
@@ -81 +93 @@
 drawEffect _ s RingBell = actBell >> return s
 
 actBell :: (Term m, MonadReader Prefs m) => m ()
-actBell = do
+actBell = do 
     style <- asks bellStyle
     case style of
         NoBell -> return ()

System/Console/Haskeline/Vi.hs

@@ -9 +9 @@
 import System.Console.Haskeline.Command.Undo
 import System.Console.Haskeline.LineState
 import System.Console.Haskeline.InputT
-
+import qualified System.Console.Haskeline.LineState as L 
 import Data.Char
 import Control.Monad(liftM)
 
@@ -409 +409 @@
     beforeCursor prefix se = beforeCursor (prefix ++ stringToGraphemes [searchChar se])
                                 (entryState se)
     afterCursor = afterCursor . entryState
+    mode s = L.Command
 
 viEnterSearch :: Monad m => Char -> Direction
                     -> Command (ViT m) CommandMode CommandMode