1#if __GLASGOW_HASKELL__ < 802 2{-# OPTIONS_GHC -Wno-redundant-constraints #-} 3#endif 4module System.Console.Haskeline.Emacs where 5 6import System.Console.Haskeline.Command 7import System.Console.Haskeline.Monads 8import System.Console.Haskeline.Key 9import System.Console.Haskeline.Command.Completion 10import System.Console.Haskeline.Command.History 11import System.Console.Haskeline.Command.Undo 12import System.Console.Haskeline.Command.KillRing 13import System.Console.Haskeline.LineState 14import System.Console.Haskeline.InputT 15 16import Control.Monad.Catch (MonadMask) 17import Data.Char 18 19type InputCmd s t = forall m . (MonadIO m, MonadMask m) => Command (InputCmdT m) s t 20type InputKeyCmd s t = forall m . (MonadIO m, MonadMask m) => KeyCommand (InputCmdT m) s t 21 22emacsCommands :: InputKeyCmd InsertMode (Maybe String) 23emacsCommands = choiceCmd [ 24 choiceCmd [simpleActions, controlActions] >+> 25 keyCommand emacsCommands 26 , enders] 27 28enders :: InputKeyCmd InsertMode (Maybe String) 29enders = choiceCmd [simpleChar '\n' +> finish, eotKey +> deleteCharOrEOF] 30 where 31 eotKey = ctrlChar 'd' 32 deleteCharOrEOF s 33 | s == emptyIM = return Nothing 34 | otherwise = change deleteNext s >>= justDelete 35 justDelete = keyChoiceCmd [eotKey +> change deleteNext >|> justDelete 36 , emacsCommands] 37 38 39simpleActions, controlActions :: InputKeyCmd InsertMode InsertMode 40simpleActions = choiceCmd 41 [ simpleKey LeftKey +> change goLeft 42 , simpleKey RightKey +> change goRight 43 , simpleKey Backspace +> change deletePrev 44 , simpleKey Delete +> change deleteNext 45 , changeFromChar insertChar 46 , completionCmd (simpleChar '\t') 47 , simpleKey UpKey +> historyBack 48 , simpleKey DownKey +> historyForward 49 , simpleKey SearchReverse +> searchForPrefix Reverse 50 , simpleKey SearchForward +> searchForPrefix Forward 51 , searchHistory 52 ] 53 54controlActions = choiceCmd 55 [ ctrlChar 'a' +> change moveToStart 56 , ctrlChar 'e' +> change moveToEnd 57 , ctrlChar 'b' +> change goLeft 58 , ctrlChar 'f' +> change goRight 59 , ctrlChar 'l' +> clearScreenCmd 60 , metaChar 'f' +> change wordRight 61 , metaChar 'b' +> change wordLeft 62 , ctrlKey (simpleKey LeftKey) +> change wordLeft 63 , ctrlKey (simpleKey RightKey) +> change wordRight 64 , metaChar 'c' +> change (modifyWord capitalize) 65 , metaChar 'l' +> change (modifyWord (mapBaseChars toLower)) 66 , metaChar 'u' +> change (modifyWord (mapBaseChars toUpper)) 67 , ctrlChar '_' +> commandUndo 68 , ctrlChar 'x' +> try (ctrlChar 'u' +> commandUndo) 69 , ctrlChar 't' +> change transposeChars 70 , ctrlChar 'p' +> historyBack 71 , ctrlChar 'n' +> historyForward 72 , metaChar '<' +> historyStart 73 , metaChar '>' +> historyEnd 74 , simpleKey Home +> change moveToStart 75 , simpleKey End +> change moveToEnd 76 , choiceCmd 77 [ ctrlChar 'w' +> killFromHelper (SimpleMove bigWordLeft) 78 , metaKey (simpleKey Backspace) +> killFromHelper (SimpleMove wordLeft) 79 , metaChar 'd' +> killFromHelper (SimpleMove wordRight) 80 , ctrlChar 'k' +> killFromHelper (SimpleMove moveToEnd) 81 , simpleKey KillLine +> killFromHelper (SimpleMove moveToStart) 82 ] 83 , ctrlChar 'y' +> rotatePaste 84 ] 85 86rotatePaste :: InputCmd InsertMode InsertMode 87rotatePaste im = get >>= loop 88 where 89 loop kr = case peek kr of 90 Nothing -> return im 91 Just s -> setState (insertGraphemes s im) 92 >>= try (metaChar 'y' +> \_ -> loop (rotate kr)) 93 94 95wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode 96wordRight = goRightUntil (atStart (not . isAlphaNum)) 97wordLeft = goLeftUntil (atStart isAlphaNum) 98bigWordLeft = goLeftUntil (atStart (not . isSpace)) 99 100modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode 101modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2 102 where 103 IMode xs ys = skipRight (not . isAlphaNum) im 104 (ys1,ys2) = span (isAlphaNum . baseChar) ys 105 106capitalize :: [Grapheme] -> [Grapheme] 107capitalize [] = [] 108capitalize (c:cs) = modifyBaseChar toUpper c : cs 109