gsmenu 1.0 → 1.1
raw patch · 9 files changed
+407/−234 lines, 9 filessetup-changed
Files
- GSMenu/Config.hs +1/−0
- GSMenu/Font.hsc +5/−7
- GSMenu/GCCache.hs +77/−0
- GSMenu/Pick.hs +126/−144
- GSMenu/Util.hs +12/−2
- Main.hs +132/−69
- Setup.hs +1/−1
- gsmenu.1 +50/−9
- gsmenu.cabal +3/−2
GSMenu/Config.hs view
@@ -30,6 +30,7 @@ , 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
GSMenu/Font.hsc view
@@ -79,14 +79,13 @@ -- | 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+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 fs = do- io $ freeFont dpy fs+releaseCoreFont dpy = io . freeFont dpy initUtf8Font :: MonadIO m => Display -> String -> m FontSet initUtf8Font dpy s = do@@ -96,8 +95,7 @@ fallBack = const $ createFontSet dpy "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" releaseUtf8Font :: MonadIO m => Display -> FontSet -> m ()-releaseUtf8Font dpy fs = do- io $ freeFontSet dpy fs+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'@@ -116,7 +114,7 @@ releaseXMF :: MonadIO m => Display -> GSMenuFont -> m () #ifdef XFT-releaseXMF dpy (Xft xftfont) = do+releaseXMF dpy (Xft xftfont) = io $ xftFontClose dpy xftfont #endif releaseXMF dpy (Utf8 fs) = releaseUtf8Font dpy fs@@ -136,7 +134,7 @@ textExtentsXMF (Utf8 fs) s = do let (_,rl) = wcTextExtents fs s ascent = fi $ - (rect_y rl)- descent = fi $ rect_height rl + (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
+ GSMenu/GCCache.hs view
@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -45,6 +45,7 @@ import Graphics.X11.Xshape import GSMenu.Font+import qualified GSMenu.GCCache as G import GSMenu.Util data GPConfig a = GPConfig {@@ -53,6 +54,7 @@ , gp_cellwidth :: Dimension , gp_cellpadding :: Dimension , gp_font :: String+ , gp_subfont :: String , gp_inputfont :: String , gp_keymap :: KeyMap a , gp_originFractX :: Double@@ -65,7 +67,7 @@ data Element a = Element { el_colors :: (String, String) , el_data :: a- , el_disp :: String+ , el_disp :: (String, [String]) , el_tags :: [String] } @@ -80,6 +82,7 @@ , ep_maskgc :: GC , ep_unmaskgc :: GC , ep_textgc :: GC+ , ep_bordergc :: GC } type TextBuffer = String@@ -101,12 +104,14 @@ passes :: Filter -> Element a -> Bool passes (Include s) elm = any (isInfixOf $ downcase s) fields- where fields = map downcase (el_disp elm : el_tags elm)+ 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 f = filter $ passes f+apply = filter . passes isRunning :: Filter -> Bool isRunning (Running _) = True@@ -120,8 +125,7 @@ data TwoDState a = TwoDState { td_curpos :: TwoDPosition- , td_colorcache :: M.Map (String, String)- (GC, String, String)+ , td_colorcache :: G.GCCache , td_tbuffer :: TextBuffer , td_filters :: [FilterState a] }@@ -133,12 +137,14 @@ , 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 (StateT (TwoDState a)- (ReaderT (TwoDConf a) IO) b)+newtype TwoD a b = TwoD (ReaderT (TwoDConf a)+ (StateT (TwoDState a) IO) b) deriving (Monad, Functor, MonadState (TwoDState a), MonadReader (TwoDConf a), MonadIO) @@ -146,8 +152,8 @@ (<*>) = ap pure = return -evalTwoD :: TwoD a b -> TwoDState a -> TwoDConf a -> IO b-evalTwoD (TwoD m) s c = runReaderT (evalStateT m s) c+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@@ -157,22 +163,12 @@ elementMap :: TwoD a (TwoDElementMap a) elementMap = do- s <- get+ 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)+elementGrid elms = flip zip (map select elms) <$> asks td_scaffold select :: Element a -> Element (TwoD a (Maybe a)) select elm = elm { el_data = return $ Just $ el_data elm }@@ -196,41 +192,50 @@ 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 :: 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 [] = 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+textHeight :: GSMenuFont -> String -> IO Dimension+textHeight font = liftM (fi . uncurry (+)) . textExtentsXMF font++drawWinBox :: Window -> (String, String)+ -> String -> [String] -> 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)+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- 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+ 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)+ stext f = shrinkWhile (reverse . inits)+ (\n -> do size <- textWidthXMF dpy f n+ return $ size > fi (cw-fi (2*cp)))+ x' = fi (x+fi cp)+ y' = fi (y+(fi ch-fi sheight-fi theight) `div` 2)+ putline f voff (h, s) = do+ s' <- stext f s+ printStringXMF dpy win f (ep_textgc ep) fg bg x' (voff+fi h) s'+ return h+ _ <- putline font y' (theight, text)+ foldM_ (putline subfont) (y'+fi theight) $ zip (map fi sheights) subs' drawBoxMask :: Display -> GC -> Pixmap -> Position -> Position -> Dimension -> Dimension -> IO ()@@ -238,35 +243,14 @@ 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+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@@ -305,15 +289,11 @@ 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+ , el_disp = (text, sub) }) =+ drawWinBox win colors' text sub where colors' | curpos == (x,y) = ("black", "#faff69") | otherwise = colors@@ -343,9 +323,16 @@ 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 <* modify (\s -> s { td_curpos = (0,0) })+ f <* adjustPosition <* redrawAllElements <* updateTextInput @@ -423,45 +410,31 @@ moveTo (nx, ny) = do (x,y) <- gets td_curpos move (nx-x, ny-y)--dist :: TwoDPosition -> Integer-dist (x,y) = abs x + abs y+ +distTo :: TwoDPosition -> TwoDPosition -> Integer+distTo (x1, y1) (x2, y2) = abs (x2-x1) + abs (y2-y1) -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+visibleGrid :: TwoD a [TwoDPosition]+visibleGrid =+ liftM2 intersect (map fst <$> elementMap) $ asks td_scaffold -skipalong :: ([TwoDPosition] -> TwoDPosition) - -> (Integer -> Integer)- -> ([TwoDPosition] -> TwoDPosition)- -> (([TwoDPosition], [TwoDPosition]) -> TwoDPosition)+skipalong :: ([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'+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 last (+1) jump forward- where jump (p:_) = p- jump _ = (0,0)- forward (_, _:p:_) = p- forward _ = (0,0)+next = skipalong id 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+prev = skipalong reverse lineMove :: ((TwoDPosition -> TwoDPosition -> Ordering) -> [TwoDPosition] -> TwoDPosition)@@ -470,7 +443,7 @@ (_,y) <- gets td_curpos elmap <- elementMap let row = filter ((==y) . snd) $ map fst elmap- moveTo $ f (comparing $ fst) row+ moveTo $ f (comparing fst) row beg :: TwoD a () beg = lineMove minimumBy@@ -482,7 +455,7 @@ pop = do f <- topFilter case f of- Just (Running _) -> changingState $ pop'+ Just (Running _) -> changingState pop' Just _ -> changingState popFilter _ -> return () where pop' = do@@ -517,10 +490,10 @@ elmap <- elementMap case lookup pos elmap of Nothing -> eventLoop- Just elm -> do maybe eventLoop (return . Just) =<< el_data elm+ Just elm -> maybe eventLoop (return . Just) =<< el_data elm | t == keyPress = do keymap <- asks (gp_keymap . td_gpconfig)- maybe unbound id $ M.lookup (m',ks) $ keymap+ fromMaybe unbound $ M.lookup (m',ks) keymap eventLoop where m' = cleanMask m unbound | not $ any isControl s = input s@@ -537,7 +510,7 @@ gridY = fi $ (fi y - (h - ch) `div` 2) `div` ch case lookup (gridX,gridY) elmap of Nothing -> eventLoop- Just elm -> do+ Just elm -> maybe eventLoop (return . Just) =<< el_data elm | otherwise = eventLoop @@ -561,15 +534,18 @@ createWindow dpy rw x y w h 0 copyFromParent inputOutput visual attrmask attrs -mkElemPane :: Display -> Screen -> Rectangle -> IO ElemPane-mkElemPane dpy screen rect = do+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- pm <- createPixmap dpy win rwidth rheight 1- maskgc <- createGC dpy pm+ 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@@ -577,7 +553,6 @@ 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@@ -585,16 +560,18 @@ , ep_shapemask = pm , ep_maskgc = maskgc , ep_unmaskgc = unmaskgc- , ep_textgc = textgc }+ , 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 } = do+ , ep_textgc = textgc + , ep_bordergc = bordergc} = do unmapWindow dpy win destroyWindow dpy win- mapM_ (freeGC dpy) [maskgc, unmaskgc, textgc]+ mapM_ (freeGC dpy) [maskgc, unmaskgc, textgc, bordergc] sync dpy False fgGC :: Display -> Drawable -> (String, Pixel) -> IO GC@@ -644,37 +621,42 @@ 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+ ep@ElemPane { ep_win = win } <-+ mkElemPane dpy screen rect $ gp_bordercolor gpconfig 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)+ 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 * fromIntegral restrictX- originPosY = floor $ ((gp_originFractY gpconfig) - (1/2)) * 2 * fromIntegral restrictY+ 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 }+ (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 view
@@ -18,6 +18,8 @@ , upcase , downcase , hsv2rgb+ , wrap+ , quote ) where import Control.Monad.Trans@@ -49,8 +51,8 @@ -- | 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+ 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)@@ -62,3 +64,11 @@ 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
@@ -38,82 +38,41 @@ import GSMenu.Pick import GSMenu.Util -data AppConfig = AppConfig {+data AppConfig a = AppConfig { cfg_complex :: Bool , cfg_display :: String , cfg_enumerate :: Bool+ , cfg_gpconfig :: GPConfig a } -defaultConfig :: AppConfig+defaultConfig :: AppConfig a defaultConfig = AppConfig { cfg_complex = False , cfg_display = "" , cfg_enumerate = False+ , cfg_gpconfig = defaultGPConfig } main :: IO () main = do opts <- getOpt RequireOrder options <$> getArgs- dstr <- getEnv "DISPLAY" `catch` (const $ return "")+ 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+ mapM_ (hPutStrLn stderr . ("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 :: 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 defaultGPConfig elems+ sel <- gpick dpy screen rect (cfg_gpconfig cfg) elems case sel of Left reason -> err reason >> exitWith (ExitFailure 1) Right Nothing -> exitWith $ ExitFailure 2@@ -122,14 +81,13 @@ | cfg_complex cfg = readElementsC "stdin" | otherwise = readElements valuer- | cfg_enumerate cfg = \_ i -> show i+ | cfg_enumerate cfg = const show | otherwise = \ s _ -> s setupDisplay :: String -> IO Display-setupDisplay dstr = do- dpy <- openDisplay dstr `Prelude.catch` \_ -> do- error $ "Cannot open display '" ++ dstr ++ "'."- return dpy+setupDisplay dstr =+ openDisplay dstr `Prelude.catch` \_ ->+ error $ "Cannot open display \"" ++ dstr ++ "\"." findRectangle :: Display -> Window -> IO Rectangle findRectangle dpy rootw = do@@ -149,7 +107,7 @@ where mk line num = Element { el_colors = ("black", "white") , el_data = f line num- , el_disp = line + , el_disp = (line, []) , el_tags = [] } readElementsC :: MonadIO m => SourceName@@ -162,30 +120,135 @@ Left e -> error $ show e Right els -> return $ zipWith mk els [0..] where mk elm num = elm {- el_data = f (el_disp elm) num }- + el_data = f (fst $ el_disp elm) num }++type GSMenuOption a = OptDescr (AppConfig a -> IO (AppConfig a))++options :: [GSMenuOption a]+options = [optHelp, optVersion, optDisplay, optComplex, optEnumResult,+ optFont, optSubFont, optInputFont,+ optCellHeight, optCellWidth, optCellPadding,+ optOriginX, optOriginY]++inGPConfig :: (String -> GPConfig a -> GPConfig a)+ -> String -> AppConfig a -> IO (AppConfig a)+inGPConfig f arg cfg = return $ cfg { cfg_gpconfig = f arg (cfg_gpconfig cfg) }++tryRead :: Read a => (String -> String) -> String -> a+tryRead ef s = case reads s of+ [(x, "")] -> x+ _ -> error $ ef s++readInt :: (Integral a, Read a) => String -> a+readInt = tryRead $ (++ " is not an integer.") . quote++readFloat :: (Fractional a, Read a) => String -> a+readFloat = tryRead $ (++ " is not a decimal fraction.") . quote++optHelp :: GSMenuOption a+optHelp = Option "h" ["help"]+ (NoArg $ \_ -> do+ hPutStrLn stderr =<< usageStr+ exitSuccess)+ "Display this help screen."+ +usageStr :: IO String+usageStr = do+ prog <- getProgName+ let header = "Help for " ++ prog ++ " " ++ versionString+ return $ usageInfo header options+ +optVersion :: GSMenuOption a+optVersion = Option "v" ["version"]+ (NoArg $ \_ -> do + hPutStrLn stderr ("gsmenu " ++ versionString ++ ".")+ hPutStrLn stderr "Copyright (C) Troels Henriksen."+ exitSuccess)+ "Print version number."+ +versionString :: String+versionString = "1.1"+ +optDisplay :: GSMenuOption a+optDisplay = Option "d" ["display"]+ (ReqArg (\arg cfg -> return $ cfg { cfg_display = arg }) "dpy" )+ "Specify the X display to connect to."+ +optComplex :: GSMenuOption a+optComplex = Option "c" ["complex"]+ (NoArg (\cfg -> return $ cfg { cfg_complex = True }) )+ "Use complex input format."++optEnumResult :: GSMenuOption a+optEnumResult = Option "e" ["enumerate"]+ (NoArg (\cfg -> return $ cfg { cfg_enumerate = True }) )+ "Print the result as the (zero-indexed) element number."++optCellHeight :: GSMenuOption a+optCellHeight = Option [] ["cellheight"]+ (ReqArg (inGPConfig $ \arg gpc ->+ gpc { gp_cellheight = readInt arg }) "height")+ "The height of each element cell"++optCellWidth :: GSMenuOption a+optCellWidth = Option [] ["cellwidth"]+ (ReqArg (inGPConfig $ \arg gpc ->+ gpc { gp_cellwidth = readInt arg }) "width")+ "The width of each element cell"++optCellPadding :: GSMenuOption a+optCellPadding = Option [] ["cellpadding"]+ (ReqArg (inGPConfig $ \arg gpc ->+ gpc { gp_cellpadding = readInt arg }) "padding")+ "The inner padding of each element cell."++optFont :: GSMenuOption a+optFont = Option [] ["font"]+ (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_font = arg }) "font")+ "The font used for printing names of elements."++optSubFont :: GSMenuOption a+optSubFont = Option [] ["subfont"]+ (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_subfont = arg}) "font")+ "The font used for printing extra lines in elements."++optInputFont :: GSMenuOption a+optInputFont = Option [] ["inputfont"]+ (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_inputfont = arg}) "font")+ "The font used for the input field."++optOriginX :: GSMenuOption a+optOriginX = Option "x" []+ (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_originFractX = readFloat arg }) "float")+ "The horizontal center of the grid, range [0,1]."+ +optOriginY :: GSMenuOption a+optOriginY = Option "y" []+ (ReqArg (inGPConfig $ \arg gpc -> gpc { gp_originFractY = readFloat arg }) "float")+ "The vertical center of the grid, range [0,1]"+ 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_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] ))+ (r,g,b) = hsv2rgb (seed 83 `mod` 360,+ fi (seed 191 `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 a = printf "%02x" a+twodigitHex = printf "%02x" element :: GenParser Char u (Element a) element = do kvs <- kvPair `sepBy1` realSpaces <* spaces@@ -194,8 +257,8 @@ where tags (("tags",ts):ls) = ts ++ tags ls tags ((_,_):ls) = tags ls tags [] = []- procKv elm ("name", [val]) =- return elm { el_disp = val }+ procKv elm ("name", val : more) =+ return elm { el_disp = (val, more) } procKv _ ("name", _) = badval "name" procKv elm ("fg", [val]) = return elm {@@ -208,11 +271,11 @@ 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+ badval = parserFail . ("Bad value for field " ++) . quote+ nokey = parserFail . ("Unknown key " ++) . quote kvPair :: GenParser Char u (String, [String])-kvPair = do+kvPair = pure (,) <*> (many1 alphaNum <* realSpaces <* char '=' <* realSpaces) <*> many1 (value <* realSpaces)
Setup.hs view
@@ -55,4 +55,4 @@ 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")+ copyFileVerbose v ("gsmenu.1") (mandir dirs `combine` "man1" `combine` "gsmenu.1")
@@ -1,17 +1,27 @@-.TH GSMENU 1 gsmenu\-1.0+.TH GSMENU 1 gsmenu\-1.1 .SH NAME gsmenu \- grid menu .SH SYNOPSIS-.B gsmenu-.RB [ \-d " <display>"]-.RB [ \-c ]-.RB [ \-e]-.RB [ \-h ]-.RB [ \-v ]+.nh+gsmenu+[\fB\-d=\fIdisplay\fR]+[\fB\-c\fR]+[\fB\-e\fR]+[\fB\-\-cellheight \fIheight\fR]+[\fB\-\-cellwidth \fIwidth\fR\fR]+[\fB\-\-cellpadding \fIpadding\fR]+[\fB\-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] .SH DESCRIPTION .SS Overview gsmenu is a generic grid menu for X11, originally a port of the-GridSelect contrib for XMonad.+GridSelect contrib for XMonad. It displays elements as a grid of+rectangular cells. .SS Options .TP .B \-d@@ -24,6 +34,33 @@ 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@@ -57,7 +94,11 @@ The following keys are defined: .TP .B name-The string that will be displayed in the grid.+The string that will be displayed in the grid. The value can also be+a list, in which case each part of the list will be printed as a line+by itself (note that there will probably not be room for more than two+lines). Also, only the first line will count as the "name" as far as+selection output is concerned. .TP .B fg The foreground (text) colour of the element (#RGB, #RRGGBB, and color
@@ -1,10 +1,10 @@ name: gsmenu-version: 1.0+version: 1.1 homepage: http://sigkill.dk synopsis: A visual generic menu description: Standalone port of XMonadContrib's GridSelect.-category: System+category: Tools license: BSD3 license-file: LICENSE author: Troels Henriksen@@ -24,6 +24,7 @@ cpp-options: -DXFT main-is: Main.hs other-modules: GSMenu.Config+ GSMenu.GCCache GSMenu.Pick GSMenu.Font GSMenu.Util