diff --git a/GSMenu/Pick.hs b/GSMenu/Pick.hs --- a/GSMenu/Pick.hs +++ b/GSMenu/Pick.hs @@ -30,6 +30,8 @@ , pop ) where +import Codec.Binary.UTF8.String (decodeString) + import Data.Maybe import Data.Bits import Data.Char @@ -71,7 +73,7 @@ , el_tags :: [String] } -type TwoDElement a = (TwoDPosition, Element (TwoD a (Maybe a))) +type TwoDElement a = (TwoDPosition, Element a) type TwoDElementMap a = [TwoDElement a] data ElemPane = ElemPane { @@ -119,7 +121,6 @@ data FilterState a = FilterState { fl_filter :: Filter - , fl_elmap :: TwoDElementMap a , fl_elms :: [Element a] } @@ -162,16 +163,7 @@ return $ fromMaybe allelms $ fl_elms <$> listToMaybe (td_filters s) elementMap :: TwoD a (TwoDElementMap a) -elementMap = do - s <- get - elmap <- asks td_elmap - return $ fromMaybe elmap $ fl_elmap <$> listToMaybe (td_filters s) - -elementGrid :: [Element a] -> TwoD a (TwoDElementMap a) -elementGrid elms = flip zip (map select elms) <$> asks td_scaffold - -select :: Element a -> Element (TwoD a (Maybe a)) -select elm = elm { el_data = return $ Just $ el_data elm } +elementMap = liftM2 zip (asks td_scaffold) elements diamondLayer :: (Enum b', Num b') => b' -> [(b', b')] diamondLayer 0 = [(0,0)] @@ -192,6 +184,9 @@ findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b) findInElementMap pos = find ((== pos) . fst) +textHeight :: GSMenuFont -> String -> IO Dimension +textHeight font = liftM (fi . uncurry (+)) . textExtentsXMF font + shrinkWhile :: Monad m => ([a] -> [[a]]) -> ([a] -> m Bool) -> [a] -> m [a] @@ -203,8 +198,11 @@ then sw ns else return n -textHeight :: GSMenuFont -> String -> IO Dimension -textHeight font = liftM (fi . uncurry (+)) . textExtentsXMF font +stopText :: Display -> GSMenuFont -> Dimension -> String -> IO String +stopText dpy f mw = + shrinkWhile (reverse . inits) + (\n -> do size <- textWidthXMF dpy f n + return $ size > fi mw) drawWinBox :: Window -> (String, String) -> String -> [String] @@ -225,22 +223,18 @@ (sheight, subs') = fromMaybe (0, []) $ find ((<=room) . fst) (zip sheights $ reverse $ inits sub) - stext f = shrinkWhile (reverse . inits) - (\n -> do size <- textWidthXMF dpy f n - return $ size > fi (cw-fi (2*cp))) - x' = fi (x+fi cp) - y' = fi (y+(fi ch-fi sheight-fi theight) `div` 2) - putline f voff (h, s) = do - s' <- stext f s - printStringXMF dpy win f (ep_textgc ep) fg bg x' (voff+fi h) s' - return h - _ <- putline font y' (theight, text) - foldM_ (putline subfont) (y'+fi theight) $ zip (map fi sheights) subs' + x' = fi (x+fi cp) :: Position + y' = y+(fi ch-fi sheight-fi theight) `div` 2 + fi theight :: Position + ys = scanl1 (+) $ map ((+y') . fi) sheights + putline f voff s = do + stopText dpy f (cw-fi (2*cp)) s >>= + printStringXMF dpy win f (ep_textgc ep) fg bg x' voff + _ <- putline font y' text + zipWithM_ (putline subfont) ys subs' drawBoxMask :: Display -> GC -> Pixmap -> Position -> Position -> Dimension -> Dimension -> IO () -drawBoxMask dpy gc pm x y w h = do - setForeground dpy gc 1 +drawBoxMask dpy gc pm x y w h = fillRectangle dpy pm gc x y w h getGC :: Drawable -> String -> TwoD a GC @@ -339,11 +333,9 @@ pushFilter :: Filter -> TwoD a () pushFilter f = do elms' <- apply f <$> elements - elmap <- elementGrid elms' modify $ \s -> s { td_filters = FilterState { fl_filter = f - , fl_elms = elms' - , fl_elmap = elmap } : td_filters s } + , fl_elms = elms' } : td_filters s } popFilter :: TwoD a () popFilter = @@ -473,9 +465,14 @@ (ks,s) <- if ev_event_type ev == keyPress then lookupString $ asKeyEvent e else return (Nothing, "") - return (ks,s,ev) + return (ks,decodeString s,ev) -- XXX, relies on s being UTF-8 encoded. handle (fromMaybe xK_VoidSymbol keysym,string) event +selectAt :: TwoDPosition -> TwoD a (Maybe a) +selectAt pos = + lookup pos <$> elementMap >>= + maybe eventLoop (return . Just . el_data) + cleanMask :: KeyMask -> KeyMask cleanMask km = complement (numLockMask .|. lockMask) .&. km @@ -485,12 +482,8 @@ handle :: (KeySym, String) -> Event -> TwoD a (Maybe a) handle (ks,s) (KeyEvent {ev_event_type = t, ev_state = m }) | t == keyPress && ks == xK_Escape = return Nothing - | t == keyPress && ks == xK_Return = do - pos <- gets td_curpos - elmap <- elementMap - case lookup pos elmap of - Nothing -> eventLoop - Just elm -> maybe eventLoop (return . Just) =<< el_data elm + | t == keyPress && ks == xK_Return = + selectAt =<< gets td_curpos | t == keyPress = do keymap <- asks (gp_keymap . td_gpconfig) fromMaybe unbound $ M.lookup (m',ks) keymap @@ -501,17 +494,13 @@ handle _ (ButtonEvent { ev_event_type = t, ev_x = x, ev_y = y }) | t == buttonRelease = do - elmap <- elementMap ch <- asks (gp_cellheight . td_gpconfig) cw <- asks (gp_cellwidth . td_gpconfig) w <- asks (ep_width . td_elempane) h <- asks (ep_height . td_elempane) let gridX = fi $ (fi x - (w - cw) `div` 2) `div` cw gridY = fi $ (fi y - (h - ch) `div` 2) `div` ch - case lookup (gridX,gridY) elmap of - Nothing -> eventLoop - Just elm -> - maybe eventLoop (return . Just) =<< el_data elm + selectAt (gridX, gridY) | otherwise = eventLoop handle _ (ExposeEvent { ev_count = 0 }) = redrawAllElements >> eventLoop @@ -633,11 +622,10 @@ let restriction ss cs = (ss/fi (cs gpconfig)-1)/2 :: Double restrictX = floor $ restriction (fi rwidth) gp_cellwidth restrictY = floor $ restriction (fi rheight) gp_cellheight - originPosX = floor $ (gp_originFractX gpconfig - (1/2)) * 2 * fromIntegral restrictX - originPosY = floor $ (gp_originFractY gpconfig - (1/2)) * 2 * fromIntegral restrictY + originPosX = floor $ (gp_originFractX gpconfig - (1/2)) * 2 * fi restrictX + originPosY = floor $ (gp_originFractY gpconfig - (1/2)) * 2 * fi restrictY coords = diamondRestrict restrictX restrictY originPosX originPosY - boxelms = map select ellist - elmap = zip coords boxelms + elmap = zip coords ellist (selectedElement, s) <- runTwoD (do updateTextInput redrawAllElements eventLoop) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -24,7 +24,7 @@ import Graphics.X11.Xlib hiding (refreshKeyboardMapping) import Graphics.X11.Xinerama -import System.Console.GetOpt +import System.Console.GetFlag import System.Environment import System.Exit import System.IO @@ -124,12 +124,6 @@ type GSMenuOption a = OptDescr (AppConfig a -> IO (AppConfig a)) -options :: [GSMenuOption a] -options = [optHelp, optVersion, optDisplay, optComplex, optEnumResult, - optFont, optSubFont, optInputFont, - optCellHeight, optCellWidth, optCellPadding, - optOriginX, optOriginY] - inGPConfig :: (String -> GPConfig a -> GPConfig a) -> String -> AppConfig a -> IO (AppConfig a) inGPConfig f arg cfg = return $ cfg { cfg_gpconfig = f arg (cfg_gpconfig cfg) } @@ -145,87 +139,64 @@ readFloat :: (Fractional a, Read a) => String -> a readFloat = tryRead $ (++ " is not a decimal fraction.") . quote -optHelp :: GSMenuOption a -optHelp = Option "h" ["help"] - (NoArg $ \_ -> do - hPutStrLn stderr =<< usageStr - exitSuccess) - "Display this help screen." - usageStr :: IO String usageStr = do prog <- getProgName - let header = "Help for " ++ prog ++ " " ++ versionString + let header = "Help for " ++ prog ++ " " ++ versionStr return $ usageInfo header options - -optVersion :: GSMenuOption a -optVersion = Option "v" ["version"] - (NoArg $ \_ -> do - hPutStrLn stderr ("gsmenu " ++ versionString ++ ".") - hPutStrLn stderr "Copyright (C) Troels Henriksen." - exitSuccess) - "Print version number." - -versionString :: String -versionString = "1.1" - -optDisplay :: GSMenuOption a -optDisplay = Option "d" ["display"] - (ReqArg (\arg cfg -> return $ cfg { cfg_display = arg }) "dpy" ) - "Specify the X display to connect to." - -optComplex :: GSMenuOption a -optComplex = Option "c" ["complex"] - (NoArg (\cfg -> return $ cfg { cfg_complex = True }) ) - "Use complex input format." -optEnumResult :: GSMenuOption a -optEnumResult = Option "e" ["enumerate"] - (NoArg (\cfg -> return $ cfg { cfg_enumerate = True }) ) - "Print the result as the (zero-indexed) element number." - -optCellHeight :: GSMenuOption a -optCellHeight = Option [] ["cellheight"] - (ReqArg (inGPConfig $ \arg gpc -> - gpc { gp_cellheight = readInt arg }) "height") - "The height of each element cell" - -optCellWidth :: GSMenuOption a -optCellWidth = Option [] ["cellwidth"] - (ReqArg (inGPConfig $ \arg gpc -> - gpc { gp_cellwidth = readInt arg }) "width") - "The width of each element cell" - -optCellPadding :: GSMenuOption a -optCellPadding = Option [] ["cellpadding"] - (ReqArg (inGPConfig $ \arg gpc -> - gpc { gp_cellpadding = readInt arg }) "padding") - "The inner padding of each element cell." - -optFont :: GSMenuOption a -optFont = Option [] ["font"] - (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_font = arg }) "font") - "The font used for printing names of elements." - -optSubFont :: GSMenuOption a -optSubFont = Option [] ["subfont"] - (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_subfont = arg}) "font") - "The font used for printing extra lines in elements." - -optInputFont :: GSMenuOption a -optInputFont = Option [] ["inputfont"] - (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_inputfont = arg}) "font") - "The font used for the input field." +versionStr :: String +versionStr = "2.0" -optOriginX :: GSMenuOption a -optOriginX = Option "x" [] - (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_originFractX = readFloat arg }) "float") - "The horizontal center of the grid, range [0,1]." - -optOriginY :: GSMenuOption a -optOriginY = Option "y" [] - (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_originFractY = readFloat arg }) "float") - "The vertical center of the grid, range [0,1]" +options :: [GSMenuOption a] +options = [ Option "h" (NoArg $ \_ -> do + hPutStrLn stderr =<< usageStr + exitSuccess) + "Display this help screen." + , Option "v" (NoArg $ \_ -> do + hPutStrLn stderr ("gsmenu " ++ versionStr ++ ".") + hPutStrLn stderr "Copyright (C) Troels Henriksen." + exitSuccess) + "Print version number." + , Option "c" + (NoArg (\cfg -> return $ cfg { cfg_complex = True })) + "Use complex input format." + , Option "e" + (NoArg (\cfg -> return $ cfg { cfg_enumerate = True })) + "Print the result as the (zero-indexed) element number." + , Option "cellheight" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_cellheight = readInt arg }) "height") + "The height of each element cell" + , Option "cellwidth" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_cellwidth = readInt arg }) "width") + "The width of each element cell" + , Option "cellpadding" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_cellpadding = readInt arg }) "padding") + "The inner padding of each element cell." + , Option "font" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_font = arg }) "font") + "The font used for printing names of elements." + , Option "subfont" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_subfont = arg}) "font") + "The font used for printing extra lines in elements." + , Option "inputfont" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_inputfont = arg}) "font") + "The font used for the input field." + , Option "x" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_originFractX = readFloat arg }) "float") + "The horizontal center of the grid, range [0,1]." + , Option "y" + (ReqArg (inGPConfig $ \arg gpc -> + gpc { gp_originFractY = readFloat arg }) "float") + "The vertical center of the grid, range [0,1]" + ] parseElements :: SourceName -> String -> Either ParseError [Element a] parseElements = parse $ many element <* eof diff --git a/gsmenu.1 b/gsmenu.1 --- a/gsmenu.1 +++ b/gsmenu.1 @@ -1,32 +1,29 @@ -.TH GSMENU 1 gsmenu\-1.1 +.TH GSMENU 1 gsmenu\-2.0 .SH NAME gsmenu \- grid menu .SH SYNOPSIS .nh gsmenu -[\fB\-d=\fIdisplay\fR] [\fB\-c\fR] [\fB\-e\fR] -[\fB\-\-cellheight \fIheight\fR] -[\fB\-\-cellwidth \fIwidth\fR\fR] -[\fB\-\-cellpadding \fIpadding\fR] +[\fB\-cellheight \fIheight\fR] +[\fB\-cellwidth \fIwidth\fR\fR] +[\fB\-cellpadding \fIpadding\fR] [\fB\-x \fIposition\fR] [\fB\-y \fIposition\fR] -[\fB\-\-font=\fIfont\fR] -[\fB\-\-subfont=\fIfont\fR] -[\fB\-\-inputfont=\fIfont\fR] +[\fB\-font \fIfont\fR] +[\fB\-subfont \fIfont\fR] +[\fB\-inputfont \fIfont\fR] [\fB\-h\fR] [\fB\-v\fR] .SH DESCRIPTION .SS Overview gsmenu is a generic grid menu for X11, originally a port of the GridSelect contrib for XMonad. It displays elements as a grid of -rectangular cells. +rectangular cells. gsmenu always contacts the display indicated in +the DISPLAY environment variable. .SS Options .TP -.B \-d -specifies the X server to contact. -.TP .B \-c makes gsmenu accept complex input format (see below). .TP @@ -34,13 +31,13 @@ print the selected item as an index into the (0-indexed) sequence of input elements. .TP -.B \-\-cellheight +.B \-cellheight The height of each cell in pixels. .TP -.B \-\-cellwidth +.B \-cellwidth The width of each cell in pixels. .TP -.B \-\-cellpadding +.B \-cellpadding The inner text padding of each cell in pixels. .TP .B \-x @@ -50,16 +47,16 @@ .B \-y As \fB\-x\fR, but sets the vertical position. .TP -.B \-\-font +.B \-font The first line of elements is printed in this font. Both traditional X11-font-strings and XFT-fonts are accepted, the latter when prefixed with "xft:" (for example "xft:URW Bookman L-10"). .TP -.B \-\-subfont -As \-\-font, but used for secondary lines of elements. +.B \-subfont +As \-font, but used for secondary lines of elements. .TP -.B \-\-inputfont -As \-\-font, but affects the user input text field. +.B \-inputfont +As \-font, but affects the user input text field. .TP .B \-h prints command option summary to standard output, then exits. diff --git a/gsmenu.cabal b/gsmenu.cabal --- a/gsmenu.cabal +++ b/gsmenu.cabal @@ -1,6 +1,6 @@ name: gsmenu -version: 1.1 -homepage: http://sigkill.dk +version: 2.0 +homepage: http://sigkill.dk/programs/gsmenu synopsis: A visual generic menu description: Standalone port of XMonadContrib's GridSelect. @@ -16,10 +16,10 @@ description: Use Xft to render text executable gsmenu - build-depends: X11>=1.5.0.0 && < 1.6, X11-xshape>=0.1.1, mtl, base==4.*, containers, parsec==3.* + build-depends: X11>=1.5.0.0 && < 1.6, X11-xshape>=0.1.1, mtl, base==4.*, containers, parsec==3.*, getflag, utf8-string if flag(use_xft) - build-depends: X11-xft >= 0.2, utf8-string + build-depends: X11-xft >= 0.2 extensions: ForeignFunctionInterface cpp-options: -DXFT main-is: Main.hs diff --git a/gsmenu_path b/gsmenu_path --- a/gsmenu_path +++ b/gsmenu_path @@ -27,7 +27,7 @@ cd "$dir" && for file in * do - test -x "$file" && echo "name=\"$file\" $tags" + test -x "$file" && echo "name=\"$(echo $file|sed 's/"/""/g')\" \"$dir\" $tags" done done | sort | uniq > "$CACHE".$$ && mv "$CACHE".$$ "$CACHE"