module XMonad.Prompt
(
mkXPrompt
, mkXPromptWithReturn
, amberXPConfig
, defaultXPConfig
, greenXPConfig
, XPType (..)
, XPPosition (..)
, XPConfig (..)
, XPrompt (..)
, XP
, defaultXPKeymap
, quit
, killBefore, killAfter, startOfLine, endOfLine
, pasteString, moveCursor
, setInput, getInput
, moveWord, killWord, deleteString
, moveHistory, setSuccess, setDone
, Direction1D(..)
, ComplFunction
, mkUnmanagedWindow
, fillDrawable
, mkComplFunFromList
, mkComplFunFromList'
, getNextOfLastWord
, getNextCompletion
, getLastWord
, skipLastWord
, splitInSubListsAt
, breakAtSpace
, uniqSort
, historyCompletion
, historyCompletionP
, deleteAllDuplicates
, deleteConsecutive
, HistoryMatches
, initMatches
, historyUpMatching
, historyDownMatching
, XPState
) where
import Prelude hiding (catch)
import XMonad hiding (config, cleanMask)
import qualified XMonad as X (numberlockMask)
import qualified XMonad.StackSet as W
import XMonad.Util.Font
import XMonad.Util.Types
import XMonad.Util.XSelection (getSelection)
import Codec.Binary.UTF8.String (decodeString)
import Control.Applicative ((<$>))
import Control.Arrow ((&&&),first)
import Control.Concurrent (threadDelay)
import Control.Exception.Extensible hiding (handle)
import Control.Monad.State
import Data.Bits
import Data.Char (isSpace)
import Data.IORef
import Data.List
import Data.Maybe (fromMaybe)
import Data.Set (fromList, toList)
import System.Directory (getAppUserDataDirectory)
import System.IO
import System.Posix.Files
import qualified Data.Map as M
type XP = StateT XPState IO
data XPState =
XPS { dpy :: Display
, rootw :: !Window
, win :: !Window
, screen :: !Rectangle
, complWin :: Maybe Window
, complWinDim :: Maybe ComplWindowDim
, completionFunction :: String -> IO [String]
, showComplWin :: Bool
, gcon :: !GC
, fontS :: !XMonadFont
, xptype :: !XPType
, commandHistory :: W.Stack String
, offset :: !Int
, config :: XPConfig
, successful :: Bool
, numlockMask :: KeyMask
, done :: Bool
}
data XPConfig =
XPC { font :: String
, bgColor :: String
, fgColor :: String
, fgHLight :: String
, bgHLight :: String
, borderColor :: String
, promptBorderWidth :: !Dimension
, position :: XPPosition
, height :: !Dimension
, historySize :: !Int
, historyFilter :: [String] -> [String]
, promptKeymap :: M.Map (KeyMask,KeySym) (XP ())
, completionKey :: KeySym
, defaultText :: String
, autoComplete :: Maybe Int
, showCompletionOnTab :: Bool
, searchPredicate :: String -> String -> Bool
}
data XPType = forall p . XPrompt p => XPT p
instance Show XPType where
show (XPT p) = showXPrompt p
instance XPrompt XPType where
showXPrompt = show
nextCompletion (XPT t) = nextCompletion t
commandToComplete (XPT t) = commandToComplete t
completionToCommand (XPT t) = completionToCommand t
class XPrompt t where
showXPrompt :: t -> String
nextCompletion :: t -> String -> [String] -> String
nextCompletion = getNextOfLastWord
commandToComplete :: t -> String -> String
commandToComplete _ = getLastWord
completionToCommand :: t -> String -> String
completionToCommand _ c = c
data XPPosition = Top
| Bottom
deriving (Show,Read)
amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig
defaultXPConfig =
XPC { font = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"
, bgColor = "grey22"
, fgColor = "grey80"
, fgHLight = "black"
, bgHLight = "grey"
, borderColor = "white"
, promptBorderWidth = 1
, promptKeymap = defaultXPKeymap
, completionKey = xK_Tab
, position = Bottom
, height = 18
, historySize = 256
, historyFilter = id
, defaultText = []
, autoComplete = Nothing
, showCompletionOnTab = False
, searchPredicate = isPrefixOf
}
greenXPConfig = defaultXPConfig { fgColor = "green", bgColor = "black", promptBorderWidth = 0 }
amberXPConfig = defaultXPConfig { fgColor = "#ca8f2d", bgColor = "black", fgHLight = "#eaaf4c" }
type ComplFunction = String -> IO [String]
initState :: XPrompt p => Display -> Window -> Window -> Rectangle -> ComplFunction
-> GC -> XMonadFont -> p -> [String] -> XPConfig -> KeyMask -> XPState
initState d rw w s compl gc fonts pt h c nm =
XPS { dpy = d
, rootw = rw
, win = w
, screen = s
, complWin = Nothing
, complWinDim = Nothing
, completionFunction = compl
, showComplWin = not (showCompletionOnTab c)
, gcon = gc
, fontS = fonts
, xptype = XPT pt
, commandHistory = W.Stack { W.focus = defaultText c
, W.up = []
, W.down = h }
, offset = length (defaultText c)
, config = c
, successful = False
, done = False
, numlockMask = nm
}
command :: XPState -> String
command = W.focus . commandHistory
setCommand :: String -> XPState -> XPState
setCommand xs s = s { commandHistory = (commandHistory s) { W.focus = xs }}
setInput :: String -> XP ()
setInput = modify . setCommand
getInput :: XP String
getInput = gets command
mkXPromptWithReturn :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X a) -> X (Maybe a)
mkXPromptWithReturn t conf compl action = do
XConf { display = d, theRoot = rw } <- ask
s <- gets $ screenRect . W.screenDetail . W.current . windowset
hist <- io readHistory
w <- io $ createWin d rw conf s
io $ selectInput d w $ exposureMask .|. keyPressMask
gc <- io $ createGC d w
io $ setGraphicsExposures d gc False
fs <- initXMF (font conf)
numlock <- gets $ X.numberlockMask
let hs = fromMaybe [] $ M.lookup (showXPrompt t) hist
st = initState d rw w s compl gc fs (XPT t) hs conf numlock
st' <- io $ execStateT runXP st
releaseXMF fs
io $ freeGC d gc
if successful st'
then do
let prune = take (historySize conf)
io $ writeHistory $ M.insertWith
(\xs ys -> prune . historyFilter conf $ xs ++ ys)
(showXPrompt t)
(prune $ historyFilter conf [command st'])
hist
Just <$> action (command st')
else return Nothing
mkXPrompt :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt t conf compl action = mkXPromptWithReturn t conf compl action >> 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)
cleanMask :: KeyMask -> XP KeyMask
cleanMask msk = do
numlock <- gets numlockMask
let highMasks = 1 `shiftL` 12 1
return (complement (numlock .|. lockMask) .&. msk .&. highMasks)
handle :: KeyStroke -> Event -> XP ()
handle ks@(sym,_) e@(KeyEvent {ev_event_type = t, ev_state = m}) = do
complKey <- gets $ completionKey . config
c <- getCompletions
when (length c > 1) $ modify (\s -> s { showComplWin = True })
if complKey == sym
then completionHandle c ks e
else when (t == keyPress) $ keyPressHandle m ks
handle _ (ExposeEvent {ev_window = w}) = do
st <- get
when (win st == w) updateWindows
handle _ _ = return ()
completionHandle :: [String] -> KeyStroke -> Event -> XP ()
completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = do
complKey <- gets $ completionKey . config
case () of
() | t == keyPress && sym == complKey ->
do
st <- get
let updateState l =
let new_command = nextCompletion (xptype st) (command st) l
in modify $ \s -> setCommand new_command $ s { offset = length new_command }
updateWins l = redrawWindows l >>
eventLoop (completionHandle l)
case c of
[] -> updateWindows >> eventLoop handle
[x] -> updateState [x] >> getCompletions >>= updateWins
l -> updateState l >> updateWins l
| t == keyRelease && sym == complKey -> eventLoop (completionHandle c)
| otherwise -> keyPressHandle m ks
completionHandle _ k e = handle k e
tryAutoComplete :: XP Bool
tryAutoComplete = do
ac <- gets (autoComplete . config)
case ac of
Just d -> do cs <- getCompletions
case cs of
[c] -> runCompleted c d >> return True
_ -> return False
Nothing -> return False
where runCompleted cmd delay = do
st <- get
let new_command = nextCompletion (xptype st) (command st) [cmd]
modify $ setCommand "autocompleting..."
updateWindows
io $ threadDelay delay
modify $ setCommand new_command
return True
defaultXPKeymap :: M.Map (KeyMask,KeySym) (XP ())
defaultXPKeymap = M.fromList $
map (first $ (,) controlMask)
[ (xK_u, killBefore)
, (xK_k, killAfter)
, (xK_a, startOfLine)
, (xK_e, endOfLine)
, (xK_y, pasteString)
, (xK_Right, moveWord Next)
, (xK_Left, moveWord Prev)
, (xK_Delete, killWord Next)
, (xK_BackSpace, killWord Prev)
, (xK_w, killWord Prev)
, (xK_g, quit)
, (xK_bracketleft, quit)
] ++
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, quit)
]
keyPressHandle :: KeyMask -> KeyStroke -> XP ()
keyPressHandle m (ks,str) = do
km <- gets (promptKeymap . config)
kmask <- cleanMask m
case M.lookup (kmask,ks) km of
Just action -> action >> updateWindows
Nothing -> case str of
"" -> eventLoop handle
_ -> when (kmask .&. controlMask == 0) $ do
insertString (decodeString str)
updateWindows
completed <- tryAutoComplete
when completed $ setSuccess True >> setDone True
setSuccess :: Bool -> XP ()
setSuccess b = modify $ \s -> s { successful = b }
setDone :: Bool -> XP ()
setDone b = modify $ \s -> s { done = b }
quit :: XP ()
quit = flushString >> setSuccess False >> setDone True
killBefore :: XP ()
killBefore =
modify $ \s -> setCommand (drop (offset s) (command s)) $ s { offset = 0 }
killAfter :: XP ()
killAfter =
modify $ \s -> setCommand (take (offset s) (command s)) s
killWord :: Direction1D -> XP ()
killWord d = do
o <- gets offset
c <- gets command
let (f,ss) = splitAt o c
delNextWord w =
case w of
' ':x -> x
word -> snd . break isSpace $ word
delPrevWord = reverse . delNextWord . reverse
(ncom,noff) =
case d of
Next -> (f ++ delNextWord ss, o)
Prev -> (delPrevWord f ++ ss, length $ delPrevWord f)
modify $ \s -> setCommand ncom $ s { offset = noff}
endOfLine :: XP ()
endOfLine =
modify $ \s -> s { offset = length (command s)}
startOfLine :: XP ()
startOfLine =
modify $ \s -> s { offset = 0 }
flushString :: XP ()
flushString = modify $ \s -> setCommand "" $ s { offset = 0}
insertString :: String -> XP ()
insertString str =
modify $ \s -> setCommand (c (command s) (offset s)) $ s { offset = o (offset s)}
where o oo = oo + length str
c oc oo | oo >= length oc = oc ++ str
| otherwise = f ++ str ++ ss
where (f,ss) = splitAt oo oc
pasteString :: XP ()
pasteString = join $ io $ liftM insertString getSelection
deleteString :: Direction1D -> XP ()
deleteString d =
modify $ \s -> setCommand (c (command s) (offset s)) $ s { offset = o (offset s)}
where o oo = if d == Prev then max 0 (oo 1) else oo
c oc oo
| oo >= length oc && d == Prev = take (oo 1) oc
| oo < length oc && d == Prev = take (oo 1) f ++ ss
| oo < length oc && d == Next = f ++ tail ss
| otherwise = oc
where (f,ss) = splitAt oo oc
moveCursor :: Direction1D -> XP ()
moveCursor d =
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)
moveWord :: Direction1D -> XP ()
moveWord d = do
c <- gets command
o <- gets offset
let (f,ss) = splitAt o c
lenToS = length . fst . break isSpace
ln p s = case p s of
' ':x -> 1 + lenToS x
x -> lenToS x
newoff = case d of
Prev -> o ln reverse f
Next -> o + ln id ss
modify $ \s -> s { offset = newoff }
moveHistory :: (W.Stack String -> W.Stack String) -> XP ()
moveHistory f = modify $ \s -> let ch = f $ commandHistory s
in s { commandHistory = ch
, offset = length $ W.focus ch }
updateWindows :: XP ()
updateWindows = do
d <- gets dpy
drawWin
c <- getCompletions
case c of
[] -> destroyComplWin >> return ()
l -> redrawComplWin l
io $ sync d False
redrawWindows :: [String] -> XP ()
redrawWindows c = do
d <- gets dpy
drawWin
case c of
[] -> return ()
l -> redrawComplWin l
io $ sync d False
createWin :: Display -> Window -> XPConfig -> Rectangle -> IO Window
createWin d rw c s = do
let (x,y) = case position c of
Top -> (0,0)
Bottom -> (0, rect_height s height c)
w <- mkUnmanagedWindow d (defaultScreenOfDisplay d) rw
(rect_x s + x) (rect_y s + fi y) (rect_width s) (height c)
mapWindow d w
return w
drawWin :: XP ()
drawWin = do
st <- get
let (c,(d,(w,gc))) = (config &&& dpy &&& win &&& gcon) st
scr = defaultScreenOfDisplay d
wh = widthOfScreen scr
ht = height c
bw = promptBorderWidth c
Just bgcolor <- io $ initColor d (bgColor c)
Just border <- io $ initColor d (borderColor c)
p <- io $ createPixmap d w wh ht
(defaultDepthOfScreen scr)
io $ fillDrawable d p gc border bgcolor (fi bw) wh ht
printPrompt p
io $ copyArea d p w gc 0 0 wh ht 0 0
io $ freePixmap d p
printPrompt :: Drawable -> XP ()
printPrompt drw = do
st <- get
let (gc,(c,(d,fs))) = (gcon &&& config &&& dpy &&& fontS) st
(prt,(com,off)) = (show . xptype &&& command &&& offset) st
str = prt ++ com
(f,p,ss) = if off >= length com
then (str, " ","")
else let (a,b) = (splitAt off com)
in (prt ++ a, [head b], tail b)
ht = height c
fsl <- io $ textWidthXMF (dpy st) fs f
psl <- io $ textWidthXMF (dpy st) fs p
(asc,desc) <- io $ textExtentsXMF fs str
let y = fi $ ((ht fi (asc + desc)) `div` 2) + fi asc
x = (asc + desc) `div` 2
let draw = printStringXMF d drw fs gc
draw (fgColor c) (bgColor c) x y f
draw (bgColor c) (fgColor c) (x + fromIntegral fsl) y p
draw (fgColor c) (bgColor c) (x + fromIntegral (fsl + psl)) y ss
getCompletions :: XP [String]
getCompletions = do
s <- get
io $ completionFunction s (commandToComplete (xptype s) (command s))
`catch` \(SomeException _) -> return []
setComplWin :: Window -> ComplWindowDim -> XP ()
setComplWin w wi =
modify (\s -> s { complWin = Just w, complWinDim = Just wi })
destroyComplWin :: XP ()
destroyComplWin = do
d <- gets dpy
cw <- gets complWin
case cw of
Just w -> do io $ destroyWindow d w
modify (\s -> s { complWin = Nothing, complWinDim = Nothing })
Nothing -> return ()
type ComplWindowDim = (Position,Position,Dimension,Dimension,Columns,Rows)
type Rows = [Position]
type Columns = [Position]
createComplWin :: ComplWindowDim -> XP Window
createComplWin wi@(x,y,wh,ht,_,_) = do
st <- get
let d = dpy st
scr = defaultScreenOfDisplay d
w <- io $ mkUnmanagedWindow d scr (rootw st)
x y wh ht
io $ mapWindow d w
setComplWin w wi
return w
getComplWinDim :: [String] -> XP ComplWindowDim
getComplWinDim compl = do
st <- get
let (c,(scr,fs)) = (config &&& screen &&& fontS) st
wh = rect_width scr
ht = height c
tws <- mapM (textWidthXMF (dpy st) fs) compl
let max_compl_len = fromIntegral ((fi ht `div` 2) + maximum tws)
columns = max 1 $ wh `div` fi max_compl_len
rem_height = rect_height scr ht
(rows,r) = length compl `divMod` fi columns
needed_rows = max 1 (rows + if r == 0 then 0 else 1)
actual_max_number_of_rows = rem_height `div` ht
actual_rows = min actual_max_number_of_rows (fi needed_rows)
actual_height = actual_rows * ht
(x,y) = case position c of
Top -> (0,ht)
Bottom -> (0, (0 + rem_height actual_height))
(asc,desc) <- io $ textExtentsXMF fs $ head compl
let yp = fi $ (ht + fi (asc desc)) `div` 2
xp = (asc + desc) `div` 2
yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]
xx = take (fi columns) [xp,(xp + max_compl_len)..]
return (rect_x scr + x, rect_y scr + fi y, wh, actual_height, xx, yy)
drawComplWin :: Window -> [String] -> XP ()
drawComplWin w compl = do
st <- get
let c = config st
d = dpy st
scr = defaultScreenOfDisplay d
bw = promptBorderWidth c
gc = gcon st
Just bgcolor <- io $ initColor d (bgColor c)
Just border <- io $ initColor d (borderColor c)
(_,_,wh,ht,xx,yy) <- getComplWinDim compl
p <- io $ createPixmap d w wh ht
(defaultDepthOfScreen scr)
io $ fillDrawable d p gc border bgcolor (fi bw) wh ht
let ac = splitInSubListsAt (length yy) (take (length xx * length yy) compl)
printComplList d p gc (fgColor c) (bgColor c) xx yy ac
io $ copyArea d p w gc 0 0 wh ht 0 0
io $ freePixmap d p
redrawComplWin :: [String] -> XP ()
redrawComplWin compl = do
st <- get
nwi <- getComplWinDim compl
let recreate = do destroyComplWin
w <- createComplWin nwi
drawComplWin w compl
if compl /= [] && showComplWin st
then case complWin st of
Just w -> case complWinDim st of
Just wi -> if nwi == wi
then drawComplWin w compl
else recreate
Nothing -> recreate
Nothing -> recreate
else destroyComplWin
printComplList :: Display -> Drawable -> GC -> String -> String
-> [Position] -> [Position] -> [[String]] -> XP ()
printComplList d drw gc fc bc xs ys sss =
zipWithM_ (\x ss ->
zipWithM_ (\y s -> do
st <- get
let (f,b) = if completionToCommand (xptype st) s == commandToComplete (xptype st) (command st)
then (fgHLight $ config st,bgHLight $ config st)
else (fc,bc)
printStringXMF d drw (fontS st) gc f b x y s)
ys ss) xs sss
type History = M.Map String [String]
emptyHistory :: History
emptyHistory = M.empty
getHistoryFile :: IO FilePath
getHistoryFile = fmap (++ "/history") $ getAppUserDataDirectory "xmonad"
readHistory :: IO History
readHistory = readHist `catch` \(SomeException _) -> return emptyHistory
where
readHist = do
path <- getHistoryFile
xs <- bracket (openFile path ReadMode) hClose hGetLine
readIO xs
writeHistory :: History -> IO ()
writeHistory hist = do
path <- getHistoryFile
let filtered = M.filter (not . null) hist
writeFile path (show filtered) `catch` \(SomeException e) ->
hPutStrLn stderr ("error writing history: "++show e)
setFileMode path mode
where mode = ownerReadMode .|. ownerWriteMode
fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
-> Dimension -> Dimension -> Dimension -> IO ()
fillDrawable d drw gc border bgcolor bw wh ht = do
setForeground d gc border
fillRectangle d drw gc 0 0 wh ht
setForeground d gc bgcolor
fillRectangle d drw gc (fi bw) (fi bw) (wh (bw * 2)) (ht (bw * 2))
mkUnmanagedWindow :: Display -> Screen -> Window -> Position
-> Position -> Dimension -> Dimension -> IO Window
mkUnmanagedWindow d s rw x y w h = do
let visual = defaultVisualOfScreen s
attrmask = cWOverrideRedirect
allocaSetWindowAttributes $
\attributes -> do
set_override_redirect attributes True
createWindow d rw x y w h 0 (defaultDepthOfScreen s)
inputOutput visual attrmask attributes
mkComplFunFromList :: [String] -> String -> IO [String]
mkComplFunFromList _ [] = return []
mkComplFunFromList l s =
return $ filter (\x -> take (length s) x == s) l
mkComplFunFromList' :: [String] -> String -> IO [String]
mkComplFunFromList' l [] = return l
mkComplFunFromList' l s =
return $ filter (\x -> take (length s) x == s) l
getNextOfLastWord :: XPrompt t => t -> String -> [String] -> String
getNextOfLastWord t c l = skipLastWord c ++ completionToCommand t (l !! ni)
where ni = case commandToComplete t c `elemIndex` map (completionToCommand t) l of
Just i -> if i >= length l 1 then 0 else i + 1
Nothing -> 0
getNextCompletion :: String -> [String] -> String
getNextCompletion c l = l !! idx
where idx = case c `elemIndex` l of
Just i -> if i >= length l 1 then 0 else i + 1
Nothing -> 0
splitInSubListsAt :: Int -> [a] -> [[a]]
splitInSubListsAt _ [] = []
splitInSubListsAt i x = f : splitInSubListsAt i rest
where (f,rest) = splitAt i x
getLastWord :: String -> String
getLastWord = reverse . fst . breakAtSpace . reverse
skipLastWord :: String -> String
skipLastWord = reverse . snd . breakAtSpace . reverse
breakAtSpace :: String -> (String, String)
breakAtSpace s
| " \\" `isPrefixOf` s2 = (s1 ++ " " ++ s1', s2')
| otherwise = (s1, s2)
where (s1, s2 ) = break isSpace s
(s1',s2') = breakAtSpace $ tail s2
historyCompletion :: ComplFunction
historyCompletion = historyCompletionP (const True)
historyCompletionP :: (String -> Bool) -> ComplFunction
historyCompletionP p x = fmap (toComplList . M.filterWithKey (const . p)) readHistory
where toComplList = deleteConsecutive . filter (isInfixOf x) . M.fold (++) []
uniqSort :: Ord a => [a] -> [a]
uniqSort = toList . fromList
deleteAllDuplicates, deleteConsecutive :: [String] -> [String]
deleteAllDuplicates = nub
deleteConsecutive = map head . group
newtype HistoryMatches = HistoryMatches (IORef ([String],Maybe (W.Stack String)))
initMatches :: (Functor m, MonadIO m) => m HistoryMatches
initMatches = HistoryMatches <$> liftIO (newIORef ([],Nothing))
historyNextMatching :: HistoryMatches -> (W.Stack String -> W.Stack String) -> XP ()
historyNextMatching hm@(HistoryMatches ref) next = do
(completed,completions) <- io $ readIORef ref
input <- getInput
if input `elem` completed
then case completions of
Just cs -> do
let cmd = W.focus cs
modify $ setCommand cmd
modify $ \s -> s { offset = length cmd }
io $ writeIORef ref (cmd:completed,Just $ next cs)
Nothing -> return ()
else do
io . writeIORef ref . ((,) [input]) . filterMatching input =<< gets commandHistory
historyNextMatching hm next
where filterMatching :: String -> W.Stack String -> Maybe (W.Stack String)
filterMatching prefix = W.filter (prefix `isPrefixOf`) . next
historyUpMatching, historyDownMatching :: HistoryMatches -> XP ()
historyUpMatching hm = historyNextMatching hm W.focusDown'
historyDownMatching hm = historyNextMatching hm W.focusUp'