twin/xmonad-contrib
1
0
Fork 0
mirror of https://github.com/xmonad/xmonad-contrib.git synced 2025-08-01 20:51:52 -07:00
Code Issues Packages Projects Releases Wiki Activity

Vim for 'XMonad.Prompt':

Browse Source 
A vim-like keymap, yay! And dynamic colors and a reworked event loop.
Also fixes 'showCompletionOnTab' which was broken, and many new or
improved prompt interface functions.

Changes moveWord/moveWord' but updates the old keymaps to retain the
original behavior. See the documentation to do the same to your XMonad
configuration.

P.S. That bug I mention was there before my changes.
This commit is contained in:
Yclept Nemo
2018-04-19 19:24:41 -04:00
parent a774168415
commit b0d6e0f942
1 changed files with 678 additions and 254 deletions
Download Patch File Download Diff File Expand all files Collapse all files

678
XMonad/Prompt.hs
View File

@@ -4,7 +4,7 @@
-- | -- |
-- Module : XMonad.Prompt -- Module : XMonad.Prompt
-- Copyright : (C) 2007 Andrea Rossato, 2015 Evgeny Kurnevsky -- Copyright : (C) 2007 Andrea Rossato, 2015 Evgeny Kurnevsky
-- 2015 Sibi Prabakaran -- 2015 Sibi Prabakaran, 2018 Yclept Nemo
-- License : BSD3 -- License : BSD3
-- --
-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> -- Maintainer : Spencer Janssen <spencerjanssen@gmail.com>
@@ -15,6 +15,17 @@
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- Bugs:
-- if 'alwaysHighlight' is True, and
-- 1 type several characters
-- 2 tab-complete past several entries
-- 3 backspace back to the several characters
-- 4 tab-complete once (results in the entry past the one in [2])
-- 5 tab-complete against this shorter list of completions
-- then the prompt will freeze (XMonad continues however).
-----------------------------------------------------------------------------
module XMonad.Prompt module XMonad.Prompt
( -- * Usage ( -- * Usage
-- $usage -- $usage
@@ -27,18 +38,25 @@ module XMonad.Prompt
, greenXPConfig , greenXPConfig
, XPMode , XPMode
, XPType (..) , XPType (..)
, XPColor (..)
, XPPosition (..) , XPPosition (..)
, XPConfig (..) , XPConfig (..)
, XPrompt (..) , XPrompt (..)
, XP , XP
, defaultXPKeymap, defaultXPKeymap' , defaultXPKeymap, defaultXPKeymap'
, emacsLikeXPKeymap, emacsLikeXPKeymap' , emacsLikeXPKeymap, emacsLikeXPKeymap'
, vimLikeXPKeymap, vimLikeXPKeymap'
, quit , quit
, promptSubmap, promptBuffer, toHeadChar, bufferOne
, killBefore, killAfter, startOfLine, endOfLine , killBefore, killAfter, startOfLine, endOfLine
, insertString, pasteString, moveCursor , insertString, pasteString, pasteString'
, setInput, getInput , clipCursor, moveCursor, moveCursorClip
, moveWord, moveWord', killWord, killWord', deleteString , setInput, getInput, getOffset
, moveHistory, setSuccess, setDone , modifyColor, setColor, resetColor, setBorderColor
, modifyPrompter, setPrompter, resetPrompter
, moveWord, moveWord', killWord, killWord'
, changeWord, deleteString
, moveHistory, setSuccess, setDone, setModeDone
, Direction1D(..) , Direction1D(..)
, ComplFunction , ComplFunction
-- * X Utilities -- * X Utilities
@@ -80,7 +98,7 @@ import XMonad.Util.XSelection (getSelection)
import Codec.Binary.UTF8.String (decodeString,isUTF8Encoded) import Codec.Binary.UTF8.String (decodeString,isUTF8Encoded)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Arrow (first, (&&&), (***)) import Control.Arrow (first, second, (&&&), (***))
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Exception.Extensible as E hiding (handle) import Control.Exception.Extensible as E hiding (handle)
import Control.Monad.State import Control.Monad.State
@@ -123,6 +141,12 @@ data XPState =
, successful :: Bool , successful :: Bool
, numlockMask :: KeyMask , numlockMask :: KeyMask
, done :: Bool , done :: Bool
, modeDone :: Bool
, color :: XPColor
, prompter :: String -> String
, eventBuffer :: [(KeySym, String, Event)]
, inputBuffer :: String
, currentCompletions :: Maybe [String]
} }
data XPConfig = data XPConfig =
@@ -130,11 +154,6 @@ data XPConfig =
-- @"xft:Hack:pixelsize=1"@. Alternatively, use X Logical Font -- @"xft:Hack:pixelsize=1"@. Alternatively, use X Logical Font
-- Description, i.e. something like -- Description, i.e. something like
-- @"-*-dejavu sans mono-medium-r-normal--*-80-*-*-*-*-iso10646-1"@. -- @"-*-dejavu sans mono-medium-r-normal--*-80-*-*-*-*-iso10646-1"@.
, bgColor :: String -- ^ Background color
, fgColor :: String -- ^ Font color
, fgHLight :: String -- ^ Font color of a highlighted completion entry
, bgHLight :: String -- ^ Background color of a highlighted completion entry
, borderColor :: String -- ^ Border color
, promptBorderWidth :: !Dimension -- ^ Border width , promptBorderWidth :: !Dimension -- ^ Border width
, position :: XPPosition -- ^ Position: 'Top', 'Bottom', or 'CenteredAt' , position :: XPPosition -- ^ Position: 'Top', 'Bottom', or 'CenteredAt'
, alwaysHighlight :: !Bool -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only. , alwaysHighlight :: !Bool -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only.
@@ -156,6 +175,9 @@ data XPConfig =
, searchPredicate :: String -> String -> Bool , searchPredicate :: String -> String -> Bool
-- ^ Given the typed string and a possible -- ^ Given the typed string and a possible
-- completion, is the completion valid? -- completion, is the completion valid?
, defaultPrompter :: String -> String
-- ^ Modifies the prompt given by 'showXPrompt'
, defaultColor :: XPColor -- ^ Prompt colors
, sorter :: String -> [String] -> [String] , sorter :: String -> [String] -> [String]
-- ^ Used to sort the possible completions by how well they -- ^ Used to sort the possible completions by how well they
-- match the search string (see X.P.FuzzyMatch for an -- match the search string (see X.P.FuzzyMatch for an
@@ -248,16 +270,28 @@ data XPPosition = Top
} }
deriving (Show,Read) deriving (Show,Read)
data XPColor =
XPColor { bgNormal :: String -- ^ Background color
, fgNormal :: String -- ^ Font color
, bgHLight :: String -- ^ Background color of a highlighted completion entry
, fgHLight :: String -- ^ Font color of a highlighted completion entry
, border :: String -- ^ Border color
}
amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig
instance Default XPColor where
def =
XPColor { bgNormal = "grey22"
, fgNormal = "grey80"
, fgHLight = "black"
, bgHLight = "grey"
, border = "white"
}
instance Default XPConfig where instance Default XPConfig where
def = def =
XPC { font = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*" XPC { font = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"
, bgColor = "grey22"
, fgColor = "grey80"
, fgHLight = "black"
, bgHLight = "grey"
, borderColor = "white"
, promptBorderWidth = 1 , promptBorderWidth = 1
, promptKeymap = defaultXPKeymap , promptKeymap = defaultXPKeymap
, completionKey = (0,xK_Tab) , completionKey = (0,xK_Tab)
@@ -272,12 +306,20 @@ instance Default XPConfig where
, showCompletionOnTab = False , showCompletionOnTab = False
, searchPredicate = isPrefixOf , searchPredicate = isPrefixOf
, alwaysHighlight = False , alwaysHighlight = False
, defaultPrompter = id
, defaultColor = def
, sorter = const id , sorter = const id
} }
{-# DEPRECATED defaultXPConfig "Use def (from Data.Default, and re-exported from XMonad.Prompt) instead." #-} {-# DEPRECATED defaultXPConfig "Use def (from Data.Default, and re-exported from XMonad.Prompt) instead." #-}
defaultXPConfig = def defaultXPConfig = def
greenXPConfig = def { fgColor = "green", bgColor = "black", promptBorderWidth = 0 } greenXPConfig = def { defaultColor = def { fgNormal = "green", bgNormal = "black" }
amberXPConfig = def { fgColor = "#ca8f2d", bgColor = "black", fgHLight = "#eaaf4c" } , promptBorderWidth = 0
}
amberXPConfig = def { defaultColor = def { fgNormal = "#ca8f2d"
, bgNormal = "black"
, fgHLight = "#eaaf4c"
}
}
initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode
-> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> XPState -> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> XPState
@@ -295,13 +337,20 @@ initState d rw w s opMode gc fonts h c nm =
, fontS = fonts , fontS = fonts
, commandHistory = W.Stack { W.focus = defaultText c , commandHistory = W.Stack { W.focus = defaultText c
, W.up = [] , W.up = []
, W.down = h } , W.down = h
}
, complIndex = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True , complIndex = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True
, offset = length (defaultText c) , offset = length (defaultText c)
, config = c , config = c
, successful = False , successful = False
, done = False , done = False
, modeDone = False
, numlockMask = nm , numlockMask = nm
, prompter = defaultPrompter c
, color = defaultColor c
, eventBuffer = []
, inputBuffer = ""
, currentCompletions = Nothing
} }
-- Returns the current XPType -- Returns the current XPType
@@ -349,10 +398,52 @@ setInput :: String -> XP ()
setInput = modify . setCommand setInput = modify . setCommand
-- | Returns the current input string. Intented for use in custom keymaps -- | Returns the current input string. Intented for use in custom keymaps
-- where the 'get' or similar can't be used to retrieve it. -- where 'get' or similar can't be used to retrieve it.
getInput :: XP String getInput :: XP String
getInput = gets command getInput = gets command
-- | Returns the offset of the current input string. Intended for use in custom
-- keys where 'get' or similar can't be used to retrieve it.
getOffset :: XP Int
getOffset = gets offset
-- | Modify the prompt colors.
modifyColor :: (XPColor -> XPColor) -> XP ()
modifyColor c = modify $ \s -> s { color = c $ color s }
-- | Set the prompt colors.
setColor :: XPColor -> XP ()
setColor = modifyColor . const
-- | Reset the prompt colors to those from 'XPConfig'.
resetColor :: XP ()
resetColor = gets (defaultColor . config) >>= setColor
-- | Set the prompt border color.
setBorderColor :: String -> XPColor -> XPColor
setBorderColor bc xpc = xpc { border = bc }
-- | Modify the prompter, i.e. for chaining prompters.
modifyPrompter :: ((String -> String) -> (String -> String)) -> XP ()
modifyPrompter p = modify $ \s -> s { prompter = p $ prompter s }
-- | Set the prompter.
setPrompter :: (String -> String) -> XP ()
setPrompter = modifyPrompter . const
-- | Reset the prompter to the one from 'XPConfig'.
resetPrompter :: XP ()
resetPrompter = gets (defaultPrompter . config) >>= setPrompter
-- | Set the current completion list, or 'Nothing' to invalidate the current
-- completions.
setCurrentCompletions :: Maybe [String] -> XP ()
setCurrentCompletions cs = modify $ \s -> s { currentCompletions = cs }
-- | Get the current completion list.
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions = gets currentCompletions
-- | Same as 'mkXPrompt', except that the action function can have -- | Same as 'mkXPrompt', except that the action function can have
-- type @String -> X a@, for any @a@, and the final action returned -- type @String -> X a@, for any @a@, and the final action returned
-- by 'mkXPromptWithReturn' will have type @X (Maybe a)@. @Nothing@ -- by 'mkXPromptWithReturn' will have type @X (Maybe a)@. @Nothing@
@@ -464,34 +555,6 @@ mkXPromptWithModes modes conf = do
return () return ()
runXP :: XP ()
runXP = do
(d,w) <- gets (dpy &&& win)
status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime
when (status == grabSuccess) $ do
updateWindows
eventLoop handle
io $ ungrabKeyboard d currentTime
io $ destroyWindow d w
destroyComplWin
io $ sync d False
type KeyStroke = (KeySym, String)
eventLoop :: (KeyStroke -> Event -> XP ()) -> XP ()
eventLoop action = do
d <- gets dpy
(keysym,string,event) <- io $
allocaXEvent $ \e -> do
maskEvent d (exposureMask .|. keyPressMask) e
ev <- getEvent e
(ks,s) <- if ev_event_type ev == keyPress
then lookupString $ asKeyEvent e
else return (Nothing, "")
return (ks,s,ev)
action (fromMaybe xK_VoidSymbol keysym,string) event
gets done >>= flip unless (eventLoop handle)
-- | Removes numlock and capslock from a keymask. -- | Removes numlock and capslock from a keymask.
-- Duplicate of cleanMask from core, but in the -- Duplicate of cleanMask from core, but in the
-- XP monad instead of X. -- XP monad instead of X.
@@ -501,48 +564,129 @@ cleanMask msk = do
let highMasks = 1 `shiftL` 12 - 1 let highMasks = 1 `shiftL` 12 - 1
return (complement (numlock .|. lockMask) .&. msk .&. highMasks) return (complement (numlock .|. lockMask) .&. msk .&. highMasks)
-- Main event handler -- | Inverse of 'Codec.Binary.UTF8.String.utf8Encode', that is, a convenience
handle :: KeyStroke -> Event -> XP () -- function that checks to see if the input string is UTF8 encoded before
handle ks@(sym,_) e@(KeyEvent {ev_event_type = t, ev_state = m}) = do -- decoding.
complKey <- gets $ completionKey . config utf8Decode :: String -> String
chgModeKey <- gets $ changeModeKey . config utf8Decode str
c <- getCompletions | isUTF8Encoded str = decodeString str
mCleaned <- cleanMask m | otherwise = str
when (length c > 1) $ modify (\s -> s { showComplWin = True })
if complKey == (mCleaned,sym) runXP :: XP ()
then completionHandle c ks e runXP = do
else if (sym == chgModeKey) then (d,w) <- gets (dpy &&& win)
do status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime
modify setNextMode when (status == grabSuccess) $ do
updateWindows updateWindows
else when (t == keyPress) $ keyPressHandle mCleaned ks eventLoop handleMain evDefaultStop
handle _ (ExposeEvent {ev_window = w}) = do io $ ungrabKeyboard d currentTime
io $ destroyWindow d w
destroyComplWin
io $ sync d False
type KeyStroke = (KeySym, String)
-- | Main event "loop". Gives priority to events from the state's event buffer.
eventLoop :: (KeyStroke -> Event -> XP ())
-> XP Bool
-> XP ()
eventLoop handle stopAction = do
b <- gets eventBuffer
(keysym,keystr,event) <- case b of
[] -> do
d <- gets dpy
io $ allocaXEvent $ \e -> do
maskEvent d (exposureMask .|. keyPressMask) e
ev <- getEvent e
(ks,s) <- if ev_event_type ev == keyPress
then lookupString $ asKeyEvent e
else return (Nothing, "")
return (fromMaybe xK_VoidSymbol ks,s,ev)
l -> do
modify $ \s -> s { eventBuffer = tail l }
return $ head l
handle (keysym,keystr) event
stopAction >>= flip unless (eventLoop handle stopAction)
-- | Default event loop stop condition.
evDefaultStop :: XP Bool
evDefaultStop = (||) <$> (gets modeDone) <*> (gets done)
-- | Common patterns shared by all event handlers. Expose events can be
-- triggered by switching virtual consoles.
handleOther :: KeyStroke -> Event -> XP ()
handleOther _ (ExposeEvent {ev_window = w}) = do
st <- get st <- get
when (win st == w) updateWindows when (win st == w) updateWindows
handle _ _ = return () handleOther _ _ = return ()
-- completion event handler -- | Prompt event handler for the main loop. Dispatches to input, completion
completionHandle :: [String] -> KeyStroke -> Event -> XP () -- and mode switching handlers.
completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = do handleMain :: KeyStroke -> Event -> XP ()
complKey <- gets $ completionKey . config handleMain stroke@(keysym,_) (KeyEvent {ev_event_type = t, ev_state = m}) = do
(compKey,modeKey) <- gets $ (completionKey &&& changeModeKey) . config
keymask <- cleanMask m
-- haven't subscribed to keyRelease, so just in case
when (t == keyPress) $
if (keymask,keysym) == compKey
then getCurrentCompletions >>= handleCompletionMain
else do
setCurrentCompletions Nothing
if (keysym == modeKey)
then modify setNextMode >> updateWindows
else handleInputMain keymask stroke
handleMain stroke event = handleOther stroke event
-- | Prompt input handler for the main loop.
handleInputMain :: KeyMask -> KeyStroke -> XP ()
handleInputMain keymask (keysym,keystr) = do
keymap <- gets (promptKeymap . config)
case M.lookup (keymask,keysym) keymap of
-- 'null keystr' i.e. when only a modifier was pressed
Just action -> action >> updateWindows
Nothing -> unless (null keystr) $
when (keymask .&. controlMask == 0) $ do
insertString $ utf8Decode keystr
updateWindows
updateHighlightedCompl
complete <- tryAutoComplete
when complete $ setSuccess True >> setDone True
-- There are two options to store the completion list during the main loop:
-- * Use the State monad, with 'Nothing' as the initial state.
-- * Join the output of the event loop handler to the input of the (same)
-- subsequent handler, using 'Nothing' as the initial input.
-- Both approaches are, under the hood, equivalent.
--
-- | Prompt completion handler for the main loop. Given 'Nothing', generate the
-- current completion list. With the current list, trigger a completion.
handleCompletionMain :: Maybe [String] -> XP ()
handleCompletionMain Nothing = do
cs <- getCompletions
when (length cs > 1) $
modify $ \s -> s { showComplWin = True }
setCurrentCompletions $ Just cs
handleCompletion cs
handleCompletionMain (Just cs) = handleCompletion cs
handleCompletion :: [String] -> XP ()
handleCompletion cs = do
alwaysHlight <- gets $ alwaysHighlight . config alwaysHlight <- gets $ alwaysHighlight . config
mCleaned <- cleanMask m
case () of
() | t == keyPress && (mCleaned,sym) == complKey -> do
st <- get st <- get
let updateWins l = redrawWindows l >> eventLoop (completionHandle l) let updateWins l = redrawWindows l
updateState l = case alwaysHlight of updateState l = case alwaysHlight of
False -> simpleComplete l st False -> simpleComplete l st
True | Just (command st) /= highlightedCompl st -> alwaysHighlightCurrent st True | Just (command st) /= highlightedCompl st -> alwaysHighlightCurrent st
| otherwise -> alwaysHighlightNext l st | otherwise -> alwaysHighlightNext l st
case c of case cs of
[] -> updateWindows >> eventLoop handle [] -> updateWindows
[x] -> updateState [x] >> getCompletions >>= updateWins [x] -> do updateState [x]
cs' <- getCompletions
updateWins cs'
setCurrentCompletions $ Just cs'
l -> updateState l >> updateWins l l -> updateState l >> updateWins l
| t == keyRelease && (mCleaned,sym) == complKey -> eventLoop (completionHandle c)
| otherwise -> keyPressHandle mCleaned ks -- some other key, handle it normally
where where
-- When alwaysHighlight is off, just complete based on what the -- When alwaysHighlight is off, just complete based on what the
-- user has typed so far. -- user has typed so far.
@@ -559,7 +703,7 @@ completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = d
-- current completion item. -- current completion item.
alwaysHighlightCurrent :: XPState -> XP () alwaysHighlightCurrent :: XPState -> XP ()
alwaysHighlightCurrent st = do alwaysHighlightCurrent st = do
let newCommand = fromMaybe (command st) $ highlightedItem st c let newCommand = fromMaybe (command st) $ highlightedItem st cs
modify $ \s -> setCommand newCommand $ modify $ \s -> setCommand newCommand $
setHighlightedCompl (Just newCommand) $ setHighlightedCompl (Just newCommand) $
s { offset = length newCommand s { offset = length newCommand
@@ -573,7 +717,7 @@ completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = d
alwaysHighlightNext :: [String] -> XPState -> XP () alwaysHighlightNext :: [String] -> XPState -> XP ()
alwaysHighlightNext l st = do alwaysHighlightNext l st = do
let complIndex' = nextComplIndex st (length l) let complIndex' = nextComplIndex st (length l)
highlightedCompl' = highlightedItem st { complIndex = complIndex'} c highlightedCompl' = highlightedItem st { complIndex = complIndex'} cs
newCommand = fromMaybe (command st) $ highlightedCompl' newCommand = fromMaybe (command st) $ highlightedCompl'
modify $ \s -> setHighlightedCompl highlightedCompl' $ modify $ \s -> setHighlightedCompl highlightedCompl' $
setCommand newCommand $ setCommand newCommand $
@@ -581,8 +725,107 @@ completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = d
, offset = length newCommand , offset = length newCommand
} }
-- some other event: go back to main loop -- | Initiate a prompt sub-map event loop. Submaps are intended to provide
completionHandle _ k e = handle k e -- alternate keybindings. Accepts a default action and a mapping from key
-- combinations to actions. If no entry matches, the default action is run.
promptSubmap :: XP ()
-> M.Map (KeyMask, KeySym) (XP ())
-> XP ()
promptSubmap defaultAction keymap = do
md <- gets modeDone
setModeDone False
updateWindows
eventLoop (handleSubmap defaultAction keymap) evDefaultStop
setModeDone md
handleSubmap :: XP ()
-> M.Map (KeyMask, KeySym) (XP ())
-> KeyStroke
-> Event
-> XP ()
handleSubmap defaultAction keymap stroke (KeyEvent {ev_event_type = t, ev_state = m}) = do
keymask <- cleanMask m
when (t == keyPress) $ handleInputSubmap defaultAction keymap keymask stroke
handleSubmap _ _ stroke event = handleOther stroke event
handleInputSubmap :: XP ()
-> M.Map (KeyMask, KeySym) (XP ())
-> KeyMask
-> KeyStroke
-> XP ()
handleInputSubmap defaultAction keymap keymask (keysym,keystr) = do
case M.lookup (keymask,keysym) keymap of
Just action -> action >> updateWindows
Nothing -> unless (null keystr) $ defaultAction >> updateWindows
-- | Initiate a prompt input buffer event loop. Input is sent to a buffer and
-- bypasses the prompt. The provided function is given the existing buffer and
-- the input keystring. The first field of the result determines whether the
-- input loop continues (if @True@). The second field determines whether the
-- input is appended to the buffer, or dropped (if @False@). If the loop is to
-- stop without keeping input - that is, @(False,False)@ - the event is
-- prepended to the event buffer to be processed by the parent loop. This
-- allows loop to process both fixed and indeterminate inputs.
--
-- Result given @(continue,keep)@:
--
-- * cont and keep
--
-- * grow input buffer
--
-- * stop and keep
--
-- * grow input buffer
-- * stop loop
--
-- * stop and drop
--
-- * buffer event
-- * stop loop
--
-- * cont and drop
--
-- * do nothing
promptBuffer :: (String -> String -> (Bool,Bool)) -> XP (String)
promptBuffer f = do
md <- gets modeDone
setModeDone False
eventLoop (handleBuffer f) evDefaultStop
buff <- gets inputBuffer
modify $ \s -> s { inputBuffer = "" }
setModeDone md
return buff
handleBuffer :: (String -> String -> (Bool,Bool))
-> KeyStroke
-> Event
-> XP ()
handleBuffer f stroke event@(KeyEvent {ev_event_type = t, ev_state = m}) = do
keymask <- cleanMask m
when (t == keyPress) $ handleInputBuffer f keymask stroke event
handleBuffer _ stroke event = handleOther stroke event
handleInputBuffer :: (String -> String -> (Bool,Bool))
-> KeyMask
-> KeyStroke
-> Event
-> XP ()
handleInputBuffer f keymask (keysym,keystr) event = do
unless (null keystr || keymask .&. controlMask /= 0) $ do
(evB,inB) <- gets (eventBuffer &&& inputBuffer)
let keystr' = utf8Decode keystr
let (cont,keep) = f inB keystr'
when (keep) $
modify $ \s -> s { inputBuffer = inB ++ keystr' }
unless (cont) $
setModeDone True
unless (cont || keep) $
modify $ \s -> s { eventBuffer = (keysym,keystr,event) : evB }
-- | Predicate instructing 'promptBuffer' to get (and keep) a single non-empty
-- 'KeyEvent'.
bufferOne :: String -> String -> (Bool,Bool)
bufferOne xs x = (null xs && null x,True)
--Receives an state of the prompt, the size of the autocompletion list and returns the column,row --Receives an state of the prompt, the size of the autocompletion list and returns the column,row
--which should be highlighted next --which should be highlighted next
@@ -642,8 +885,9 @@ defaultXPKeymap' p = M.fromList $
, (xK_a, startOfLine) , (xK_a, startOfLine)
, (xK_e, endOfLine) , (xK_e, endOfLine)
, (xK_y, pasteString) , (xK_y, pasteString)
, (xK_Right, moveWord' p Next) -- Retain the pre-0.14 moveWord' behavior:
, (xK_Left, moveWord' p Prev) , (xK_Right, moveWord' p Next >> moveCursor Next)
, (xK_Left, moveCursor Prev >> moveWord' p Prev)
, (xK_Delete, killWord' p Next) , (xK_Delete, killWord' p Next)
, (xK_BackSpace, killWord' p Prev) , (xK_BackSpace, killWord' p Prev)
, (xK_w, killWord' p Prev) , (xK_w, killWord' p Prev)
@@ -694,8 +938,9 @@ emacsLikeXPKeymap' p = M.fromList $
] ++ ] ++
map (first $ (,) mod1Mask) -- meta key + <key> map (first $ (,) mod1Mask) -- meta key + <key>
[ (xK_BackSpace, killWord' p Prev) [ (xK_BackSpace, killWord' p Prev)
, (xK_f, moveWord' p Next) -- move a word forward -- Retain the pre-0.14 moveWord' behavior:
, (xK_b, moveWord' p Prev) -- move a word backward , (xK_f, moveWord' p Next >> moveCursor Next) -- move a word forward
, (xK_b, moveCursor Prev >> moveWord' p Prev) -- move a word backward
, (xK_d, killWord' p Next) -- kill the next word , (xK_d, killWord' p Next) -- kill the next word
, (xK_n, moveHistory W.focusUp') , (xK_n, moveHistory W.focusUp')
, (xK_p, moveHistory W.focusDown') , (xK_p, moveHistory W.focusDown')
@@ -715,34 +960,141 @@ emacsLikeXPKeymap' p = M.fromList $
, (xK_Escape, quit) , (xK_Escape, quit)
] ]
keyPressHandle :: KeyMask -> KeyStroke -> XP () -- | Vim-ish key bindings. Click on the \"Source\" link to the right to see the
keyPressHandle m (ks,str) = do -- complete list. See also 'vimLikeXPKeymap''.
km <- gets (promptKeymap . config) vimLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ())
case M.lookup (m,ks) km of vimLikeXPKeymap = vimLikeXPKeymap' (setBorderColor "grey22") id id isSpace
Just action -> action >> updateWindows
Nothing -> case str of
"" -> eventLoop handle
_ -> when (m .&. controlMask == 0) $ do
let str' = if isUTF8Encoded str
then decodeString str
else str
insertString str'
updateWindows
updateHighlightedCompl
completed <- tryAutoComplete
when completed $ setSuccess True >> setDone True
-- | A variant of 'vimLikeXPKeymap' with customizable aspects:
vimLikeXPKeymap' :: (XPColor -> XPColor)
-- ^ Modifies the prompt color when entering normal mode.
-- The default is @setBorderColor "grey22"@ - same color as
-- the default background color.
-> (String -> String)
-- ^ Prompter to use in normal mode. The default of 'id'
-- balances 'defaultPrompter' but @("[n] " ++)@ is a good
-- alternate with 'defaultPrompter' as @("[i] " ++)@.
-> (String -> String)
-- ^ Filter applied to the X Selection before pasting. The
-- default is 'id' but @filter isPrint@ is a good
-- alternate.
-> (Char -> Bool)
-- ^ Predicate identifying non-word characters. The default
-- is 'isSpace'. See the documentation of other keymaps for
-- alternates.
-> M.Map (KeyMask,KeySym) (XP ())
vimLikeXPKeymap' fromColor promptF pasteFilter notWord = M.fromList $
map (first $ (,) 0)
[ (xK_Return, setSuccess True >> setDone True)
, (xK_KP_Enter, setSuccess True >> setDone True)
, (xK_BackSpace, deleteString Prev)
, (xK_Delete, deleteString Next)
, (xK_Left, moveCursor Prev)
, (xK_Right, moveCursor Next)
, (xK_Home, startOfLine)
, (xK_End, endOfLine)
, (xK_Down, moveHistory W.focusUp')
, (xK_Up, moveHistory W.focusDown')
, (xK_Escape, moveCursor Prev
>> modifyColor fromColor
>> setPrompter promptF
>> promptSubmap (return ()) normalVimXPKeymap
>> resetColor
>> resetPrompter
)
] where
normalVimXPKeymap = M.fromList $
map (first $ (,) 0)
[ (xK_i, setModeDone True)
, (xK_a, moveCursor Next >> setModeDone True)
, (xK_s, deleteString Next >> setModeDone True)
, (xK_x, deleteString Next >> clipCursor)
, (xK_Delete, deleteString Next >> clipCursor)
, (xK_p, moveCursor Next
>> pasteString' pasteFilter
>> moveCursor Prev
)
, (xK_0, startOfLine)
, (xK_Escape, quit)
, (xK_Down, moveHistory W.focusUp')
, (xK_j, moveHistory W.focusUp')
, (xK_Up, moveHistory W.focusDown')
, (xK_k, moveHistory W.focusDown')
, (xK_Right, moveCursorClip Next)
, (xK_l, moveCursorClip Next)
, (xK_h, moveCursorClip Prev)
, (xK_Left, moveCursorClip Prev)
, (xK_BackSpace, moveCursorClip Prev)
-- Implementation using the original 'moveWord'':
--, (xK_e, moveCursor Next >> moveWord' notWord Next >> moveCursor Prev)
--, (xK_b, moveWord' notWord Prev)
--, (xK_w, moveWord' (not . notWord) Next >> clipCursor)
, (xK_e, moveCursorClip Next >> moveWord' notWord Next)
, (xK_b, moveCursorClip Prev >> moveWord' notWord Prev)
, (xK_w, moveWord' (not . notWord) Next >> moveCursorClip Next)
, (xK_f, promptBuffer bufferOne >>= toHeadChar Next)
, (xK_d, promptSubmap (setModeDone True) deleteVimXPKeymap)
, (xK_c, promptSubmap (setModeDone True) changeVimXPKeymap
>> setModeDone True
)
] ++
map (first $ (,) shiftMask)
[ (xK_dollar, endOfLine >> moveCursor Prev)
, (xK_D, killAfter >> moveCursor Prev)
, (xK_C, killAfter >> setModeDone True)
, (xK_P, pasteString' pasteFilter >> moveCursor Prev)
, (xK_A, endOfLine >> setModeDone True)
, (xK_I, startOfLine >> setModeDone True)
, (xK_F, promptBuffer bufferOne >>= toHeadChar Prev)
]
deleteVimXPKeymap = M.fromList $
map ((first $ (,) 0) . (second $ flip (>>) (setModeDone True)))
[ (xK_e, deleteString Next >> killWord' notWord Next >> clipCursor)
, (xK_w, killWord' (not . notWord) Next >> clipCursor)
, (xK_0, killBefore)
, (xK_b, killWord' notWord Prev)
, (xK_d, setInput "")
] ++
map ((first $ (,) shiftMask) . (second $ flip (>>) (setModeDone True)))
[ (xK_dollar, killAfter >> moveCursor Prev)
]
changeVimXPKeymap = M.fromList $
map ((first $ (,) 0) . (second $ flip (>>) (setModeDone True)))
[ (xK_e, deleteString Next >> killWord' notWord Next)
, (xK_0, killBefore)
, (xK_b, killWord' notWord Prev)
, (xK_c, setInput "")
, (xK_w, changeWord notWord)
] ++
map ((first $ (,) shiftMask) . (second $ flip (>>) (setModeDone True)))
[ (xK_dollar, killAfter)
]
-- Useful for exploring off-by-one issues.
--testOffset :: XP ()
--testOffset = do
-- off <- getOffset
-- str <- getInput
-- setInput $ str ++ "|" ++ (show off) ++ ":" ++ (show $ length str)
-- | Set @True@ to save the prompt's entry to history and run it via the
-- provided action.
setSuccess :: Bool -> XP () setSuccess :: Bool -> XP ()
setSuccess b = modify $ \s -> s { successful = b } setSuccess b = modify $ \s -> s { successful = b }
-- | Set @True@ to leave all event loops, no matter how nested.
setDone :: Bool -> XP () setDone :: Bool -> XP ()
setDone b = modify $ \s -> s { done = b } setDone b = modify $ \s -> s { done = b }
-- | Set @True@ to leave the current event loop, i.e. submaps.
setModeDone :: Bool -> XP ()
setModeDone b = modify $ \s -> s { modeDone = b }
-- KeyPress and State -- KeyPress and State
-- | Quit. -- | Quit.
quit :: XP () quit :: XP ()
quit = flushString >> setSuccess False >> setDone True quit = flushString >> setSuccess False >> setDone True >> setModeDone True
-- | Kill the portion of the command before the cursor -- | Kill the portion of the command before the cursor
killBefore :: XP () killBefore :: XP ()
@@ -781,6 +1133,19 @@ killWord' p d = do
Prev -> (delPrevWord f ++ ss, length $ delPrevWord f) -- laziness!! Prev -> (delPrevWord f ++ ss, length $ delPrevWord f) -- laziness!!
modify $ \s -> setCommand ncom $ s { offset = noff} modify $ \s -> setCommand ncom $ s { offset = noff}
-- | From Vim's @:help cw@:
--
-- * Special case: When the cursor is in a word, "cw" and "cW" do not include
-- the white space after a word, they only change up to the end of the word.
changeWord :: (Char -> Bool) -> XP ()
changeWord p = f <$> getInput <*> getOffset <*> (pure p) >>= id
where
f :: String -> Int -> (Char -> Bool) -> XP ()
f str off _ | length str <= off ||
length str <= 0 = return ()
f str off p'| p' $ str !! off = killWord' (not . p') Next
| otherwise = killWord' p' Next
-- | Put the cursor at the end of line -- | Put the cursor at the end of line
endOfLine :: XP () endOfLine :: XP ()
endOfLine = endOfLine =
@@ -812,9 +1177,15 @@ insertString str =
| otherwise = f ++ str ++ ss | otherwise = f ++ str ++ ss
where (f,ss) = splitAt oo oc where (f,ss) = splitAt oo oc
-- | Insert the current X selection string at the cursor position. -- | Insert the current X selection string at the cursor position. The X
-- selection is not modified.
pasteString :: XP () pasteString :: XP ()
pasteString = join $ io $ liftM insertString getSelection pasteString = pasteString' id
-- | A variant of 'pasteString' which allows modifying the X selection before
-- pasting.
pasteString' :: (String -> String) -> XP ()
pasteString' f = join $ io $ liftM (insertString . f) getSelection
-- | Remove a character at the cursor position -- | Remove a character at the cursor position
deleteString :: Direction1D -> XP () deleteString :: Direction1D -> XP ()
@@ -828,26 +1199,59 @@ deleteString d =
| otherwise = oc | otherwise = oc
where (f,ss) = splitAt oo oc where (f,ss) = splitAt oo oc
-- | move the cursor one position -- | Ensure the cursor remains over the command by shifting left if necessary.
clipCursor :: XP ()
clipCursor = modify $ \s -> s { offset = o (offset s) (command s)}
where o oo c = min (max 0 $ length c - 1) oo
-- | Move the cursor one position.
moveCursor :: Direction1D -> XP () moveCursor :: Direction1D -> XP ()
moveCursor d = moveCursor d =
modify $ \s -> s { offset = o (offset s) (command s)} modify $ \s -> s { offset = o (offset s) (command s)}
where o oo c = if d == Prev then max 0 (oo - 1) else min (length c) (oo + 1) where o oo c = if d == Prev then max 0 (oo - 1) else min (length c) (oo + 1)
-- | Move the cursor one position, but not beyond the command.
moveCursorClip :: Direction1D -> XP ()
moveCursorClip = (>> clipCursor) . moveCursor
-- modify $ \s -> s { offset = o (offset s) (command s)}
-- where o oo c = if d == Prev then max 0 (oo - 1) else min (max 0 $ length c - 1) (oo + 1)
-- | Move the cursor one word, using 'isSpace' as the default -- | Move the cursor one word, using 'isSpace' as the default
-- predicate for non-word characters. See 'moveWord''. -- predicate for non-word characters. See 'moveWord''.
moveWord :: Direction1D -> XP () moveWord :: Direction1D -> XP ()
moveWord = moveWord' isSpace moveWord = moveWord' isSpace
-- | Move the cursor one word, given a predicate to identify non-word -- | Given a direction, move the cursor to just before the next
-- characters. First move past any consecutive non-word characters; -- (predicate,not-predicate) character transition. This means a (not-word,word)
-- then move to just before the next non-word character. -- transition should be followed by a 'moveCursorClip' action. Always considers
-- the character under the current cursor position. This means a
-- (word,not-word) transition should be preceded by a 'moveCursorClip' action.
-- Calculated as the length of consecutive non-predicate characters starting
-- from the cursor position, plus the length of subsequent consecutive
-- predicate characters, plus when moving backwards the distance of the cursor
-- beyond the input. Reduced by one to avoid jumping off either end of the
-- input, when present.
--
-- Use these identities to retain the pre-0.14 behavior:
--
-- @
-- (oldMoveWord' p Prev) = (moveCursor Prev >> moveWord' p Prev)
-- @
--
-- @
-- (oldMoveWord' p Next) = (moveWord' p Next >> moveCursor Next)
-- @
moveWord' :: (Char -> Bool) -> Direction1D -> XP () moveWord' :: (Char -> Bool) -> Direction1D -> XP ()
moveWord' p d = do moveWord' p d = do
c <- gets command c <- gets command
o <- gets offset o <- gets offset
let (f,ss) = splitAt o c let (f,ss) = splitOn o c
len = uncurry (+) splitOn n xs = (take (n+1) xs, drop n xs)
gap = case d of
Prev -> max 0 $ (o + 1) - (length c)
Next -> 0
len = max 0 . flip (-) 1 . (gap +)
. uncurry (+)
. (length *** (length . fst . break p)) . (length *** (length . fst . break p))
. break (not . p) . break (not . p)
newoff = case d of newoff = case d of
@@ -855,6 +1259,9 @@ moveWord' p d = do
Next -> o + len ss Next -> o + len ss
modify $ \s -> s { offset = newoff } modify $ \s -> s { offset = newoff }
-- | Set the prompt's input to an entry further up or further down the history
-- stack. Use 'Stack' functions from 'XMonad.StackSet', i.e. 'focusUp'' or
-- 'focusDown''.
moveHistory :: (W.Stack String -> W.Stack String) -> XP () moveHistory :: (W.Stack String -> W.Stack String) -> XP ()
moveHistory f = do moveHistory f = do
modify $ \s -> let ch = f $ commandHistory s modify $ \s -> let ch = f $ commandHistory s
@@ -864,6 +1271,21 @@ moveHistory f = do
updateWindows updateWindows
updateHighlightedCompl updateHighlightedCompl
-- | Move the cursor in the given direction to the first instance of the first
-- character of the given string, assuming the string is not empty. The
-- starting cursor character is not considered, and the cursor is placed over
-- the matching character.
toHeadChar :: Direction1D -> String -> XP ()
toHeadChar d s = unless (null s) $ do
cmd <- gets command
off <- gets offset
let c = head s
off' = (if d == Prev then negate . fst else snd)
. join (***) (fromMaybe 0 . fmap (+1) . elemIndex c)
. (reverse *** drop 1)
$ (splitAt off cmd)
modify $ \st -> st { offset = offset st + off' }
updateHighlightedCompl :: XP () updateHighlightedCompl :: XP ()
updateHighlightedCompl = do updateHighlightedCompl = do
st <- get st <- get
@@ -909,18 +1331,18 @@ createWin d rw c s = do
drawWin :: XP () drawWin :: XP ()
drawWin = do drawWin = do
st <- get st <- get
let (c,(d,(w,gc))) = (config &&& dpy &&& win &&& gcon) st let (c,(cr,(d,(w,gc)))) = (config &&& color &&& dpy &&& win &&& gcon) st
scr = defaultScreenOfDisplay d scr = defaultScreenOfDisplay d
wh = case position c of wh = case position c of
CenteredAt _ wd -> floor $ wd * fi (widthOfScreen scr) CenteredAt _ wd -> floor $ wd * fi (widthOfScreen scr)
_ -> widthOfScreen scr _ -> widthOfScreen scr
ht = height c ht = height c
bw = promptBorderWidth c bw = promptBorderWidth c
Just bgcolor <- io $ initColor d (bgColor c) Just bgcolor <- io $ initColor d (bgNormal cr)
Just border <- io $ initColor d (borderColor c) Just borderC <- io $ initColor d (border cr)
p <- io $ createPixmap d w wh ht p <- io $ createPixmap d w wh ht
(defaultDepthOfScreen scr) (defaultDepthOfScreen scr)
io $ fillDrawable d p gc border bgcolor (fi bw) wh ht io $ fillDrawable d p gc borderC bgcolor (fi bw) wh ht
printPrompt p printPrompt p
io $ copyArea d p w gc 0 0 wh ht 0 0 io $ copyArea d p w gc 0 0 wh ht 0 0
io $ freePixmap d p io $ freePixmap d p
@@ -928,8 +1350,9 @@ drawWin = do
printPrompt :: Drawable -> XP () printPrompt :: Drawable -> XP ()
printPrompt drw = do printPrompt drw = do
st <- get st <- get
let (gc,(c,(d,fs))) = (gcon &&& config &&& dpy &&& fontS) st let (pr,(cr,gc)) = (prompter &&& color &&& gcon) st
(prt,(com,off)) = (show . currentXPMode &&& command &&& offset) st (c,(d,fs)) = (config &&& dpy &&& fontS) st
(prt,(com,off)) = (pr . show . currentXPMode &&& command &&& offset) st
str = prt ++ com str = prt ++ com
-- break the string in 3 parts: till the cursor, the cursor and the rest -- break the string in 3 parts: till the cursor, the cursor and the rest
(f,p,ss) = if off >= length com (f,p,ss) = if off >= length com
@@ -945,11 +1368,11 @@ printPrompt drw = do
let draw = printStringXMF d drw fs gc let draw = printStringXMF d drw fs gc
-- print the first part -- print the first part
draw (fgColor c) (bgColor c) x y f draw (fgNormal cr) (bgNormal cr) x y f
-- reverse the colors and print the "cursor" ;-) -- reverse the colors and print the "cursor" ;-)
draw (bgColor c) (fgColor c) (x + fromIntegral fsl) y p draw (bgNormal cr) (fgNormal cr) (x + fromIntegral fsl) y p
-- reverse the colors and print the rest of the string -- reverse the colors and print the rest of the string
draw (fgColor c) (bgColor c) (x + fromIntegral (fsl + psl)) y ss draw (fgNormal cr) (bgNormal cr) (x + fromIntegral (fsl + psl)) y ss
-- get the current completion function depending on the active mode -- get the current completion function depending on the active mode
getCompletionFunction :: XPState -> ComplFunction getCompletionFunction :: XPState -> ComplFunction
@@ -1034,21 +1457,22 @@ drawComplWin :: Window -> [String] -> XP ()
drawComplWin w compl = do drawComplWin w compl = do
st <- get st <- get
let c = config st let c = config st
cr = color st
d = dpy st d = dpy st
scr = defaultScreenOfDisplay d scr = defaultScreenOfDisplay d
bw = promptBorderWidth c bw = promptBorderWidth c
gc = gcon st gc = gcon st
Just bgcolor <- io $ initColor d (bgColor c) Just bgcolor <- io $ initColor d (bgNormal cr)
Just border <- io $ initColor d (borderColor c) Just borderC <- io $ initColor d (border cr)
(_,_,wh,ht,xx,yy) <- getComplWinDim compl (_,_,wh,ht,xx,yy) <- getComplWinDim compl
p <- io $ createPixmap d w wh ht p <- io $ createPixmap d w wh ht
(defaultDepthOfScreen scr) (defaultDepthOfScreen scr)
io $ fillDrawable d p gc border bgcolor (fi bw) wh ht io $ fillDrawable d p gc borderC bgcolor (fi bw) wh ht
let ac = splitInSubListsAt (length yy) (take (length xx * length yy) compl) let ac = splitInSubListsAt (length yy) (take (length xx * length yy) compl)
printComplList d p gc (fgColor c) (bgColor c) xx yy ac printComplList d p gc (fgNormal cr) (bgNormal cr) xx yy ac
--lift $ spawn $ "xmessage " ++ " ac: " ++ show ac ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy) --lift $ spawn $ "xmessage " ++ " ac: " ++ show ac ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy)
io $ copyArea d p w gc 0 0 wh ht 0 0 io $ copyArea d p w gc 0 0 wh ht 0 0
io $ freePixmap d p io $ freePixmap d p
@@ -1090,12 +1514,12 @@ printComplList d drw gc fc bc xs ys sss =
let let
(colIndex,rowIndex) = findComplIndex item sss (colIndex,rowIndex) = findComplIndex item sss
in -- assign some colors in -- assign some colors
if ((complIndex st) == (colIndex,rowIndex)) then (fgHLight $ config st,bgHLight $ config st) if ((complIndex st) == (colIndex,rowIndex)) then (fgHLight $ color st,bgHLight $ color st)
else (fc,bc) else (fc,bc)
False -> False ->
-- compare item with buffer's value -- compare item with buffer's value
if completionToCommand (currentXPMode st) item == commandToComplete (currentXPMode st) (command st) if completionToCommand (currentXPMode st) item == commandToComplete (currentXPMode st) (command st)
then (fgHLight $ config st,bgHLight $ config st) then (fgHLight $ color st,bgHLight $ color st)
else (fc,bc) else (fc,bc)
printStringXMF d drw (fontS st) gc f b x y item) printStringXMF d drw (fontS st) gc f b x y item)
ys ss) xs sss ys ss) xs sss
@@ -1132,9 +1556,9 @@ writeHistory hist = do
-- | Fills a 'Drawable' with a rectangle and a border -- | Fills a 'Drawable' with a rectangle and a border
fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
-> Dimension -> Dimension -> Dimension -> IO () -> Dimension -> Dimension -> Dimension -> IO ()
fillDrawable d drw gc border bgcolor bw wh ht = do fillDrawable d drw gc borderC bgcolor bw wh ht = do
-- we start with the border -- we start with the border
setForeground d gc border setForeground d gc borderC
fillRectangle d drw gc 0 0 wh ht fillRectangle d drw gc 0 0 wh ht
-- here foreground means the background of the text -- here foreground means the background of the text
setForeground d gc bgcolor setForeground d gc bgcolor