diff --git a/GSMenu/Config.hs b/GSMenu/Config.hs new file mode 100644 --- /dev/null +++ b/GSMenu/Config.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GSMenu.Config +-- Author : Troels Henriksen +-- License : MIT-style (see LICENSE) +-- +-- Stability : stable +-- Portability : unportable +-- +-- Default bindings and settings for easy editing +-- +----------------------------------------------------------------------------- + +module GSMenu.Config + ( defaultGPConfig + , defaultGPNav + ) where + +import qualified Data.Map as M + +import Graphics.X11.Xlib + +import GSMenu.Pick + + +defaultGPConfig :: GPConfig a +defaultGPConfig = GPConfig { + gp_bordercolor = "white" + , gp_cellheight = 50 + , gp_cellwidth = 130 + , gp_cellpadding = 10 + , gp_font = "xft:Sans-8" + , gp_inputfont = "xft:Monospace-14" + , gp_keymap = defaultGPNav + , gp_originFractX = 1/2 + , gp_originFractY = 1/2 + } + +defaultGPNav :: KeyMap a +defaultGPNav = M.fromList + [ ((0,xK_Left) ,move (-1,0)) + , ((controlMask,xK_b) ,move (-1,0)) + , ((0,xK_Right) ,move (1,0)) + , ((controlMask,xK_f) ,move (1,0)) + , ((0,xK_Down) ,move (0,1)) + , ((controlMask,xK_n) ,move (0,1)) + , ((0,xK_Up) ,move (0,-1)) + , ((controlMask,xK_p) ,move (0,-1)) + , ((0,xK_BackSpace) ,backspace) + , ((controlMask,xK_o) ,exclude) + , ((controlMask,xK_i) ,include) + , ((controlMask,xK_s) ,next) + , ((controlMask,xK_r) ,prev) + , ((controlMask,xK_a) ,beg) + , ((controlMask,xK_e) ,end) + , ((controlMask,xK_w) ,pop) + ] diff --git a/GSMenu/Font.hsc b/GSMenu/Font.hsc new file mode 100644 --- /dev/null +++ b/GSMenu/Font.hsc @@ -0,0 +1,205 @@ +---------------------------------------------------------------------------- +-- | +-- Module : GSMenu.Font +-- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for abstracting a font facility over Core fonts and Xft +-- Taken from XMonad.Util.Font. +-- +----------------------------------------------------------------------------- + +module GSMenu.Font + ( -- * Usage: + -- $usage + GSMenuFont(..) + , initColor + , initXMF + , releaseXMF + , initCoreFont + , releaseCoreFont + , initUtf8Font + , releaseUtf8Font + , Align (..) + , stringPosition + , textWidthXMF + , textExtentsXMF + , printStringXMF + , stringToPixel + , decodeInput + , encodeOutput + ) where + +import Foreign +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Data.Maybe + +#ifdef XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +import Graphics.X11 +import Graphics.X11.Xlib.Extras + +import Codec.Binary.UTF8.String (encodeString, decodeString) + +import GSMenu.Util + + +-- Hide the Core Font/Xft switching here +data GSMenuFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- | Get the 'Pixel' value for a named color +initColor :: Display -> String -> IO (Maybe Pixel) +initColor dpy c = catch + (Just . color_pixel . fst <$> allocNamedColor dpy colormap c) + (const $ return Nothing) + where colormap = defaultColormap dpy (defaultScreen dpy) + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel +stringToPixel d s = fromMaybe fallBack <$> io getIt + where getIt = initColor d s + fallBack = blackPixel d (defaultScreen d) + + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: MonadIO m => Display -> String -> m FontStruct +initCoreFont dpy s = do + io $ catch getIt fallBack + where getIt = loadQueryFont dpy s + fallBack = const $ loadQueryFont dpy "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseCoreFont :: MonadIO m => Display -> FontStruct -> m () +releaseCoreFont dpy fs = do + io $ freeFont dpy fs + +initUtf8Font :: MonadIO m => Display -> String -> m FontSet +initUtf8Font dpy s = do + (_,_,fs) <- io $ catch getIt fallBack + return fs + where getIt = createFontSet dpy s + fallBack = const $ createFontSet dpy "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseUtf8Font :: MonadIO m => Display -> FontSet -> m () +releaseUtf8Font dpy fs = do + io $ freeFontSet dpy fs + +-- | When initXMF gets a font name that starts with 'xft:' it switches to the Xft backend +-- Example: 'xft: Sans-10' +initXMF :: MonadIO m => Display -> String -> m GSMenuFont +initXMF dpy s = +#ifdef XFT + if xftPrefix `isPrefixOf` s then + do xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) + return (Xft xftdraw) + else +#endif + liftM Utf8 $ initUtf8Font dpy s +#ifdef XFT + where xftPrefix = "xft:" +#endif + +releaseXMF :: MonadIO m => Display -> GSMenuFont -> m () +#ifdef XFT +releaseXMF dpy (Xft xftfont) = do + io $ xftFontClose dpy xftfont +#endif +releaseXMF dpy (Utf8 fs) = releaseUtf8Font dpy fs +releaseXMF dpy (Core fs) = releaseCoreFont dpy fs + + +textWidthXMF :: MonadIO m => Display -> GSMenuFont -> String -> m Int +textWidthXMF _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s +#ifdef XFT +textWidthXMF dpy (Xft xftdraw) s = liftIO $ do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtentsXMF :: MonadIO m => GSMenuFont -> String -> m (Int32,Int32) +textExtentsXMF (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +textExtentsXMF (Core fs) s = do + let (_,a,d,_) = textExtents fs s + return (a,d) +#ifdef XFT +textExtentsXMF (Xft xftfont) _ = io $ do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft | AlignRightOffset Int + deriving (Show, Read) + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: (Functor m, MonadIO m) => Display -> GSMenuFont -> Rectangle -> Align -> String -> m (Position,Position) +stringPosition dpy fs (Rectangle _ _ w h) al s = do + width <- textWidthXMF dpy fs s + (a,d) <- textExtentsXMF fs s + let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)); + AlignRightOffset offset -> fi (w - (fi width + 1)) - fi offset; + return (x,y) + +printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable + -> GSMenuFont -> GC -> String -> String + -> Position -> Position -> String -> m () +printStringXMF d p (Core fs) gc fc bc x y s = io $ do + setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s +printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s +#ifdef XFT +printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + bcolor <- stringToPixel dpy bc + (a,d) <- textExtentsXMF fs s + gi <- io $ xftTextExtents dpy font s + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi a) + (fi $ xglyphinfo_xOff gi) + (fi $ a + d) + io $ withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x y s +#endif + +decodeInput :: String -> String +decodeInput = decodeString + +encodeOutput :: String -> String +encodeOutput = encodeString diff --git a/GSMenu/Pick.hs b/GSMenu/Pick.hs new file mode 100644 --- /dev/null +++ b/GSMenu/Pick.hs @@ -0,0 +1,680 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : GSMenu.Pick +-- Author : Troels Henriksen +-- License : MIT-style (see LICENSE) +-- +-- Stability : stable +-- Portability : unportable +-- +-- The main display and selection logic. +-- +----------------------------------------------------------------------------- + +module GSMenu.Pick + ( GPConfig(..) + , Element(..) + , KeyMap + , TwoDPosition + , gpick + + , move + , next + , prev + , beg + , end + , backspace + , include + , exclude + , pop + ) where + +import Data.Maybe +import Data.Bits +import Data.Char +import Data.Ord +import Control.Applicative +import Control.Monad.State +import Control.Monad.Reader +import Data.List as L +import qualified Data.Map as M + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xshape + +import GSMenu.Font +import GSMenu.Util + +data GPConfig a = GPConfig { + gp_bordercolor :: String + , gp_cellheight :: Dimension + , gp_cellwidth :: Dimension + , gp_cellpadding :: Dimension + , gp_font :: String + , gp_inputfont :: String + , gp_keymap :: KeyMap a + , gp_originFractX :: Double + , gp_originFractY :: Double +} + +type KeyMap a = M.Map (KeyMask,KeySym) (TwoD a ()) + +type TwoDPosition = (Integer, Integer) +data Element a = Element { + el_colors :: (String, String) + , el_data :: a + , el_disp :: String + , el_tags :: [String] + } + +type TwoDElement a = (TwoDPosition, Element (TwoD a (Maybe a))) +type TwoDElementMap a = [TwoDElement a] + +data ElemPane = ElemPane { + ep_width :: Dimension + , ep_height :: Dimension + , ep_win :: Window + , ep_shapemask :: Pixmap + , ep_maskgc :: GC + , ep_unmaskgc :: GC + , ep_textgc :: GC + } + +type TextBuffer = String + +data TextPane a = TextPane { + tp_win :: Window + , tp_bggc :: GC + , tp_fcolors :: TwoDElementMap a -> (String, String) + , tp_fieldgc :: GC + , tp_font :: GSMenuFont + , tp_lowerleft :: (Position, Position) + , tp_width :: Dimension + } + +data Filter = Include String + | Exclude String + | Running String + +passes :: Filter -> Element a -> Bool +passes (Include s) elm = + any (isInfixOf $ downcase s) fields + where fields = map downcase (el_disp elm : el_tags elm) +passes (Exclude s) elm = not $ passes (Include s) elm +passes (Running s) elm = passes (Include s) elm + +apply :: Filter -> [Element a] -> [Element a] +apply f = filter $ passes f + +isRunning :: Filter -> Bool +isRunning (Running _) = True +isRunning _ = False + +data FilterState a = FilterState { + fl_filter :: Filter + , fl_elmap :: TwoDElementMap a + , fl_elms :: [Element a] + } + +data TwoDState a = TwoDState { + td_curpos :: TwoDPosition + , td_colorcache :: M.Map (String, String) + (GC, String, String) + , td_tbuffer :: TextBuffer + , td_filters :: [FilterState a] + } + +data TwoDConf a = TwoDConf { + td_elempane :: ElemPane + , td_textpane :: TextPane a + , td_gpconfig :: GPConfig a + , td_display :: Display + , td_screen :: Screen + , td_font :: GSMenuFont + , td_elms :: [Element a] + , td_elmap :: TwoDElementMap a + } + +newtype TwoD a b = TwoD (StateT (TwoDState a) + (ReaderT (TwoDConf a) IO) b) + deriving (Monad, Functor, MonadState (TwoDState a), + MonadReader (TwoDConf a), MonadIO) + +instance Applicative (TwoD a) where + (<*>) = ap + pure = return + +evalTwoD :: TwoD a b -> TwoDState a -> TwoDConf a -> IO b +evalTwoD (TwoD m) s c = runReaderT (evalStateT m s) c + +elements :: TwoD a [Element a] +elements = do + s <- get + allelms <- asks td_elms + 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 = do + gpconfig <- asks td_gpconfig + rwidth <- asks (ep_width . td_elempane) + rheight <- asks (ep_height . td_elempane) + 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 + coords = diamondRestrict restrictX restrictY originPosX originPosY + return (zip coords $ map select elms) + +select :: Element a -> Element (TwoD a (Maybe a)) +select elm = elm { el_data = return $ Just $ el_data elm } + +diamondLayer :: (Enum b', Num b') => b' -> [(b', b')] +diamondLayer 0 = [(0,0)] +diamondLayer n = concat [ zip [0..] [n,n-1..1] + , zip [n,n-1..1] [0,-1..] + , zip [0,-1..] [-n..(-1)] + , zip [-n..(-1)] [0,1..] ] + +diamond :: (Enum a, Num a) => [(a, a)] +diamond = concatMap diamondLayer [0..] + +diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [TwoDPosition] +diamondRestrict x y originX originY = + L.filter (\(x',y') -> abs x' <= x && abs y' <= y) . + map (\(x', y') -> (x' + originX, y' + originY)) . + take 1000 $ diamond + +findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b) +findInElementMap pos = find ((== pos) . fst) + +shrinkIt :: String -> [String] +shrinkIt "" = [""] +shrinkIt cs = cs : shrinkIt (init cs) + +shrinkWhile :: Monad m => (String -> [String]) + -> (String -> m Bool) + -> String -> m String +shrinkWhile sh p x = sw $ sh x + where sw [n] = return n + sw [] = return "" + sw (n:ns) = do cond <- p n + if cond + then sw ns + else return n + +drawWinBox :: Display -> Window -> GSMenuFont -> String + -> (String, String) -> String -> Dimension + -> Position -> Position -> Dimension -> Dimension + -> TwoD a () +drawWinBox dpy win font bc (fg,bg) text cp x y cw ch = do + (gc, fg', bg') <- procColors dpy (fg, bg) + textgc <- asks (ep_textgc . td_elempane) + io $ do + bordergc <- createGC dpy win + bordercolor <- stringToPixel dpy bc + setForeground dpy bordergc bordercolor + fillRectangle dpy win gc x y cw ch + drawRectangle dpy win bordergc x y cw ch + stext <- shrinkWhile shrinkIt + (\n -> do size <- textWidthXMF dpy font n + return $ size > fi (cw-fi (2*cp))) + text + printStringXMF dpy win font textgc fg' bg' + (fi (x+fi cp)) (fi (y+fi (div ch 2))) stext + freeGC dpy bordergc + +drawBoxMask :: Display -> GC -> Pixmap -> Position + -> Position -> Dimension -> Dimension -> IO () +drawBoxMask dpy gc pm x y w h = do + setForeground dpy gc 1 + fillRectangle dpy pm gc x y w h + +procColors :: Display -> (String, String) -> TwoD a (GC, String, String) +procColors dpy col@(fg, bg) = do + gcs <- gets td_colorcache + case M.lookup col gcs of + Just x -> return x + Nothing -> do + x <- procColors' + modify $ \s -> s { td_colorcache = M.insert col x gcs } + return x + where procColors' = do + screen <- asks td_screen + win <- asks (ep_win . td_elempane) + let wp = whitePixelOfScreen screen + bp = blackPixelOfScreen screen + badcol gc x = do err $ "Bad color " ++ x + setBackground dpy gc bp + setForeground dpy gc wp + return (gc, "black", "white") + io $ do + gc <- io $ createGC dpy win + fgc <- initColor dpy fg + bgc <- initColor dpy bg + case (fgc, bgc) of + (Just fgc', Just bgc') -> do + setBackground dpy gc fgc' + setForeground dpy gc bgc' + return (gc, fg, bg) + (Nothing, _) -> badcol gc fg + (_, Nothing) -> badcol gc bg + +updatingBoxes :: (TwoDElement a + -> Position -> Position + -> Dimension -> Dimension + -> TwoD a ()) + -> TwoDElementMap a -> TwoD a () +updatingBoxes f els = do + cellwidth <- asks (gp_cellwidth . td_gpconfig) + cellheight <- asks (gp_cellheight . td_gpconfig) + ElemPane { ep_width = w + , ep_height = h + } <- asks td_elempane + let w' = div (w-cellwidth) 2 + h' = div (h-cellheight) 2 + proc el@((x,y), _) = + f el (fi $ fi w'+x*fi cellwidth) + (fi $ fi h'+y*fi cellheight) + (fi cellwidth) (fi cellheight) + mapM_ proc els + +redrawAllElements :: TwoD a () +redrawAllElements = do + els <- elementMap + dpy <- asks td_display + ElemPane { ep_width = pw + , ep_height = ph + , ep_win = win + , ep_shapemask = pm + , ep_maskgc = maskgc + , ep_unmaskgc = unmaskgc } <- asks td_elempane + io $ fillRectangle dpy pm maskgc 0 0 pw ph + let drawbox _ x y w h = io $ drawBoxMask dpy unmaskgc pm x y (w+1) (h+1) + updatingBoxes drawbox els + io $ xshapeCombineMask dpy win shapeBounding 0 0 pm shapeSet + redrawElements els + +redrawElements :: TwoDElementMap a -> TwoD a () +redrawElements elementmap = do + dpy <- asks td_display + font <- asks td_font + bc <- asks (gp_bordercolor . td_gpconfig) + padding <- asks (gp_cellpadding . td_gpconfig) + win <- asks (ep_win . td_elempane) + curpos <- gets td_curpos + let update ((x,y),Element { el_colors = colors + , el_disp = text }) = do + drawWinBox dpy win font bc colors' text padding + where colors' | curpos == (x,y) = + ("black", "#faff69") + | otherwise = colors + updatingBoxes update elementmap + +updateTextInput :: TwoD a () +updateTextInput = do + dpy <- asks td_display + TextPane { tp_bggc = bggc, tp_win = win, tp_font = font + , tp_lowerleft = (x, y), tp_width = w, tp_fieldgc = fgc + , tp_fcolors = fcolors } + <- asks td_textpane + text <- buildStr <$> gets (map fl_filter . td_filters) + elmap <- elementMap + (a,d) <- textExtentsXMF font text + let h = max mh $ fi $ a + d + (fg, bg) = fcolors elmap + io $ do moveResizeWindow dpy win x (y-fi h) w h + fillRectangle dpy win bggc 0 0 w h + setForeground dpy fgc =<< stringToPixel dpy bg + fillRectangle dpy win fgc margin 0 50 h + printStringXMF dpy win font fgc fg bg margin (fi a) text + where mh = 1 + margin = 20 + buildStr (Exclude str:fs) = buildStr fs ++ "¬" ++ str ++ "/" + buildStr (Include str:fs) = buildStr fs ++ str ++ "/" + buildStr (Running str:fs) = buildStr fs ++ take 1 (reverse str) + buildStr _ = "" + +changingState :: TwoD a b -> TwoD a b +changingState f = + f <* modify (\s -> s { td_curpos = (0,0) }) + <* redrawAllElements + <* updateTextInput + +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 } + +popFilter :: TwoD a () +popFilter = + modify $ \s -> s { td_filters = drop 1 (td_filters s) } + +topFilter :: TwoD a (Maybe Filter) +topFilter = do + s <- get + case td_filters s of + (f:_) -> return $ Just $ fl_filter f + _ -> return Nothing + +input :: String -> TwoD a () +input "" = return () +input str = changingState $ do + f <- topFilter + let str' = case f of + Just (Running x) -> x ++ str + _ -> str + pushFilter $ Running str' + +backspace :: TwoD a () +backspace = do + f <- topFilter + case f of + Nothing -> return () + Just (Running _) -> changingState popFilter + Just (Exclude str) -> changingState $ runnings str + Just (Include str) -> changingState $ runnings str + where runnings str = do + popFilter + mapM_ (pushFilter . Running) $ drop 1 $ inits str + +solidify :: (String -> Filter) -> TwoD a () +solidify ff = changingState $ do + f <- topFilter + case f of + Just (Running str) -> do + modify $ \s -> s { td_filters = dropRunning $ td_filters s } + pushFilter (ff str) + _ -> return () + where dropRunning = dropWhile (isRunning . fl_filter) + +exclude :: TwoD a () +exclude = solidify Exclude + +include :: TwoD a () +include = solidify Include + +move :: TwoDPosition -> TwoD a () +move (dx, dy) = do + state <- get + elmap <- elementMap + let (ox, oy) = td_curpos state + newPos = (ox+dx, oy+dy) + newSelectedEl = findInElementMap newPos elmap + when (isJust newSelectedEl) $ do + put state { td_curpos = newPos } + redrawElements + (catMaybes [ findInElementMap (ox, oy) elmap + , newSelectedEl]) + +moveTo :: TwoDPosition -> TwoD a () +moveTo (nx, ny) = do + (x,y) <- gets td_curpos + move (nx-x, ny-y) + +dist :: TwoDPosition -> Integer +dist (x,y) = abs x + abs y + +visibleRing :: TwoDElementMap a -> Integer -> [TwoDPosition] +visibleRing elmap r = + diamondLayer (r `mod` (maxdist + 1)) `intersect` (map fst elmap) + where maxdist = foldr (max . dist . fst) 0 elmap + +skipalong :: ([TwoDPosition] -> TwoDPosition) + -> (Integer -> Integer) + -> ([TwoDPosition] -> TwoDPosition) + -> (([TwoDPosition], [TwoDPosition]) -> TwoDPosition) + -> TwoD a () +skipalong pf nif sf nf = do + pos <- gets td_curpos + elmap <- elementMap + let d = dist pos + circle = visibleRing elmap d + pos' + | pos == pf circle = + sf $ visibleRing elmap $ nif d + | otherwise = + nf $ break (==pos) circle + moveTo pos' + +next :: TwoD a () +next = skipalong last (+1) jump forward + where jump (p:_) = p + jump _ = (0,0) + forward (_, _:p:_) = p + forward _ = (0,0) + +prev :: TwoD a () +prev = skipalong head (+(-1)) jump forward + where jump [] = (0,0) -- will never happen + jump l = last l + forward ([], _) = (0,0) + forward (l, _) = last l + +lineMove :: ((TwoDPosition -> TwoDPosition -> Ordering) + -> [TwoDPosition] -> TwoDPosition) + -> TwoD a () +lineMove f = do + (_,y) <- gets td_curpos + elmap <- elementMap + let row = filter ((==y) . snd) $ map fst elmap + moveTo $ f (comparing $ fst) row + +beg :: TwoD a () +beg = lineMove minimumBy + +end :: TwoD a () +end = lineMove maximumBy + +pop :: TwoD a () +pop = do + f <- topFilter + case f of + Just (Running _) -> changingState $ pop' + Just _ -> changingState popFilter + _ -> return () + where pop' = do + f <- topFilter + case f of + Just (Running _) -> popFilter >> pop' + _ -> return () + +eventLoop :: TwoD a (Maybe a) +eventLoop = do + dpy <- asks td_display + (keysym,string,event) <- io $ allocaXEvent $ \e -> do + nextEvent dpy e + ev <- getEvent e + (ks,s) <- if ev_event_type ev == keyPress + then lookupString $ asKeyEvent e + else return (Nothing, "") + return (ks,s,ev) + handle (fromMaybe xK_VoidSymbol keysym,string) event + +cleanMask :: KeyMask -> KeyMask +cleanMask km = complement (numLockMask + .|. lockMask) .&. km + where numLockMask :: KeyMask + numLockMask = mod2Mask + +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 -> do maybe eventLoop (return . Just) =<< el_data elm + | t == keyPress = do + keymap <- asks (gp_keymap . td_gpconfig) + maybe unbound id $ M.lookup (m',ks) $ keymap + eventLoop + where m' = cleanMask m + unbound | not $ any isControl s = input s + | otherwise = return () + +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 -> do + maybe eventLoop (return . Just) =<< el_data elm + | otherwise = eventLoop + +handle _ (ExposeEvent { ev_count = 0 }) = redrawAllElements >> eventLoop + +handle _ _ = eventLoop + +-- | 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 dpy s rw x y w h = do + let visual = defaultVisualOfScreen s + attrmask = cWOverrideRedirect + black = blackPixelOfScreen s + white = whitePixelOfScreen s + allocaSetWindowAttributes $ \attrs -> do + set_override_redirect attrs True + set_background_pixel attrs white + set_border_pixel attrs black + createWindow dpy rw x y w h 0 copyFromParent + inputOutput visual attrmask attrs + +mkElemPane :: Display -> Screen -> Rectangle -> IO ElemPane +mkElemPane dpy screen rect = do + let rootw = rootWindowOfScreen screen + rwidth = rect_width rect + rheight = rect_height rect + win <- mkUnmanagedWindow dpy screen rootw + (rect_x rect) (rect_y rect) rwidth rheight + pm <- createPixmap dpy win rwidth rheight 1 + maskgc <- createGC dpy pm + setForeground dpy maskgc 0 + fillRectangle dpy pm maskgc 0 0 rwidth rheight + xshapeCombineMask dpy win shapeBounding 0 0 pm shapeSet + unmaskgc <- createGC dpy pm + setForeground dpy unmaskgc 1 + mapWindow dpy win + selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask) + textgc <- createGC dpy rootw + return ElemPane { + ep_width = fi rwidth + , ep_height = fi rheight + , ep_win = win + , ep_shapemask = pm + , ep_maskgc = maskgc + , ep_unmaskgc = unmaskgc + , ep_textgc = textgc } + +freeElemPane :: Display -> ElemPane -> IO () +freeElemPane dpy ElemPane { ep_win = win + , ep_maskgc = maskgc + , ep_unmaskgc = unmaskgc + , ep_textgc = textgc } = do + unmapWindow dpy win + destroyWindow dpy win + mapM_ (freeGC dpy) [maskgc, unmaskgc, textgc] + sync dpy False + +fgGC :: Display -> Drawable -> (String, Pixel) -> IO GC +fgGC dpy drw (color, pixel) = do + gc <- createGC dpy drw + pix <- initColor dpy color + setForeground dpy gc $ fromMaybe pixel pix + return gc + +mkTextPane :: Display -> Screen -> Rectangle -> GPConfig a + -> IO (TextPane a) +mkTextPane dpy screen rect gpconfig = do + let rootw = rootWindowOfScreen screen + wp = whitePixelOfScreen screen + bp = blackPixelOfScreen screen + win <- mkUnmanagedWindow dpy screen rootw + (rect_x rect) (rect_y rect) 1 1 + bggc <- fgGC dpy win ("grey", wp) + fgc <- fgGC dpy win ("black", bp) + font <- initXMF dpy (gp_inputfont gpconfig) + let fcolors [] = ("white", "red") + fcolors _ = ("white", "blue") + _ <- mapRaised dpy win + return TextPane { tp_win = win + , tp_bggc = bggc + , tp_fieldgc = fgc + , tp_fcolors = fcolors + , tp_font = font + , tp_lowerleft = ( rect_x rect + , rect_y rect + fi (rect_height rect)) + , tp_width = rect_width rect } + +freeTextPane :: Display -> TextPane a -> IO () +freeTextPane dpy TextPane { tp_win = win + , tp_bggc = bggc + , tp_fieldgc = fgc} = do + unmapWindow dpy win + destroyWindow dpy win + mapM_ (freeGC dpy) [bggc, fgc] + sync dpy False + +-- | Brings up a 2D grid of elements in the center of the screen, and one can +-- select an element with cursors keys. The selected element is returned. +gpick :: Display -> Screen -> Rectangle -> GPConfig a + -> [Element a] -> IO (Either String (Maybe a)) +gpick _ _ _ _ [] = return $ Right Nothing +gpick dpy screen rect gpconfig ellist = do + let rwidth = rect_width rect + rheight = rect_height rect + ep@ElemPane { ep_win = win } <- mkElemPane dpy screen rect + tp <- mkTextPane dpy screen rect gpconfig + status <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime + grabButton dpy button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none + font <- initXMF dpy (gp_font gpconfig) + if status /= grabSuccess then return $ Left "Could not establish keyboard grab" + else do + 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 + coords = diamondRestrict restrictX restrictY originPosX originPosY + boxelms = map select ellist + elmap = zip coords boxelms + selectedElement <- evalTwoD (do updateTextInput + redrawAllElements + eventLoop) + TwoDState { td_curpos = head coords + , td_colorcache = M.empty + , td_tbuffer = "" + , td_filters = [] } + TwoDConf { td_elempane = ep + , td_textpane = tp + , td_gpconfig = gpconfig + , td_display = dpy + , td_screen = screen + , td_font = font + , td_elmap = elmap + , td_elms = ellist } + freeElemPane dpy ep + freeTextPane dpy tp + releaseXMF dpy font + return $ Right selectedElement diff --git a/GSMenu/Util.hs b/GSMenu/Util.hs new file mode 100644 --- /dev/null +++ b/GSMenu/Util.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GSMenu.Util +-- Author : Troels Henriksen +-- License : MIT-style (see LICENSE) +-- +-- Stability : stable +-- Portability : portable +-- +-- Various utility bits and pieces. +-- +----------------------------------------------------------------------------- + +module GSMenu.Util + ( io + , fi + , err + , upcase + , downcase + , hsv2rgb + ) where + +import Control.Monad.Trans + +import Data.Char + +import System.IO + +-- | Short-hand for 'liftIO' +io :: MonadIO m => IO a -> m a +io = liftIO + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +-- | Short-hand for 'liftIO . hPutStrLn stderr' +err :: MonadIO m => String -> m () +err = io . hPutStrLn stderr + +-- | Short-hand for 'map toUpper' +upcase :: String -> String +upcase = map toUpper + +-- | Short-hand for 'map toLower' +downcase :: String -> String +downcase = map toLower + +-- | Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space +hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a) +hsv2rgb (h,s,v) = + let hi = (div h 60) `mod` 6 :: Integer + f = (((fromInteger h)/60) - (fromInteger hi)) :: Fractional a => a + q = v * (1-f) + p = v * (1-s) + t = v * (1-(1-f)*s) + in case hi of + 0 -> (v,t,p) + 1 -> (q,v,p) + 2 -> (p,v,t) + 3 -> (p,q,v) + 4 -> (t,p,v) + 5 -> (v,p,q) + _ -> error "The world is ending. x mod a >= a." diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2010 Troels Henriksen + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Author : Troels Henriksen +-- License : MIT-style (see LICENSE) +-- +-- Stability : stable +-- Portability : unportable +-- +-- gsmenu, a generic grid-based menu. +-- +----------------------------------------------------------------------------- + +module Main () where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Data.Maybe +import Data.List +import Data.Word (Word8) + +import Graphics.X11.Xlib hiding (refreshKeyboardMapping) +import Graphics.X11.Xinerama + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO + +import Text.Parsec hiding ((<|>), many, optional) +import Text.Parsec.String + +import Text.Printf + +import GSMenu.Config +import GSMenu.Pick +import GSMenu.Util + +data AppConfig = AppConfig { + cfg_complex :: Bool + , cfg_display :: String + , cfg_enumerate :: Bool + } + +defaultConfig :: AppConfig +defaultConfig = AppConfig { + cfg_complex = False + , cfg_display = "" + , cfg_enumerate = False + } + +main :: IO () +main = do + opts <- getOpt RequireOrder options <$> getArgs + dstr <- getEnv "DISPLAY" `catch` (const $ return "") + let cfg = defaultConfig { cfg_display = dstr } + case opts of + (opts', [], []) -> runWithCfg =<< foldl (>>=) (return cfg) opts' + (_, nonopts, errs) -> do + mapM_ (hPutStrLn stderr) $ map ("Junk argument: " ++) nonopts + usage <- usageStr + hPutStrLn stderr $ concat errs ++ usage + exitFailure + + +options :: [OptDescr (AppConfig -> IO AppConfig)] +options = [optHelp, optVersion, optDisplay, optComplex, optEnumResult] + +optHelp :: OptDescr (AppConfig -> IO AppConfig) +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 + return $ usageInfo header options + +optVersion :: OptDescr (AppConfig -> IO AppConfig) +optVersion = Option ['v'] ["version"] + (NoArg $ \_ -> do + hPutStrLn stderr ("gsmenu " ++ versionString ++ ".") + hPutStrLn stderr "Copyright (C) Troels Henriksen." + exitSuccess) + "Print version number." + +versionString :: String +versionString = "1.0" + +optDisplay :: OptDescr (AppConfig -> IO AppConfig) +optDisplay = Option ['d'] ["display"] + (ReqArg (\arg cfg -> return $ cfg { cfg_display = arg }) "dpy" ) + "Specify the X display to connect to." + +optComplex :: OptDescr (AppConfig -> IO AppConfig) +optComplex = Option ['c'] ["complex"] + (NoArg (\cfg -> return $ cfg { cfg_complex = True }) ) + "Use complex input format." + +optEnumResult :: OptDescr (AppConfig -> IO AppConfig) +optEnumResult = Option ['e'] ["enumerate"] + (NoArg (\cfg -> return $ cfg { cfg_enumerate = True }) ) + "Print the result as the (zero-indexed) element number." + +runWithCfg :: AppConfig -> IO () +runWithCfg cfg = do + dpy <- setupDisplay $ cfg_display cfg + let screen = defaultScreenOfDisplay dpy + elems <- reader stdin valuer + rect <- findRectangle dpy (rootWindowOfScreen screen) + sel <- gpick dpy screen rect defaultGPConfig elems + case sel of + Left reason -> err reason >> exitWith (ExitFailure 1) + Right Nothing -> exitWith $ ExitFailure 2 + Right (Just el) -> putStr el >> exitSuccess + where reader + | cfg_complex cfg = readElementsC "stdin" + | otherwise = readElements + valuer + | cfg_enumerate cfg = \_ i -> show i + | otherwise = \ s _ -> s + +setupDisplay :: String -> IO Display +setupDisplay dstr = do + dpy <- openDisplay dstr `Prelude.catch` \_ -> do + error $ "Cannot open display '" ++ dstr ++ "'." + return dpy + +findRectangle :: Display -> Window -> IO Rectangle +findRectangle dpy rootw = do + (_, _, _, x, y, _, _, _) <- queryPointer dpy rootw + let hasPointer rect = fi x >= rect_x rect && + fi (rect_width rect) + rect_x rect > fi x && + fi y >= rect_y rect && + fi (rect_height rect) + rect_y rect > fi y + fromJust <$> find hasPointer <$> getScreenInfo dpy + +readElements :: MonadIO m => Handle + -> (String -> Integer -> a) + -> m [Element a] +readElements h f = do + str <- io $ hGetContents h + return $ zipWith mk (lines str) [0..] + where mk line num = Element + { el_colors = ("black", "white") + , el_data = f line num + , el_disp = line + , el_tags = [] } + +readElementsC :: MonadIO m => SourceName + -> Handle + -> (String -> Integer -> a) + -> m [Element a] +readElementsC sn h f = do + str <- io $ hGetContents h + case parseElements sn str of + Left e -> error $ show e + Right els -> return $ zipWith mk els [0..] + where mk elm num = elm { + el_data = f (el_disp elm) num } + +parseElements :: SourceName -> String -> Either ParseError [Element a] +parseElements = parse $ many element <* eof + +blankElem :: Element a +blankElem = Element { + el_colors = ("black", "white") + , el_data = error "Element without data" + , el_disp = error "Element without display" + , el_tags = [] + } + +tagColors :: [String] -> (String, String) +tagColors ts = + let seed x = toInteger (sum $ map ((*x).fromEnum) s) :: Integer + (r,g,b) = hsv2rgb ((seed 83) `mod` 360, + (fromInteger ((seed 191) `mod` 1000))/2500+0.4, + (fromInteger ((seed 121) `mod` 1000))/2500+0.4) + in ("white", "#" ++ concat (map (twodigitHex.(round :: Double -> Word8).(*256)) [r, g, b] )) + where s = show ts + +twodigitHex :: Word8 -> String +twodigitHex a = printf "%02x" a + +element :: GenParser Char u (Element a) +element = do kvs <- kvPair `sepBy1` realSpaces <* spaces + let (fg, bg) = tagColors $ tags kvs + foldM procKv blankElem { el_colors = (fg, bg) } kvs + where tags (("tags",ts):ls) = ts ++ tags ls + tags ((_,_):ls) = tags ls + tags [] = [] + procKv elm ("name", [val]) = + return elm { el_disp = val } + procKv _ ("name", _) = badval "name" + procKv elm ("fg", [val]) = + return elm { + el_colors = (val, snd $ el_colors elm) } + procKv _ ("fg", _) = badval "fg" + procKv elm ("bg", [val]) = + return elm { + el_colors = (fst $ el_colors elm, val) } + procKv _ ("bg", _) = badval "bg" + procKv elm ("tags",val) = + return elm { el_tags = el_tags elm ++ filter (/="") val } + procKv _ (k, _) = nokey k + badval k = parserFail $ "Bad value for field " ++ k + nokey k = parserFail $ "Unknown key " ++ k + +kvPair :: GenParser Char u (String, [String]) +kvPair = do + pure (,) <*> (many1 alphaNum <* realSpaces <* char '=' <* realSpaces) + <*> many1 (value <* realSpaces) + +value :: GenParser Char u String +value = char '"' *> escapedStr + +escapedStr :: GenParser Char u String +escapedStr = do + s <- many $ noneOf "\"\n" + ( try (string "\"\"" *> pure ((s++"\"")++) <*> escapedStr) + <|> try (string "\"" *> return s)) + +realSpaces :: GenParser Char u String +realSpaces = many $ char ' ' diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,26 @@ +`gsmenu` - a generic visual menu +================================ + +`gsmenu` is a program that reads a list of entries from standard input +(one per line) and provides a visual, grid-based interface from which +the user can select one, with either mouse or keyboard. The manual +page contains full documentation. + +Installation +------------ + +Assuming a working Cabal install, just do 'cabal install'. Any +missing dependencies will automatically be downloaded and installed. +You may have to perform a 'cabal update' first to ensure that your +package list is up to date. + +Inspiration +----------- + +This program is mostly a port of the GridSelect contrib for XMonad by +Clemens Fruhwirth. + +Bugs +---- + +Please report any found bugs to the maintainer at . diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,58 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple.Setup (CopyDest(..),ConfigFlags(..),BuildFlags(..), + CopyFlags(..),RegisterFlags(..),InstallFlags(..), + defaultRegisterFlags,fromFlagOrDefault,Flag(..), + defaultCopyFlags) +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo + (LocalBuildInfo(..),absoluteInstallDirs) +import Distribution.Simple.Configure (configCompilerAux) +import Distribution.PackageDescription (PackageDescription(..)) +import Distribution.Simple.InstallDirs + (InstallDirs(..)) +import Distribution.Simple.Program + (Program(..),ConfiguredProgram(..),ProgramConfiguration(..), + ProgramLocation(..),simpleProgram,lookupProgram, + rawSystemProgramConf) +import Distribution.Simple.Utils +import Distribution.Verbosity +import Data.Char (isSpace, showLitChar) +import Data.List (isSuffixOf,isPrefixOf) +import Data.Maybe (listToMaybe,isJust) +import Data.Version +import Control.Monad (when,unless) +import Text.ParserCombinators.ReadP (readP_to_S) +import System.Exit +import System.IO (hGetContents,hClose,hPutStr,stderr) +import System.IO.Error (try) +import System.Process (runInteractiveProcess,waitForProcess) +import System.Posix +import System.Directory +import System.Info (os) +import System.FilePath + +main = defaultMainWithHooks gsmenuHooks +gsmenuHooks = simpleUserHooks { postInst = gsmenuPostInst + , postCopy = gsmenuPostCopy } + +gsmenu = "gsmenu" + +isWindows :: Bool +isWindows = os == "mingw" -- XXX + +gsmenuPostInst a (InstallFlags { installPackageDB = db, installVerbosity = v }) pd lbi = + do gsmenuPostCopy a (defaultCopyFlags { copyDest = Flag NoCopyDest, copyVerbosity = v }) pd lbi + +gsmenuPostCopy a (CopyFlags { copyDest = cdf, copyVerbosity = vf }) pd lbi = + do let v = fromFlagOrDefault normal vf + cd = fromFlagOrDefault NoCopyDest cdf + dirs = absoluteInstallDirs pd lbi cd + bin = combine (bindir dirs) + when (not isWindows) $ do + copyFileVerbose v ("gsmenu_path") (bin "gsmenu_path") + fs <- getFileStatus (bin "gsmenu") + setFileMode (bin "gsmenu_path") $ fileMode fs + putStrLn $ "Installing manpage in " ++ mandir dirs + createDirectoryIfMissing True $ mandir dirs + copyFileVerbose v ("gsmenu.1") (mandir dirs `combine` "gsmenu.1") diff --git a/gsmenu.1 b/gsmenu.1 new file mode 100644 --- /dev/null +++ b/gsmenu.1 @@ -0,0 +1,126 @@ +.TH GSMENU 1 gsmenu\-1.0 +.SH NAME +gsmenu \- grid menu +.SH SYNOPSIS +.B gsmenu +.RB [ \-d " "] +.RB [ \-c ] +.RB [ \-e] +.RB [ \-h ] +.RB [ \-v ] +.SH DESCRIPTION +.SS Overview +gsmenu is a generic grid menu for X11, originally a port of the +GridSelect contrib for XMonad. +.SS Options +.TP +.B \-d +specifies the X server to contact. +.TP +.B \-c +makes gsmenu accept complex input format (see below). +.TP +.B \-e +print the selected item as an index into the (0-indexed) sequence of +input elements. +.TP +.B \-h +prints command option summary to standard output, then exits. +.TP +.B \-v +prints version information to standard output, then exits. +.SH USAGE +gsmenu reads a list of newline-separated elements from standard input +and presents them in a grid. Each element has a foreground and a +background colour, as well as a name (what will be visible on the +screen) and a list of tags that can be used for filtering. +.SS INPUT FORMAT +In the "simple" input format (the default), each line corresponds to +the name of a single element and each element has an empty set of +tags. In the "complex" input format, entries take the form of +key-value pairs, with the key being a sequence of alphanumerics, +followed by an equals sign, followed by a value in double quotes +(double-quotes can be embedded in values by doubling them). For +example, an element might be + +.nf +name="foo" bg="red" +.fi + +And a list-value can be given by simply writing more double-quoted +strings (this also showcases double quote-escaping): + +.nf +name="quote ""this"" please" tags="bar" "baz" bg="red" +.fi + +The following keys are defined: +.TP +.B name +The string that will be displayed in the grid. +.TP +.B fg +The foreground (text) colour of the element (#RGB, #RRGGBB, and color +names are supported). +.TP +.B bg +The background colour of the element (#RGB, #RRGGBB, and color +names are supported). +.TP +.B tags +A list of tags of the element, used when filtering. + +.SS INTERACTION +When the user moves focus to an element and presses Return, that +element is selected and is printed to standard output (or its index, +if +.B \-e +is used) and gsmenu terminates. Elements can also be selected by +clicking on them with the mouse. Additionally, the following keyboard +commands are recognised: +.TP +.B Any printable character +Appends the character to the text in the input field. This works as a filter: +only items containing this text (possibly in a tag) will be displayed. +.TP +.B Backspace +Remove the last character in the input field, or if empty, open the +topmost filter for editing. +.TP +.B Left/Right/Up/Down (CTRL\-b/CTRL-f/CTRL\-p/CTRL\-n) +Move focus in the grid. +.TP +.B CTRL\-i +Solidify the current input as a filter, meaning that a new filter can be entered while the earlier will still apply. +.TP +.B CTRL\-o +Solidify the current input as an inverse filter, meaning that only +nonmatches will pass +.TP +.B CTRL\-a +Set focus to the leftmost element in the row. +.TP +.B CTRL\-e +Set focus to the rightmost element in the row. +.TP +.B CTRL\-s +Focus on the next element following a spiral path from the center. +.TP +.B CTRL\-r +Focus on the previous element following a spiral path from the center. +.TP +.B CTRL\-w +Remove the topmost filter, if any. +.TP +.B Escape +Cancel selection and exit gsmenu +.SH EXIT STATUS +gsmenu returns a +.B 0 +exit status on success, +.B 1 +if there was an internal problem, and +.B 2 +if the user cancelled. +.SH SEE ALSO +.BR dmenu (1) diff --git a/gsmenu.cabal b/gsmenu.cabal new file mode 100644 --- /dev/null +++ b/gsmenu.cabal @@ -0,0 +1,34 @@ +name: gsmenu +version: 1.0 +homepage: http://sigkill.dk +synopsis: A visual generic menu +description: + Standalone port of XMonadContrib's GridSelect. +category: System +license: BSD3 +license-file: LICENSE +author: Troels Henriksen +maintainer: athas@sigkill.dk +cabal-version: >= 1.6 +build-type: Custom + +flag use_xft + 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.* + + if flag(use_xft) + build-depends: X11-xft >= 0.2, utf8-string + extensions: ForeignFunctionInterface + cpp-options: -DXFT + main-is: Main.hs + other-modules: GSMenu.Config + GSMenu.Pick + GSMenu.Font + GSMenu.Util + + ghc-options: -funbox-strict-fields -Wall + + ghc-prof-options: -prof -auto-all + extensions: CPP diff --git a/gsmenu_path b/gsmenu_path new file mode 100644 --- /dev/null +++ b/gsmenu_path @@ -0,0 +1,36 @@ +#!/bin/sh +CACHE=$HOME/.gsmenu_cache +IFS=: + +uptodate() { + test -f "$CACHE" && + for dir in $PATH + do + test ! $dir -nt "$CACHE" || return 1 + done +} + +if ! uptodate +then + for dir in $PATH + do + tags="" + IFS=/ + for part in $dir + do + tags="\"$part\" ${tags}" + done + if [ ${tags} != '' ] + then + tags="tags=$tags" + fi + cd "$dir" && + for file in * + do + test -x "$file" && echo "name=\"$file\" $tags" + done + done | sort | uniq > "$CACHE".$$ && + mv "$CACHE".$$ "$CACHE" +fi + +cat "$CACHE"