gsmenu (empty) → 1.0
raw patch · 11 files changed
+1537/−0 lines, 11 filesdep +X11dep +X11-xftdep +X11-xshapebuild-type:Customsetup-changed
Dependencies added: X11, X11-xft, X11-xshape, base, containers, mtl, parsec, utf8-string
Files
- GSMenu/Config.hs +57/−0
- GSMenu/Font.hsc +205/−0
- GSMenu/Pick.hs +680/−0
- GSMenu/Util.hs +64/−0
- LICENSE +22/−0
- Main.hs +229/−0
- README +26/−0
- Setup.hs +58/−0
- gsmenu.1 +126/−0
- gsmenu.cabal +34/−0
- gsmenu_path +36/−0
+ GSMenu/Config.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- Module : GSMenu.Config+-- Author : Troels Henriksen <athas@sigkill.dk>+-- 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)+ ]
+ GSMenu/Font.hsc view
@@ -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
+ GSMenu/Pick.hs view
@@ -0,0 +1,680 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module : GSMenu.Pick+-- Author : Troels Henriksen <athas@sigkill.dk>+-- 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
+ GSMenu/Util.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : GSMenu.Util+-- Author : Troels Henriksen <athas@sigkill.dk>+-- 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."
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -0,0 +1,229 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- Author : Troels Henriksen <athas@sigkill.dk>+-- 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 ' '
+ README view
@@ -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 <athas@sigkill.dk>.
+ Setup.hs view
@@ -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")
@@ -0,0 +1,126 @@+.TH GSMENU 1 gsmenu\-1.0+.SH NAME+gsmenu \- grid menu+.SH SYNOPSIS+.B gsmenu+.RB [ \-d " <display>"]+.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)
@@ -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
@@ -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"