gsmenu 2.2 → 3.0
raw patch · 8 files changed
+393/−1376 lines, 8 filesdep +permutedep +sindredep +textdep −X11-xftdep −X11-xshapedep −getflag
Dependencies added: permute, sindre, text
Dependencies removed: X11-xft, X11-xshape, getflag, utf8-string
Files
- GSMenu/Config.hs +0/−58
- GSMenu/Font.hsc +0/−203
- GSMenu/GCCache.hs +0/−77
- GSMenu/Pick.hs +0/−658
- GSMenu/Util.hs +0/−74
- Main.hs +364/−209
- gsmenu.1 +21/−82
- gsmenu.cabal +8/−15
− GSMenu/Config.hs
@@ -1,58 +0,0 @@--------------------------------------------------------------------------------- |--- 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_subfont = "xft:Sans-7"- , 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
@@ -1,203 +0,0 @@-------------------------------------------------------------------------------- |--- 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 =- io $ catch getIt fallBack- where getIt = loadQueryFont dpy s- fallBack = const $ loadQueryFont dpy "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"--releaseCoreFont :: MonadIO m => Display -> FontStruct -> m ()-releaseCoreFont dpy = io . freeFont dpy--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 = io . freeFontSet dpy---- | 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) =- 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/GCCache.hs
@@ -1,77 +0,0 @@--------------------------------------------------------------------------------- |--- Module : GSMenu.GCCache--- Author : Troels Henriksen <athas@sigkill.dk>--- License : MIT-style (see LICENSE)------ Stability : stable--- Portability : unportable------ Cache for creating and retrieving Xlib GC values.-----------------------------------------------------------------------------------module GSMenu.GCCache ( getGC- , GCCache- , empty- , allGCs- , freeCache- , GCParams(..)- ) where--import Control.Monad.Trans--import qualified Data.Map as M-import Data.Maybe--import Graphics.X11.Xlib--import GSMenu.Font-import GSMenu.Util--data GCParams = GCParams {- gc_fg :: String - } deriving (Eq, Ord)--type InnerCache = M.Map GCParams GC--newtype GCCache = GCCache (M.Map Drawable InnerCache)--empty :: GCCache-empty = GCCache M.empty--innerCache :: GCCache -> Drawable -> InnerCache-innerCache (GCCache c) d =- fromMaybe M.empty $ M.lookup d c--cachedGC :: GCCache -> Drawable -> GCParams -> Maybe GC-cachedGC cache d p = M.lookup p $ innerCache cache d--setCached :: GCCache -> Drawable -> GCParams -> GC -> GCCache-setCached cache@(GCCache c) d p gc =- GCCache $ M.insert d inner' c- where inner = innerCache cache d- inner' = M.insert p gc inner--getGC :: MonadIO m => Display -> Screen -> GCCache -> Drawable -> GCParams -> m (GC, GCCache)-getGC dpy screen cache d p =- case cachedGC cache d p of- Just x -> return (x, cache)- Nothing -> do- x <- getGC'- return (x, setCached cache d p x)- where getGC' = io $ do- gc <- createGC dpy d- fgc <- initColor dpy $ gc_fg p- case fgc of- Just fgc' -> setForeground dpy gc fgc'- Nothing -> do err $ "Bad color " ++ gc_fg p- setForeground dpy gc wp- return gc- wp = whitePixelOfScreen screen--allGCs :: GCCache -> [GC]-allGCs (GCCache c) = concatMap M.elems $ M.elems c--freeCache :: Display -> GCCache -> IO ()-freeCache dpy = mapM_ (freeGC dpy) . allGCs
− GSMenu/Pick.hs
@@ -1,658 +0,0 @@-{-# 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 Codec.Binary.UTF8.String (decodeString)--import Control.Concurrent--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 qualified GSMenu.GCCache as G-import GSMenu.Util--data GPConfig a = GPConfig {- gp_bordercolor :: String- , gp_cellheight :: Dimension- , gp_cellwidth :: Dimension- , gp_cellpadding :: Dimension- , gp_font :: String- , gp_subfont :: 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, [String])- , el_tags :: [String]- }--type TwoDElement a = (TwoDPosition, Element 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- , ep_bordergc :: 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 (fst (el_disp elm) - : snd (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 = filter . passes--isRunning :: Filter -> Bool-isRunning (Running _) = True-isRunning _ = False--data FilterState a = FilterState {- fl_filter :: Filter- , fl_elms :: [Element a]- }--data TwoDState a = TwoDState {- td_curpos :: TwoDPosition- , td_colorcache :: G.GCCache- , 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_subfont :: GSMenuFont- , td_elms :: [Element a]- , td_elmap :: TwoDElementMap a- , td_scaffold :: [TwoDPosition]- }--newtype TwoD a b = TwoD (ReaderT (TwoDConf a)- (StateT (TwoDState a) IO) b)- deriving (Monad, Functor, MonadState (TwoDState a),- MonadReader (TwoDConf a), MonadIO)--instance Applicative (TwoD a) where- (<*>) = ap- pure = return--runTwoD :: TwoD a b -> TwoDConf a -> TwoDState a -> IO (b, TwoDState a)-runTwoD (TwoD m) = runStateT . runReaderT m--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 = liftM2 zip (asks td_scaffold) elements--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)--textHeight :: GSMenuFont -> String -> IO Dimension-textHeight font = liftM (fi . uncurry (+)) . textExtentsXMF font--shrinkWhile :: Monad m => ([a] -> [[a]])- -> ([a] -> m Bool)- -> [a] -> m [a]-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--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]- -> Position -> Position -> Dimension -> Dimension- -> TwoD a ()-drawWinBox win (fg,bg) text sub x y cw ch = do- gc <- getGC win bg- cp <- asks (gp_cellpadding . td_gpconfig)- TwoDConf { td_display = dpy, td_elempane = ep,- td_subfont = subfont, td_font = font }- <- ask- io $ do- fillRectangle dpy win gc x y cw ch- drawRectangle dpy win (ep_bordergc ep) x y cw ch- theight <- textHeight font text- sheights <- mapM (textHeight subfont) sub- let room = ch-2*cp-theight- (sheight, subs') =- fromMaybe (0, []) $- find ((<=room) . fst) (zip sheights $ reverse $ inits sub)- 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 =- 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'--getGC :: Drawable -> String -> TwoD a GC-getGC d fg = do- dpy <- asks td_display- screen <- asks td_screen- cache <- gets td_colorcache- (gc, cache') <- io $ G.getGC dpy screen cache d G.GCParams { G.gc_fg = fg}- modify $ \s -> s { td_colorcache = cache' }- return gc--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 $ fillRectangle dpy pm unmaskgc 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- win <- asks (ep_win . td_elempane)- curpos <- gets td_curpos- let update ((x,y),Element { el_colors = colors- , el_disp = (text, sub) }) =- drawWinBox win colors' text sub- 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 _ = ""--adjustPosition :: TwoD a ()-adjustPosition = do- coords <- (map fst <$> elementMap)- unless (null coords) $- modify (\s -> s { td_curpos = minimumBy (comparator s) coords})- where comparator = comparing . distTo . td_curpos--changingState :: TwoD a b -> TwoD a b-changingState f =- f <* adjustPosition- <* redrawAllElements- <* updateTextInput--pushFilter :: Filter -> TwoD a ()-pushFilter f = do- elms' <- apply f <$> elements- modify $ \s -> s {- td_filters = FilterState { fl_filter = f- , fl_elms = elms' } : 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- (ox, oy) <- gets td_curpos- elmap <- elementMap- let newPos = (ox+dx, oy+dy)- newSelectedEl = findInElementMap newPos elmap- when (isJust newSelectedEl) $ do- modify $ \s -> s { 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)- -distTo :: TwoDPosition -> TwoDPosition -> Integer-distTo (x1, y1) (x2, y2) = abs (x2-x1) + abs (y2-y1)--visibleGrid :: TwoD a [TwoDPosition]-visibleGrid =- liftM2 intersect (map fst <$> elementMap) $ asks td_scaffold--skipalong :: ([TwoDPosition] -> [TwoDPosition]) - -> TwoD a ()-skipalong f = do- curpos <- gets td_curpos- grid <- visibleGrid- let findnext (p:tl@(p':_))- | p == curpos = Just p'- | otherwise = findnext tl- findnext _ = Nothing- when (curpos `elem` grid) $ - moveTo $ fromMaybe curpos $ findnext $ cycle $ f grid--next :: TwoD a ()-next = skipalong id--prev :: TwoD a ()-prev = skipalong reverse--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,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- 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 || (m' == controlMask && elem ks [xK_g, xK_c]))- = return Nothing- | 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- 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- 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 x - (fi w - fi cw) `div` 2) `div` fi cw- gridY = (fi y - (fi h - fi ch) `div` 2) `div` fi ch- selectAt (gridX, gridY)- | 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 -> String -> IO ElemPane-mkElemPane dpy screen rect bc = do- let rootw = rootWindowOfScreen screen- rwidth = rect_width rect- rheight = rect_height rect- wp = whitePixelOfScreen screen- win <- mkUnmanagedWindow dpy screen rootw- (rect_x rect) (rect_y rect) rwidth rheight- bordergc <- fgGC dpy win (bc, wp)- textgc <- createGC dpy rootw- 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)- 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 - , ep_bordergc = bordergc}--freeElemPane :: Display -> ElemPane -> IO ()-freeElemPane dpy ElemPane { ep_win = win- , ep_maskgc = maskgc- , ep_unmaskgc = unmaskgc- , ep_textgc = textgc - , ep_bordergc = bordergc} = do- unmapWindow dpy win- destroyWindow dpy win- mapM_ (freeGC dpy) [maskgc, unmaskgc, textgc, bordergc]- 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--grabInput :: Display -> Window -> IO GrabStatus-grabInput dpy win = do- grabButton dpy button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none- grab (1000 :: Int)- where grab 0 = return alreadyGrabbed- grab n = do status <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime- if status /= grabSuccess- then threadDelay 1000 >> grab (n-1)- else return status- ---- | 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 $ gp_bordercolor gpconfig- tp <- mkTextPane dpy screen rect gpconfig- status <- grabInput dpy win- font <- initXMF dpy (gp_font gpconfig)- subfont <- initXMF dpy (gp_subfont 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 * fi restrictX- originPosY = floor $ (gp_originFractY gpconfig - (1/2)) * 2 * fi restrictY- coords = diamondRestrict restrictX restrictY originPosX originPosY- elmap = zip coords ellist- (selectedElement, s) <- runTwoD (do updateTextInput- redrawAllElements - eventLoop)- TwoDConf { td_elempane = ep- , td_textpane = tp- , td_gpconfig = gpconfig- , td_display = dpy- , td_screen = screen- , td_font = font- , td_subfont = subfont- , td_elmap = elmap- , td_elms = ellist- , td_scaffold = coords }- TwoDState { td_curpos = head coords- , td_colorcache = G.empty- , td_tbuffer = "" - , td_filters = [] }- freeElemPane dpy ep- freeTextPane dpy tp- G.freeCache dpy $ td_colorcache s- releaseXMF dpy font- return $ Right selectedElement
− GSMenu/Util.hs
@@ -1,74 +0,0 @@--------------------------------------------------------------------------------- |--- 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- , wrap- , quote- ) 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 = fi h/60 - fi 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."---- | Prepend and append first argument to second argument.-wrap :: String -> String -> String-wrap x y = x ++ y ++ x---- | Put double quotes around the given string.-quote :: String -> String-quote = wrap "\""
Main.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Main@@ -13,250 +16,402 @@ module Main (main) where +import Sindre.Main hiding (value, string, position)+import Sindre.Lib+import Sindre.Parser+import Sindre.Widgets+import Sindre.X11+import Sindre.KeyVal+import Sindre.Util++import Graphics.X11.Xlib hiding (refreshKeyboardMapping, Rectangle, textWidth, allocColor,+ textExtents)+import qualified Graphics.X11.Xft as Xft+ import Control.Applicative import Control.Monad-import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.State.Lazy -import Data.Maybe+import Data.Either import Data.List+import Data.Maybe+import Data.Ord (comparing)+import Data.Traversable (traverse) import Data.Word (Word8)+import qualified Data.Map as M+import qualified Data.Text as T -import Graphics.X11.Xlib hiding (refreshKeyboardMapping)-import Graphics.X11.Xinerama+import Text.Printf -import System.Console.GetFlag import System.Environment-import System.Exit-import System.IO -import Text.Parsec hiding ((<|>), many, optional)-import Text.Parsec.String+-- | The main Sindre entry point.+main :: IO ()+main = case parseSindre emptyProgram "builtin" prog of+ Left e -> error $ show e+ Right prog' ->+ sindreMain prog' classMap' objectMap funcMap globMap =<< getArgs+ where prog = unlines [ "GUI { Vertically { Horizontally { Blank; label=Label(); Blank }; grid=Grid(); input=Input(minwidth=0) } }"+ , "BEGIN { focus input; }"+ , "<C-g> || <Escape> { exit 2 }"+ , "stdin->lines(lines) { grid.insert(lines); }"+ , "input.value->changed(from, to) { grid.filter(to) }"+ , "<Right> || <C-f> { grid.east(); next }"+ , "<Left> || <C-b> { grid.west(); next }"+ , "<Up> || <C-p> { grid.north(); next }"+ , "<Down> || <C-n> { grid.south(); next }"+ , "<Return> { foo = grid.selected; print foo[\"value\"]; exit }"+ , "<C-s> { grid.next(); next }"+ , "<C-r> { grid.prev(); next }"+ , "BEGIN { foo = grid.selected; if (foo) { label.label = foo[\"name\"] } }"+ , "grid.selected->changed(from, to) { if (to) { label.label = to[\"name\"] } }" ]+ classMap' = M.insert "Grid" mkGrid classMap -import Text.Printf+data Element = Element { elementName :: T.Text+ , elementSubnames :: [T.Text]+ , elementTags :: [T.Text]+ , elementFg :: Xft.Color+ , elementBg :: Xft.Color+ , elementValue :: T.Text } -import GSMenu.Config-import GSMenu.Pick-import GSMenu.Util+instance Show Element where+ show = show . elementName -data AppConfig a = AppConfig {- cfg_complex :: Bool- , cfg_display :: String- , cfg_enumerate :: Bool- , cfg_gpconfig :: GPConfig a- }+data DisplayedElement = DisplayedElement { displayedName :: String+ , displayedSubnames :: [String]+ , displayedElement :: Element+ } deriving (Show) -defaultConfig :: AppConfig a-defaultConfig = AppConfig {- cfg_complex = False- , cfg_display = ""- , cfg_enumerate = False- , cfg_gpconfig = defaultGPConfig- }+match :: T.Text -> Element -> Bool+match f e = (T.toCaseFold f `T.isInfixOf`) `any`+ map T.toCaseFold (elementName e : elementSubnames e ++ elementTags e) -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 . ("Junk argument: " ++)) nonopts- usage <- usageStr- hPutStr stderr $ concat errs ++ usage- exitFailure+type TwoDPos = (Integer, Integer)+type TwoDElement = (TwoDPos, DisplayedElement) -runWithCfg :: AppConfig [String] -> 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 (cfg_gpconfig cfg) elems- case sel of- Left reason -> err reason >> exitWith (ExitFailure 1)- Right Nothing -> exitWith $ ExitFailure 2- Right (Just els) -> printer els >> exitSuccess- where reader- | cfg_complex cfg = readElementsC "stdin"- | otherwise = readElements- printer (x:xs:rest) = putStrLn x *> printer (xs:rest)- printer [x] = putStr x- printer _ = return ()- valuer- | cfg_enumerate cfg = const $ (:[]) . show- | otherwise = \s _ -> [s]+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..] ] -setupDisplay :: String -> IO Display-setupDisplay dstr =- openDisplay dstr `Prelude.catch` \_ ->- error $ "Cannot open display \"" ++ dstr ++ "\"."+diamond :: (Enum a, Num a) => [(a, a)]+diamond = concatMap diamondLayer [0..] -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+diamondRestrict :: Integer -> Integer -> [TwoDPos]+diamondRestrict x y =+ filter (\(x',y') -> abs x' <= x && abs y' <= y) .+ map (\(x', y') -> (x', y')) .+ take 1000 $ diamond -readElements :: MonadIO m => Handle - -> (String -> Integer -> [String])- -> m [Element [String]]-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 -> [String])- -> m [Element [String]]-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 = fromMaybe - (f (fst $ el_disp elm) num) - (el_data elm)- }+data ElementGrid =+ ElementGrid { position :: TwoDPos+ , elements :: M.Map TwoDPos DisplayedElement }+ deriving (Show) -type GSMenuOption a = OptDescr (AppConfig a -> IO (AppConfig a))+emptyGrid :: ElementGrid+emptyGrid = ElementGrid (0,0) M.empty -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) }+gridMove :: (TwoDPos -> TwoDPos) -> ElementGrid -> Maybe ElementGrid+gridMove f grid = const (grid { position = pos' })+ <$> M.lookup pos' (elements grid)+ where pos' = f $ position grid -tryRead :: Read a => (String -> String) -> String -> a-tryRead ef s = case reads s of- [(x, "")] -> x- _ -> error $ ef s+south :: ElementGrid -> Maybe ElementGrid+south = gridMove $ \(x,y) -> (x,y+1)+east :: ElementGrid -> Maybe ElementGrid+east = gridMove $ \(x,y) -> (x+1,y)+north :: ElementGrid -> Maybe ElementGrid+north = gridMove $ \(x,y) -> (x,y-1)+west :: ElementGrid -> Maybe ElementGrid+west = gridMove $ \(x,y) -> (x-1,y) -readInt :: (Integral a, Read a) => String -> a-readInt = tryRead $ (++ " is not an integer.") . quote+gridToList :: ElementGrid -> [TwoDElement]+gridToList = M.toList . elements -readFloat :: (Fractional a, Read a) => String -> a-readFloat = tryRead $ (++ " is not a decimal fraction.") . quote+gridFromMap :: M.Map TwoDPos DisplayedElement -> TwoDPos -> ElementGrid+gridFromMap = flip ElementGrid -usageStr :: IO String-usageStr = do- prog <- getProgName- let header = "Help for " ++ prog ++ " " ++ versionStr- return $ usageInfo header options+cellWidth :: Num a => a+cellWidth = 130+cellHeight :: Num a => a+cellHeight = 50+cellPadding :: Num a => a+cellPadding = 10 -versionStr :: String-versionStr = "2.2"+data Grid = Grid { gridElems :: [Element]+ , gridSelElems :: [Element]+ , gridFilter :: T.Text+ , gridElementMap :: ElementGrid+ , gridVisual :: VisualOpts+ , gridRect :: Rectangle+ } -options :: [GSMenuOption a]-options = [ 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 (Maybe [String])]-parseElements = parse $ many element <* eof+selection :: Grid -> Value+selection g = maybe falsity (asDict . displayedElement)+ $ M.lookup (position grid) $ elements grid+ where grid = gridElementMap g+ asDict e = Dict $ M.fromList+ [ (unmold "name", unmold $ elementName e)+ , (unmold "subnames", dict $ elementSubnames e)+ , (unmold "tags", dict $ elementTags e)+ , (unmold "value", unmold $ elementValue e)]+ dict = Dict . M.fromList . zip (map Number [0..]) . map unmold -blankElem :: Element (Maybe a)-blankElem = Element {- el_colors = ("black", "white")- , el_data = Nothing- , el_disp = error "Element without display."- , el_tags = []- }+gridBox :: Drawer -> Element -> SindreX11M DisplayedElement+gridBox d e@Element { elementName = text, elementSubnames = subs } = do+ d' <- io $ (`setBgColor` elementBg e) <=<+ (`setFgColor` elementFg e) $ d+ let theight = Xft.height $ drawerFont d'+ sheights = map (const theight) subs+ room = cellHeight-2*cellPadding-theight+ (_, subs') =+ fromMaybe (0::Int, []) $+ find ((<=room) . fst) $+ reverse $ zip (map sum $ inits sheights) (inits $ map T.unpack subs)+ line = stopText (drawerFont d') (cellWidth-(2*cellPadding))+ liftM3 DisplayedElement+ (line $ T.unpack text)+ (mapM line subs')+ (return e) +stopText :: Xft.Font -> Dimension -> String -> SindreX11M String+stopText f mw =+ shrinkWhile (reverse . inits)+ (\n -> (> fi mw) <$> fst <$> textExtents f n)++shrinkWhile :: Monad m => ([a] -> [[a]])+ -> ([a] -> m Bool)+ -> [a] -> m [a]+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++recomputeMap :: Drawer -> ObjectM Grid SindreX11M ()+recomputeMap d = do+ Rectangle _ _ rwidth rheight <- gets gridRect+ oldpos <- gets $ position . gridElementMap+ let restriction ss cs = (ss/cs-1)/2 :: Double+ restrictX = floor $ restriction (fi rwidth) cellWidth+ restrictY = floor $ restriction (fi rheight) cellHeight+ coords = diamondRestrict restrictX restrictY+ buildGrid = traverse (back . gridBox d) . M.fromList . zip coords+ oldsel <- gets selection+ elmap <- buildGrid =<< gets gridSelElems+ let grid = gridFromMap elmap (0,0)+ modify $ \s -> s { gridElementMap =+ grid { position = bestpos oldpos $+ map fst $ gridToList grid }+ }+ newsel <- gets selection+ when (oldsel /= newsel) $+ changed "selected" oldsel newsel+ where bestpos _ [] = (0,0)+ bestpos oldpos l = minimumBy (closeTo oldpos) l+ closeTo orig p1 p2 | dist orig p1 > dist orig p2 = GT+ | dist orig p2 > dist orig p1 = LT+ | otherwise = comparing (dist (0,0)) p1 p2+ dist (x1,y1) (x2,y2) = abs (x1-x2) + abs (y1-y2)++needRecompute :: ObjectM Grid SindreX11M ()+needRecompute = do+ modify $ \s -> s { gridRect = Rectangle 0 0 0 0 }+ fullRedraw++updateRect :: Rectangle -> Drawer -> ObjectM Grid SindreX11M ()+updateRect r1 d = do r2 <- gets gridRect+ unless (r1 == r2) $ do+ modify $ \s -> s { gridRect = r1 }+ recomputeMap d++methInsert :: T.Text -> ObjectM Grid SindreX11M ()+methInsert vs = case partitionEithers $ parser vs of+ (e:_,_) -> fail $ "Parse error on Grid element: " ++ e+ ([],els) -> do+ els' <- back $ sequence els+ modify $ \s ->+ s { gridElems = gridElems s ++ els'+ , gridSelElems = gridSelElems s +++ filter (match $ gridFilter s) els' }+ needRecompute+ where parser = map parseElement . T.lines++methRemove :: (Element -> Bool) -> ObjectM Grid SindreX11M ()+methRemove f = do modify $ \s ->+ s { gridElems = filter f $ gridElems s+ , gridSelElems = filter f $ gridSelElems s }+ needRecompute++methRemoveByValue :: T.Text -> ObjectM Grid SindreX11M ()+methRemoveByValue k = methRemove $ (/=k) . elementValue++methRemoveByName :: T.Text -> ObjectM Grid SindreX11M ()+methRemoveByName k = methRemove $ (/=k) . elementName++methClear :: ObjectM Grid SindreX11M ()+methClear = modify $ \s -> s { gridElementMap = emptyGrid+ , gridElems = []+ , gridSelElems = [] }++methFilter :: T.Text -> ObjectM Grid SindreX11M ()+methFilter f = do changeFields [("selected", unmold . selection)] $ \s ->+ return s { gridSelElems = filter (match f) $ gridElems s }+ needRecompute++methNext :: ObjectM Grid SindreX11M ()+methPrev :: ObjectM Grid SindreX11M ()+(methNext, methPrev) = (circle next, circle prev)+ where circle f = do changeFields [("selected", unmold . selection)] $ \s ->+ case gridElementMap s of+ elems@ElementGrid{position=(x,y)} ->+ return s { gridElementMap =+ fromMaybe elems $ f x y elems+ }+ redraw+ next (-1) y | y >= 0 = south <=< south <=< east+ next x y = case (compare x 0, compare y 0) of+ (EQ, EQ) -> south+ (EQ, GT) -> east <=< north+ (EQ, LT) -> west <=< south+ (LT, GT) -> south <=< east+ (LT, EQ) -> south <=< east+ (LT, LT) -> west <=< south+ (GT, GT) -> east <=< north+ (GT, _) -> north <=< west+ prev 0 1 = north+ prev x y = case (compare x 0, compare y 0) of+ (EQ, EQ) -> const Nothing+ (EQ, GT) -> west <=< north <=< north+ (EQ, LT) -> east <=< south+ (LT, GT) -> west <=< north+ (LT, EQ) -> north <=< east+ (LT, LT) -> north <=< east+ (GT, LT) -> east <=< south+ (GT, _) -> south <=< west++move :: (ElementGrid -> Maybe ElementGrid) -> ObjectM Grid SindreX11M ()+move d = do changeFields [("selected", unmold . selection)] $ \s ->+ return s { gridElementMap = fromMaybe (gridElementMap s)+ $ d $ gridElementMap s+ }+ redraw++instance Object SindreX11M Grid where+ fieldSetI _ _ = return $ Number 0+ fieldGetI "selected" = selection <$> get+ fieldGetI "elements" = Dict <$> M.fromList <$>+ zip (map Number [1..]) <$>+ map (unmold . elementValue) <$> gridSelElems <$> get+ fieldGetI _ = return $ Number 0+ callMethodI "insert" = function methInsert+ callMethodI "removeValue" = function methRemoveByValue+ callMethodI "removeName" = function methRemoveByName+ callMethodI "clear" = function methClear+ callMethodI "filter" = function methFilter+ callMethodI "next" = function methNext+ callMethodI "prev" = function methPrev+ callMethodI "north" = function $ move north+ callMethodI "south" = function $ move south+ callMethodI "west" = function $ move west+ callMethodI "east" = function $ move east+ callMethodI m = fail $ "Unknown method '" ++ m ++ "'"++instance Widget SindreX11M Grid where+ composeI = return (Unlimited, Unlimited)+ drawI = drawing gridVisual $ \r d fd -> do+ updateRect r d+ elems <- gets gridElementMap+ let update (p,e) x y cw ch = do+ d' <- io $ (`setBgColor` elementBg (displayedElement e)) <=<+ (`setFgColor` elementFg (displayedElement e)) $ d+ let drawbox | p == position elems = drawWinBox fd+ | otherwise = drawWinBox d'+ drawbox e x y cw ch+ back $ updatingBoxes update r elems++updatingBoxes :: (TwoDElement+ -> Position -> Position+ -> Dimension -> Dimension+ -> SindreX11M ())+ -> Rectangle -> ElementGrid -> SindreX11M [Rectangle]+updatingBoxes f (Rectangle origx origy w h) egrid = do+ let w' = origx + div (w-cellWidth) 2+ h' = origy + div (h-cellHeight) 2+ proc ((x,y), t) = do+ f ((x,y), t)+ (fi $ w'+x*cellWidth) (fi $ h'+y*cellHeight)+ cellWidth cellHeight+ return $ Rectangle (fi w'+x*cellWidth) (h'+y*cellHeight)+ (cellWidth+1) (cellHeight+1)+ mapM proc $ gridToList egrid++drawWinBox :: Drawer+ -> DisplayedElement+ -> Position -> Position -> Dimension -> Dimension+ -> SindreX11M ()+drawWinBox d e x y cw ch = do+ io $ bg d fillRectangle x y cw ch+ io $ fg d drawRectangle x y cw ch+ let subs = displayedSubnames e+ theight = Xft.height $ drawerFont d+ sheights = map (const $ Xft.height $ drawerFont d) subs+ sheight = length subs * fi theight+ x' = x+cellPadding+ y' = y+(fi ch-fi sheight-fi theight) `div` 2+ ys = map (+(y'+theight)) $ scanl (+) 0 sheights+ putline voff =+ drawText (drawerFgColor d) (drawerFont d) x' voff theight+ _ <- putline y' $ displayedName e+ zipWithM_ putline ys subs++mkGrid :: Constructor SindreX11M+mkGrid r [] = do+ visual <- visualOpts r+ return $ NewWidget+ Grid { gridElems = []+ , gridSelElems = []+ , gridFilter = T.empty+ , gridElementMap = emptyGrid+ , gridVisual = visual+ , gridRect = Rectangle 0 0 0 0+ }+mkGrid _ _ = error "Grids do not have children"++parseElement :: T.Text -> Either String (SindreX11M Element)+parseElement = parseKV textelement+ where textelement = el+ <$?> ([], values $ T.pack "tags")+ <||> values (T.pack "name")+ <|?> (Nothing, Just <$> value (T.pack "fg"))+ <|?> (Nothing, Just <$> value (T.pack "bg"))+ <|?> (Nothing, Just <$> value (T.pack "value"))+ el tags (name:names) fgc bgc val =+ let (tfg, tbg) = tagColors $ map T.unpack tags+ in do mgr <- asks sindreXftMgr+ fgpix <- allocColor mgr $ maybe tfg T.unpack fgc+ bgpix <- allocColor mgr $ maybe tbg T.unpack bgc+ return Element { elementName = name+ , elementSubnames = names+ , elementTags = tags+ , elementFg = fgpix+ , elementBg = bgpix+ , elementValue = fromMaybe name val }+ el _ _ _ _ _ = error "No name"+ tagColors :: [String] -> (String, String) tagColors ts = let seed x = toInteger (sum $ map ((*x).fromEnum) s) :: Integer (r,g,b) = hsv2rgb (seed 83 `mod` 360, fi (seed 191 `mod` 1000)/2500+0.4,- fi (seed 121 `mod` 1000)/2500+0.4)+ fi (seed 121 `mod` 1000)/2500+0.4) in ("white", '#' : concatMap (twodigitHex.(round :: Double -> Word8).(*256)) [r, g, b] ) where s = show ts twodigitHex :: Word8 -> String twodigitHex = printf "%02x"--element :: GenParser Char u (Element (Maybe [String]))-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 : more) =- return elm { el_disp = (val, more) }- 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 elm ("value",val) =- return elm { el_data = Just val }- procKv _ (k, _) = nokey k- badval = parserFail . ("Bad value for field " ++) . quote- nokey = parserFail . ("Unknown key " ++) . quote--kvPair :: GenParser Char u (String, [String])-kvPair =- 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 ' '
@@ -1,81 +1,30 @@-.TH GSMENU 1 gsmenu\-2.2+.TH GSMENU 1 gsmenu\-4.0 .SH NAME gsmenu \- grid menu .SH SYNOPSIS .nh gsmenu-[\fB\-c\fR]-[\fB\-e\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\-h\fR]-[\fB\-v\fR]+[Sindre options...] .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. gsmenu always contacts the display indicated in-the DISPLAY environment variable.+GridSelect contrib for XMonad. Now it is a program built on+Sindre. It displays elements as a grid of rectangular cells. gsmenu+always uses the display indicated in the DISPLAY environment variable. .SS Options-.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 \-cellheight-The height of each cell in pixels.-.TP-.B \-cellwidth-The width of each cell in pixels.-.TP-.B \-cellpadding-The inner text padding of each cell in pixels.-.TP-.B \-x-Set the horizontal position of the center cell as a proportion of the-screen width.-.TP-.B \-y-As \fB\-x\fR, but sets the vertical position.-.TP-.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.-.TP-.B \-inputfont-As \-font, but affects the user input text field.-.TP-.B \-h-prints command option summary to standard output, then exits.-.TP-.B \-v-prints version information to standard output, then exits.+No options are accepted apart from those provided by+.IR sindre (1). .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.+screen) and a list of tags that are used only 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+The standard Sindre key-value format is used. Each line takes 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 by doubling+them). For example, an element might be .nf name="foo" bg="red"@@ -111,18 +60,13 @@ .B value Instead of the name, print the value of this key when the element is selected. If a list, a newline is printed after every element but the-last. If the-.B \-e-option is passed, this key has no effect.-+last. .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:+element is selected and is printed to standard output 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:@@ -135,13 +79,6 @@ .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@@ -168,4 +105,6 @@ .B 2 if the user cancelled. .SH SEE ALSO-.BR dmenu (1)+.IR sindre (1),+.IR dmenu (1),+.IR xmonad (1)
@@ -1,9 +1,9 @@ name: gsmenu-version: 2.2+version: 3.0 homepage: http://sigkill.dk/programs/gsmenu synopsis: A visual generic menu description:- Standalone port of XMonadContrib's GridSelect.+ Grid-oriented element selection inspired by XMonadContrib's GridSelect. category: Tools license: BSD3 license-file: LICENSE@@ -12,24 +12,17 @@ cabal-version: >= 1.6 build-type: Custom -flag use_xft- description: Use Xft to render text+source-repository head+ type: git+ location: git@github.com:Athas/gsmenu.git executable gsmenu- build-depends: X11>=1.5.0.0 && < 1.6, X11-xshape>=0.1.1, mtl, base==4.*, containers, parsec==3.*, getflag, utf8-string+ build-depends: X11>=1.5.0.0 && < 1.6, mtl, base==4.*,+ containers, parsec==3.*, sindre>=0.2, text, permute - if flag(use_xft)- build-depends: X11-xft >= 0.2- extensions: ForeignFunctionInterface- cpp-options: -DXFT main-is: Main.hs- other-modules: GSMenu.Config- GSMenu.GCCache- GSMenu.Pick- GSMenu.Font- GSMenu.Util ghc-options: -funbox-strict-fields -Wall - ghc-prof-options: -prof -auto-all+ ghc-prof-options: -prof -auto-all -rtsopts extensions: CPP