[Xmonad] what about a prompt?
Andrea Rossato
mailing_list at istitutocolli.org
Wed Aug 1 14:26:49 EDT 2007
Hi,
what about a prompt? A general one, to be use to run internal xmonad
command, to run shell commands, or to run ssh, etc...
With completions, possibly.
This what I'm working to. Some previous Ion3 users will find it
similar to some of their memories.
It is not finished yet, this is why I'm not sending it as a patch, but
I'm almost there. I did not think it was going to take such a long
time - 3 days now (well, I'm not only coding, I'm also trying to enjoy
my vacation. Lake, mountains, etc....-)
But you can have an idea, and hopefully give suggestions too: save the
attached file in XMonadContrib as Prompt.hs.
Import it from Config.hs and add some key bindings to lunch the
prompts.
For instance:
, ((modMask .|. controlMask, xK_x), xmonadPrompt defaultPromptConfig)
, ((modMask .|. controlMask.|. shiftMask, xK_x), shellPrompt defaultPromptConfig)
So far only a shell prompt and an internal commands prompt
(xmonadPrompt) are provided (and only the first one with - still
unusable - completions).
Suggestions, patches, good wishes are welcome.
Andrea
PS: the guys at suckless dot something say that dmenu is less then 500
lines of code. I'm still below 500 too, with all the extra features.
Some stuff needs to be added, but there is a lot of stuff we could get
rid of. The code could not be so verbose, but that's one of my
problems. Not Haskell's.
-------------- next part --------------
-----------------------------------------------------------------------------
-- |
-- Module : XMonadContrib.Commands
-- Copyright : (C) 2007 Andrea Rossato
-- License : BSD3
--
-- Maintainer : andrea.rossato at unibz.it
-- Stability : unstable
-- Portability : unportable
--
-- A prompt for XMonad
--
-----------------------------------------------------------------------------
module XMonadContrib.Prompt (
-- * Usage
-- $usage
startPrompt
, defaultPromptConfig
, XPType (..)
, XPPosition (..)
, XPConfig (..)
) where
{-
usage:
in Config.hs add:
> import XMonadContrib.Prompt
in you keybindings add:
> , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultPromptConfig)
> , ((modMask .|. controlMask.|. shiftMask, xK_x), shellPrompt defaultPromptConfig)
-}
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import XMonad hiding (io)
import Operations
import XMonadContrib.Commands
--import Control.Monad
--import Control.Concurrent
import Control.Monad.Reader
import Control.Monad.State
import Data.Bits
import Data.Char
import Data.Maybe
import Data.List
import System.Console.Readline
import System.Environment
type XP = StateT XPState IO
data XPState =
XPS { dpy :: Display
, rootw :: Window
, win :: Window
, complWin :: Maybe Window
, gcon :: GC
, fs :: FontStruct
, xptype :: XPType
, command :: String
, offset :: Int
, config :: XPConfig
} deriving (Show)
data XPConfig =
XPC { font :: String -- ^ Font
, bgColor :: String -- ^ Backgroud color
, fgColor :: String -- ^ Default font color
, borderColor :: String -- ^
, borderWidth :: Dimension
, position :: XPPosition
, height :: Dimension -- ^ Window height
} deriving (Show, Read)
data XPType = Shell | XMonad
deriving (Read)
instance Show XPType where
show Shell = "Run: "
show XMonad = "XMonad: "
data XPPosition = Top | Bottom
deriving (Show,Read)
defaultPromptConfig :: XPConfig
defaultPromptConfig =
XPC { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
, bgColor = "#999999"
, fgColor = "#FFFFFF"
, borderColor = "#FFFFFF"
, borderWidth = 1
, position = Bottom
, height = 18
}
initState :: Display -> Window -> Window -> GC
-> FontStruct -> XPType -> XPConfig-> XPState
initState d rw w gc f pt c =
XPS d rw w Nothing gc f pt "" 0 c
shellPrompt :: XPConfig -> X ()
shellPrompt c = startPrompt Shell c
xmonadPrompt :: XPConfig -> X ()
xmonadPrompt c = startPrompt XMonad c
startPrompt :: XPType -> XPConfig -> X ()
startPrompt t conf = do
c <- ask
let d = display c
rw = theRoot c
w <- liftIO $ createWin d rw conf
liftIO $ selectInput d w $ exposureMask .|. keyPressMask
gc <- liftIO $ createGC d w
liftIO $ setGraphicsExposures d gc False
fontS <- liftIO $ loadQueryFont d (font conf)
let st = initState d rw w gc fontS t conf
st' <- liftIO $ execStateT runXP st
liftIO $ freeGC d gc
liftIO $ freeFont d fontS
case t of
XMonad -> runCommand' $ command st'
Shell -> spawn $ command st'
runXP :: XP ()
runXP = do
st <- get
let d = dpy st
w = win st
status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime
when (status == grabSuccess) $ do
updateWin
io $ ungrabKeyboard d currentTime
io $ destroyWindow d w
destroyComplWin
io $ sync d False
eventLoop :: XP ()
eventLoop = do
d <- gets dpy
-- FIXME
--st <- get
--io $ putStrLn $ "offset = " ++ show (offset st) ++ "str: " ++ (prompt st ++ command st)
(keysym,string,event) <- io $
allocaXEvent $ \e -> do
nextEvent d e
ev <- getEvent e
-- FIXME
--putStrLn $ eventName ev
(ks,s) <- lookupString $ asKeyEvent e
return (ks,s,ev)
handle (fromMaybe xK_VoidSymbol keysym,string) event
type KeyStroke = (KeySym, String)
-- Main event handler
handle :: KeyStroke -> Event -> XP ()
handle ks (KeyEvent {ev_event_type = t, ev_state = m})
| t == keyPress = do
keyPressHandle m ks
handle _ (AnyEvent {ev_event_type = t, ev_window = w})
| t == expose = do
st <- get
when (win st == w) updateWin
handle _ _ = eventLoop
-- KeyPresses
data Direction = Prev | Next deriving (Eq,Show,Read)
keyPressHandle :: KeyMask -> KeyStroke -> XP ()
-- commands: ctrl + ... todo
keyPressHandle mask (ks,s)
| mask == controlMask = do
-- TODO
eventLoop
keyPressHandle _ (ks,_)
-- exit
| ks == xK_Return = do
return ()
-- backspace
| ks == xK_BackSpace = do
deleteString Prev
updateWin
-- delete
| ks == xK_Delete = do
deleteString Next
updateWin
-- left
| ks == xK_Left = do
moveCursor Prev
updateWin
-- right
| ks == xK_Right = do
moveCursor Next
updateWin
-- exscape: exit and discard everything
| ks == xK_Escape = do
flushString
return ()
-- tab -> completion loop
| ks == xK_Tab = do
--completionLoop
eventLoop
-- insert a character
keyPressHandle _ (_,s)
| s == "" = eventLoop
| otherwise = do
insertString s
updateWin
-- KeyPress and State
-- flush the command and reset the offest
flushString :: XP ()
flushString =
modify (\s -> s { command = "", offset = 0} )
-- insert a character at the cursor position
insertString :: String -> XP ()
insertString str =
modify (\s -> s { command = c (command s) (offset 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
-- remove a character at the cursor position
deleteString :: Direction -> XP ()
deleteString d =
modify (\s -> s { command = c (command s) (offset 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
-- move the cursor one position
moveCursor :: Direction -> 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)
-- X Stuff
createWin :: Display -> Window -> XPConfig -> IO Window
createWin d rw c = do
let scr = defaultScreenOfDisplay d
wh = widthOfScreen scr
(x,y) = case position c of
Top -> (0,0)
Bottom -> (0,heightOfScreen scr - (height c))
w <- mkUnmanagedWindow d scr rw
x (fi y) wh (height c)
mapWindow d w
return w
updateWin :: XP ()
updateWin = do
d <- gets dpy
destroyComplWin
drawWin
io $ sync d False
eventLoop
drawWin :: XP ()
drawWin = do
st <- get
let c = config st
d = dpy st
scr = defaultScreenOfDisplay d
w = win st
wh = widthOfScreen scr
ht = height c
bw = borderWidth c
gc = gcon st
fontStruc = fs st
bgcolor <- io $ initColor d (bgColor c)
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 gc fontStruc
compl <- case xptype st of
Shell -> io $ getCompletions (command st)
XMonad -> return []
when (compl /= []) (drawComplWin compl)
io $ copyArea d p w gc 0 0 wh ht 0 0
io $ freePixmap d p
printPrompt :: Drawable -> GC -> FontStruct -> XP ()
printPrompt drw gc fontst = do
c <- gets config
st <- get
let d = dpy st
(prt,com,off) = (show $ xptype st, command st, offset st)
str = prt ++ com
-- scompose the string in 3 part: till the cursor, the cursor and the rest
(f,p,ss) = if off >= length com
then (str, " ","") -- add a space: it will be our cursor ;-)
else let (a,b) = (splitAt off com)
in (prt ++ a, [head b], tail b)
ht = height c
(fsl,psl) = (textWidth fontst f, textWidth fontst p)
(_,asc,desc,_) = textExtents fontst str
y = fi $ (ht + fi (asc + desc)) `div` 2
x = (asc + desc) `div` 2
fgcolor <- io $ initColor d $ fgColor c
bgcolor <- io $ initColor d $ bgColor c
-- print the first part
io $ printString d drw gc fgcolor bgcolor x y f
-- reverse the colors and print the "cursor" ;-)
io $ printString d drw gc bgcolor fgcolor (x + fsl) y p
-- reverse the colors and print the rest of the string
io $ printString d drw gc fgcolor bgcolor (x + fsl + psl) y ss
setComplWin :: Window -> XP ()
setComplWin w = do
modify (\s -> s { complWin = Just w })
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 })
Nothing -> return ()
drawComplWin :: [String] -> XP ()
drawComplWin compl = do
st <- get
let c = config st
d = dpy st
scr = defaultScreenOfDisplay d
wh = widthOfScreen scr
ht = height c
bw = borderWidth c
gc = gcon st
fontst = fs st
bgcolor <- io $ initColor d (bgColor c)
fgcolor <- io $ initColor d (fgColor c)
border <- io $ initColor d (borderColor c)
let compl_number = length compl
max_compl_len = (fi ht `div` 2) + (maximum . map (textWidth fontst) $ compl)
columns = wh `div` (fi max_compl_len)
rem_height = heightOfScreen scr - ht
needed_rows = max 1 (compl_number `div` fi columns)
needed_height = needed_rows * fi ht
actual_max_number_of_rows = rem_height `div` ht
actual_completions = if needed_height > fi rem_height
then take (fi (actual_max_number_of_rows * columns)) compl
else compl
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))
w <- io $ mkUnmanagedWindow d scr (rootw st)
x (fi y) wh actual_height
io $ mapWindow d w
setComplWin w
io $ fillDrawable d w gc border bgcolor (fi bw) wh actual_height
-- creating a table of completions...;-)
let (_,asc,desc,_) = textExtents fontst $ head compl
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)..]
ac = spliInSubListsAt (fi actual_rows) actual_completions
-- printing the table of completion
io $ printComplList d w gc fgcolor bgcolor xx yy ac
printComplList :: Display -> Drawable -> GC -> Pixel -> Pixel
-> [Position] -> [Position] -> [[String]] -> IO ()
printComplList _ _ _ _ _ _ _ [] = return ()
printComplList _ _ _ _ _ [] _ _ = return ()
printComplList d drw gc fc bc (x:xs) y (s:ss) = do
printComplColumn d drw gc fc bc x y s
printComplList d drw gc fc bc xs y ss
printComplColumn :: Display -> Drawable -> GC -> Pixel -> Pixel
-> Position -> [Position] -> [String] -> IO ()
printComplColumn _ _ _ _ _ _ _ [] = return ()
printComplColumn _ _ _ _ _ _ [] _ = return ()
printComplColumn d drw gc fc bc x (y:yy) (s:ss) = do
printString d drw gc fc bc x y s
printComplColumn d drw gc fc bc x yy ss
-- More general X Stuff
printString :: Display -> Drawable -> GC -> Pixel -> Pixel
-> Position -> Position -> String -> IO ()
printString d drw gc fc bc x y s = do
setForeground d gc fc
setBackground d gc bc
drawImageString d drw gc x y s
fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
-> Dimension -> Dimension -> Dimension -> IO ()
fillDrawable d drw gc border bgcolor bw wh ht = do
-- we strat with the border
setForeground d gc border
fillRectangle d drw gc 0 0 wh ht
-- this foreground is the background of the text!
setForeground d gc bgcolor
fillRectangle d drw gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2))
-- | Creates a window with the attribute override_redirect set to True.
-- Windows Managers should not touch this kind of windows.
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
-- Utilities
-- completions
getCompletions :: String -> IO [String]
getCompletions s
| s /= "" && last s /= ' ' = do
fl <- filenameCompletionFunction (last . words $ s)
c <- commandCompletionFunction (last . words $ s)
return $ sort . nub $ fl ++ c
| otherwise = return []
commandCompletionFunction :: String -> IO [String]
commandCompletionFunction str
| '/' `elem` str = return []
| otherwise = do
p <- getEnv "PATH"
cl p
where
cl = liftM (nub . rmPath . concat) . mapM fCF . map addToPath . split ':'
addToPath = flip (++) ("/" ++ str)
fCF = filenameCompletionFunction
rmPath [] = []
rmPath s = map (last . split '/') s
-- Lift an IO action into the XP
io :: IO a -> XP a
io = liftIO
-- shorthand
fi :: (Num b, Integral a) => a -> b
fi = fromIntegral
split :: Eq a => a -> [a] -> [[a]]
split _ [] = []
split e l =
f : split e (rest ls)
where
(f,ls) = span (/=e) l
rest s | s == [] = []
| otherwise = tail s
spliInSubListsAt :: Int -> [a] -> [[a]]
spliInSubListsAt _ [] = []
spliInSubListsAt i x = f : spliInSubListsAt i rest
where (f,rest) = splitAt i x
More information about the Xmonad
mailing list