#if __GLASGOW_HASKELL__ < 802
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
module System.Console.Haskeline.Emacs where

import System.Console.Haskeline.Command
import System.Console.Haskeline.Monads
import System.Console.Haskeline.Key
import System.Console.Haskeline.Command.Completion
import System.Console.Haskeline.Command.History
import System.Console.Haskeline.Command.Undo
import System.Console.Haskeline.Command.KillRing
import System.Console.Haskeline.LineState
import System.Console.Haskeline.InputT

import Control.Monad.Catch (MonadMask)
import Data.Char

type InputCmd s t = forall m . (MonadIO m, MonadMask m) => Command (InputCmdT m) s t
type InputKeyCmd s t = forall m . (MonadIO m, MonadMask m) => KeyCommand (InputCmdT m) s t

emacsCommands :: InputKeyCmd InsertMode (Maybe String)
emacsCommands :: InputKeyCmd InsertMode (Maybe String)
emacsCommands = forall a. [KeyMap a] -> KeyMap a
choiceCmd [
                    forall a. [KeyMap a] -> KeyMap a
choiceCmd [InputKeyCmd InsertMode InsertMode
simpleActions, InputKeyCmd InsertMode InsertMode
controlActions] forall (m :: * -> *) s t u.
Monad m =>
KeyCommand m s t -> Command m t u -> KeyCommand m s u
>+> 
                        forall (m :: * -> *) s t. KeyCommand m s t -> Command m s t
keyCommand InputKeyCmd InsertMode (Maybe String)
emacsCommands
                    , InputKeyCmd InsertMode (Maybe String)
enders]

enders :: InputKeyCmd InsertMode (Maybe String)
enders :: InputKeyCmd InsertMode (Maybe String)
enders = forall a. [KeyMap a] -> KeyMap a
choiceCmd [Char -> Key
simpleChar Char
'\n' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s.
(Monad m, Result s) =>
Command m s (Maybe String)
finish, Key
eotKey forall a. Key -> a -> KeyMap a
+> Command (InputCmdT m) InsertMode (Maybe String)
deleteCharOrEOF]
    where
        eotKey :: Key
eotKey = Char -> Key
ctrlChar Char
'd'
        deleteCharOrEOF :: Command (InputCmdT m) InsertMode (Maybe String)
deleteCharOrEOF InsertMode
s
            | InsertMode
s forall a. Eq a => a -> a -> Bool
== InsertMode
emptyIM  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | Bool
otherwise = forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
deleteNext InsertMode
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Command (InputCmdT m) InsertMode (Maybe String)
justDelete
        justDelete :: Command (InputCmdT m) InsertMode (Maybe String)
justDelete = forall (m :: * -> *) s t. [KeyCommand m s t] -> Command m s t
keyChoiceCmd [Key
eotKey forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
deleteNext forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> Command (InputCmdT m) InsertMode (Maybe String)
justDelete
                            , InputKeyCmd InsertMode (Maybe String)
emacsCommands]


simpleActions, controlActions :: InputKeyCmd InsertMode InsertMode
simpleActions :: InputKeyCmd InsertMode InsertMode
simpleActions = forall a. [KeyMap a] -> KeyMap a
choiceCmd 
            [ BaseKey -> Key
simpleKey BaseKey
LeftKey forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
goLeft
            , BaseKey -> Key
simpleKey BaseKey
RightKey forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
goRight
            , BaseKey -> Key
simpleKey BaseKey
Backspace forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
deletePrev
            , BaseKey -> Key
simpleKey BaseKey
Delete forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
deleteNext 
            , forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(Char -> s -> t) -> KeyCommand m s t
changeFromChar Char -> InsertMode -> InsertMode
insertChar
            , forall (m :: * -> *).
(MonadState Undo m, CommandMonad m) =>
Key -> KeyCommand m InsertMode InsertMode
completionCmd (Char -> Key
simpleChar Char
'\t')
            , BaseKey -> Key
simpleKey BaseKey
UpKey forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState HistLog m) =>
Command m s s
historyBack
            , BaseKey -> Key
simpleKey BaseKey
DownKey forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState HistLog m) =>
Command m s s
historyForward
            , BaseKey -> Key
simpleKey BaseKey
SearchReverse forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *).
MonadState HistLog m =>
Direction -> Command m InsertMode InsertMode
searchForPrefix Direction
Reverse
            , BaseKey -> Key
simpleKey BaseKey
SearchForward forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *).
MonadState HistLog m =>
Direction -> Command m InsertMode InsertMode
searchForPrefix Direction
Forward
            , forall (m :: * -> *).
MonadState HistLog m =>
KeyCommand m InsertMode InsertMode
searchHistory
            ] 
            
controlActions :: InputKeyCmd InsertMode InsertMode
controlActions = forall a. [KeyMap a] -> KeyMap a
choiceCmd
            [ Char -> Key
ctrlChar Char
'a' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
moveToStart 
            , Char -> Key
ctrlChar Char
'e' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
moveToEnd
            , Char -> Key
ctrlChar Char
'b' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
goLeft
            , Char -> Key
ctrlChar Char
'f' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
goRight
            , Char -> Key
ctrlChar Char
'l' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s. Command m s s
clearScreenCmd
            , Char -> Key
metaChar Char
'f' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
wordRight
            , Char -> Key
metaChar Char
'b' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
wordLeft
            , Key -> Key
ctrlKey (BaseKey -> Key
simpleKey BaseKey
LeftKey) forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
wordLeft
            , Key -> Key
ctrlKey (BaseKey -> Key
simpleKey BaseKey
RightKey) forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
wordRight
            , Char -> Key
metaChar Char
'c' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change (([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
modifyWord [Grapheme] -> [Grapheme]
capitalize)
            , Char -> Key
metaChar Char
'l' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change (([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
modifyWord ((Char -> Char) -> [Grapheme] -> [Grapheme]
mapBaseChars Char -> Char
toLower))
            , Char -> Key
metaChar Char
'u' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change (([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
modifyWord ((Char -> Char) -> [Grapheme] -> [Grapheme]
mapBaseChars Char -> Char
toUpper))
            , Char -> Key
ctrlChar Char
'_' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s.
(MonadState Undo m, Save s) =>
Command m s s
commandUndo
            , Char -> Key
ctrlChar Char
'x' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s.
Monad m =>
KeyCommand m s s -> Command m s s
try (Char -> Key
ctrlChar Char
'u' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s.
(MonadState Undo m, Save s) =>
Command m s s
commandUndo)
            , Char -> Key
ctrlChar Char
't' forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change InsertMode -> InsertMode
transposeChars
            , Char -> Key
ctrlChar Char
'p' forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState HistLog m) =>
Command m s s
historyBack
            , Char -> Key
ctrlChar Char
'n' forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState HistLog m) =>
Command m s s
historyForward
            , Char -> Key
metaChar Char
'<' forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState HistLog m) =>
Command m s s
historyStart
            , Char -> Key
metaChar Char
'>' forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState HistLog m) =>
Command m s s
historyEnd
            , BaseKey -> Key
simpleKey BaseKey
Home forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
moveToStart
            , BaseKey -> Key
simpleKey BaseKey
End forall a. Key -> a -> KeyMap a
+> forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change forall s. Move s => s -> s
moveToEnd
            , forall a. [KeyMap a] -> KeyMap a
choiceCmd
                [ Char -> Key
ctrlChar Char
'w' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s t.
(MonadState KillRing m, MonadState Undo m, Save s, Save t) =>
KillHelper -> Command m s t
killFromHelper ((InsertMode -> InsertMode) -> KillHelper
SimpleMove InsertMode -> InsertMode
bigWordLeft)
                , Key -> Key
metaKey (BaseKey -> Key
simpleKey BaseKey
Backspace) forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s t.
(MonadState KillRing m, MonadState Undo m, Save s, Save t) =>
KillHelper -> Command m s t
killFromHelper ((InsertMode -> InsertMode) -> KillHelper
SimpleMove InsertMode -> InsertMode
wordLeft)
                , Char -> Key
metaChar Char
'd' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s t.
(MonadState KillRing m, MonadState Undo m, Save s, Save t) =>
KillHelper -> Command m s t
killFromHelper ((InsertMode -> InsertMode) -> KillHelper
SimpleMove InsertMode -> InsertMode
wordRight)
                , Char -> Key
ctrlChar Char
'k' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s t.
(MonadState KillRing m, MonadState Undo m, Save s, Save t) =>
KillHelper -> Command m s t
killFromHelper ((InsertMode -> InsertMode) -> KillHelper
SimpleMove forall s. Move s => s -> s
moveToEnd)
                , BaseKey -> Key
simpleKey BaseKey
KillLine forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) s t.
(MonadState KillRing m, MonadState Undo m, Save s, Save t) =>
KillHelper -> Command m s t
killFromHelper ((InsertMode -> InsertMode) -> KillHelper
SimpleMove forall s. Move s => s -> s
moveToStart)
                ]
            , Char -> Key
ctrlChar Char
'y' forall a. Key -> a -> KeyMap a
+> InputCmd InsertMode InsertMode
rotatePaste
            ]

rotatePaste :: InputCmd InsertMode InsertMode
rotatePaste :: InputCmd InsertMode InsertMode
rotatePaste InsertMode
im = forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. Monad m => KillRing -> CmdM m InsertMode
loop
  where
    loop :: KillRing -> CmdM m InsertMode
loop KillRing
kr = case forall a. Stack a -> Maybe a
peek KillRing
kr of
                    Maybe [Grapheme]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return InsertMode
im
                    Just [Grapheme]
s -> forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState ([Grapheme] -> InsertMode -> InsertMode
insertGraphemes [Grapheme]
s InsertMode
im)
                            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s.
Monad m =>
KeyCommand m s s -> Command m s s
try (Char -> Key
metaChar Char
'y' forall a. Key -> a -> KeyMap a
+> \InsertMode
_ -> KillRing -> CmdM m InsertMode
loop (forall a. Stack a -> Stack a
rotate KillRing
kr))


wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode
wordRight :: InsertMode -> InsertMode
wordRight = (InsertMode -> Bool) -> InsertMode -> InsertMode
goRightUntil ((Char -> Bool) -> InsertMode -> Bool
atStart (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlphaNum))
wordLeft :: InsertMode -> InsertMode
wordLeft = (InsertMode -> Bool) -> InsertMode -> InsertMode
goLeftUntil ((Char -> Bool) -> InsertMode -> Bool
atStart Char -> Bool
isAlphaNum)
bigWordLeft :: InsertMode -> InsertMode
bigWordLeft = (InsertMode -> Bool) -> InsertMode -> InsertMode
goLeftUntil ((Char -> Bool) -> InsertMode -> Bool
atStart (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace))

modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
modifyWord [Grapheme] -> [Grapheme]
f InsertMode
im = [Grapheme] -> [Grapheme] -> InsertMode
IMode (forall a. [a] -> [a]
reverse ([Grapheme] -> [Grapheme]
f [Grapheme]
ys1) forall a. [a] -> [a] -> [a]
++ [Grapheme]
xs) [Grapheme]
ys2
    where
        IMode [Grapheme]
xs [Grapheme]
ys = (Char -> Bool) -> InsertMode -> InsertMode
skipRight (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlphaNum) InsertMode
im
        ([Grapheme]
ys1,[Grapheme]
ys2) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Bool
isAlphaNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grapheme -> Char
baseChar) [Grapheme]
ys

capitalize :: [Grapheme] -> [Grapheme]
capitalize :: [Grapheme] -> [Grapheme]
capitalize [] = []
capitalize (Grapheme
c:[Grapheme]
cs) = (Char -> Char) -> Grapheme -> Grapheme
modifyBaseChar Char -> Char
toUpper Grapheme
c forall a. a -> [a] -> [a]
: [Grapheme]
cs