diff --git a/GSMenu/Config.hs b/GSMenu/Config.hs deleted file mode 100644 --- a/GSMenu/Config.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : GSMenu.Config --- Author : Troels Henriksen --- License : MIT-style (see LICENSE) --- --- Stability : stable --- Portability : unportable --- --- Default bindings and settings for easy editing --- ------------------------------------------------------------------------------ - -module GSMenu.Config - ( defaultGPConfig - , defaultGPNav - ) where - -import qualified Data.Map as M - -import Graphics.X11.Xlib - -import GSMenu.Pick - - -defaultGPConfig :: GPConfig a -defaultGPConfig = GPConfig { - gp_bordercolor = "white" - , gp_cellheight = 50 - , gp_cellwidth = 130 - , gp_cellpadding = 10 - , gp_font = "xft:Sans-8" - , gp_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) - ] diff --git a/GSMenu/Font.hsc b/GSMenu/Font.hsc deleted file mode 100644 --- a/GSMenu/Font.hsc +++ /dev/null @@ -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 diff --git a/GSMenu/GCCache.hs b/GSMenu/GCCache.hs deleted file mode 100644 --- a/GSMenu/GCCache.hs +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 --- a/GSMenu/Pick.hs +++ /dev/null @@ -1,658 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : GSMenu.Pick --- Author : Troels Henriksen --- License : MIT-style (see LICENSE) --- --- Stability : stable --- Portability : unportable --- --- The main display and selection logic. --- ------------------------------------------------------------------------------ - -module GSMenu.Pick - ( GPConfig(..) - , Element(..) - , KeyMap - , TwoDPosition - , gpick - - , move - , next - , prev - , beg - , end - , backspace - , include - , exclude - , pop - ) where - -import 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 diff --git a/GSMenu/Util.hs b/GSMenu/Util.hs deleted file mode 100644 --- a/GSMenu/Util.hs +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : GSMenu.Util --- Author : Troels Henriksen --- License : MIT-style (see LICENSE) --- --- Stability : stable --- Portability : portable --- --- Various utility bits and pieces. --- ------------------------------------------------------------------------------ - -module GSMenu.Util - ( io - , fi - , err - , upcase - , downcase - , hsv2rgb - , 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 "\"" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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; }" + , " || { exit 2 }" + , "stdin->lines(lines) { grid.insert(lines); }" + , "input.value->changed(from, to) { grid.filter(to) }" + , " || { grid.east(); next }" + , " || { grid.west(); next }" + , " || { grid.north(); next }" + , " || { grid.south(); next }" + , " { foo = grid.selected; print foo[\"value\"]; exit }" + , " { grid.next(); next }" + , " { 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 ' ' diff --git a/gsmenu.1 b/gsmenu.1 --- a/gsmenu.1 +++ b/gsmenu.1 @@ -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) diff --git a/gsmenu.cabal b/gsmenu.cabal --- a/gsmenu.cabal +++ b/gsmenu.cabal @@ -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