diff --git a/GSMenu/Config.hs b/GSMenu/Config.hs --- a/GSMenu/Config.hs +++ b/GSMenu/Config.hs @@ -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 diff --git a/GSMenu/Font.hsc b/GSMenu/Font.hsc --- a/GSMenu/Font.hsc +++ b/GSMenu/Font.hsc @@ -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 diff --git a/GSMenu/GCCache.hs b/GSMenu/GCCache.hs new file mode 100644 --- /dev/null +++ b/GSMenu/GCCache.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GSMenu.GCCache +-- Author : Troels Henriksen +-- 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 diff --git a/GSMenu/Pick.hs b/GSMenu/Pick.hs --- a/GSMenu/Pick.hs +++ b/GSMenu/Pick.hs @@ -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 diff --git a/GSMenu/Util.hs b/GSMenu/Util.hs --- a/GSMenu/Util.hs +++ b/GSMenu/Util.hs @@ -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 "\"" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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") diff --git a/gsmenu.1 b/gsmenu.1 --- a/gsmenu.1 +++ b/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 " "] -.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 diff --git a/gsmenu.cabal b/gsmenu.cabal --- a/gsmenu.cabal +++ b/gsmenu.cabal @@ -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