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