diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -28,7 +28,6 @@ textExtents) import qualified Graphics.X11.Xft as Xft -import Control.Applicative import Control.Monad import Control.Monad.Reader import Control.Monad.State.Lazy @@ -37,7 +36,6 @@ 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 @@ -61,10 +59,10 @@ , " || { grid.west(); next }" , " || { grid.north(); next }" , " || { grid.south(); next }" - , " { foo = grid.selected; print foo[\"value\"]; exit }" + , " { if (grid.selected) { print grid.selected [\"value\"] }; exit }" , " { grid.next(); next }" , " { grid.prev(); next }" - , "BEGIN { foo = grid.selected; if (foo) { label.label = foo[\"name\"] } }" + , "BEGIN { if (grid.selected) { label.label = grid.selected[\"name\"] } }" , "grid.selected->changed(from, to) { if (to) { label.label = to[\"name\"] } }" ] classMap' = M.insert "Grid" mkGrid classMap @@ -78,26 +76,36 @@ instance Show Element where show = show . elementName +instance Mold Element where + mold = const Nothing + unmold e = Dict $ M.fromList + [ (unmold "name", unmold $ elementName e) + , (unmold "subnames", dict $ elementSubnames e) + , (unmold "tags", dict $ elementTags e) + , (unmold "value", unmold $ elementValue e)] + where dict = Dict . M.fromList . zip (map Number [0..]) . map unmold + data DisplayedElement = DisplayedElement { displayedName :: String , displayedSubnames :: [String] , displayedElement :: Element } deriving (Show) -match :: T.Text -> Element -> Bool -match f e = (T.toCaseFold f `T.isInfixOf`) `any` - map T.toCaseFold (elementName e : elementSubnames e ++ elementTags e) +matchEl :: T.Text -> Element -> Bool +matchEl pat e = matchEl' `all` T.words (T.toCaseFold pat) + where es = map T.toCaseFold (elementName e : elementSubnames e ++ elementTags e) + matchEl' w = (isJust . match w) `any` es type TwoDPos = (Integer, Integer) type TwoDElement = (TwoDPos, DisplayedElement) -diamondLayer :: (Enum b', Num b') => b' -> [(b', b')] +diamondLayer :: Integral a => a -> [(a, a)] 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 :: Integral a => [(a, a)] diamond = concatMap diamondLayer [0..] diamondRestrict :: Integer -> Integer -> [TwoDPos] @@ -149,16 +157,9 @@ , gridRect :: Rectangle } -selection :: Grid -> Value -selection g = maybe falsity (asDict . displayedElement) - $ M.lookup (position grid) $ elements grid +selection :: Grid -> Maybe Element +selection g = liftM 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 gridBox :: Drawer -> Element -> SindreX11M DisplayedElement gridBox d e@Element { elementName = text, elementSubnames = subs } = do @@ -193,8 +194,8 @@ then sw ns else return n -recomputeMap :: Drawer -> ObjectM Grid SindreX11M () -recomputeMap d = do +recomputeMap :: X11Field Grid (Maybe Element) -> Drawer -> ObjectM Grid SindreX11M () +recomputeMap sel d = changingField sel $ do Rectangle _ _ rwidth rheight <- gets gridRect oldpos <- gets $ position . gridElementMap let restriction ss cs = (ss/cs-1)/2 :: Double @@ -202,33 +203,29 @@ 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) + 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 +updateRect :: X11Field Grid (Maybe Element) -> Rectangle -> Drawer -> ObjectM Grid SindreX11M () +updateRect sel r1 d = do r2 <- gets gridRect + unless (r1 == r2) $ do + modify $ \s -> s { gridRect = r1 } + recomputeMap sel d methInsert :: T.Text -> ObjectM Grid SindreX11M () methInsert vs = case partitionEithers $ parser vs of @@ -238,7 +235,7 @@ modify $ \s -> s { gridElems = gridElems s ++ els' , gridSelElems = gridSelElems s ++ - filter (match $ gridFilter s) els' } + filter (matchEl $ gridFilter s) els' } needRecompute where parser = map parseElement . T.lines @@ -259,21 +256,20 @@ , 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 +methFilter :: X11Field Grid (Maybe Element) -> T.Text -> ObjectM Grid SindreX11M () +methFilter sel f = changingField sel $ do + modify $ \s -> s { gridSelElems = filter (matchEl f) $ gridElems s } + needRecompute -methNext :: ObjectM Grid SindreX11M () -methPrev :: ObjectM Grid SindreX11M () +methNext :: X11Field Grid (Maybe Element) -> ObjectM Grid SindreX11M () +methPrev :: X11Field Grid (Maybe Element) -> 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 + where circle f sel = changingField sel $ do + elems@ElementGrid{position=(x,y)} <- gets gridElementMap + modify $ \s -> 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 @@ -295,45 +291,56 @@ (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 +move :: X11Field Grid (Maybe Element) + -> (ElementGrid -> Maybe ElementGrid) -> ObjectM Grid SindreX11M () +move sel d = changingField sel $ do + modify $ \s -> 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 ++ "'" +mkGrid :: Constructor SindreX11M +mkGrid wn [] = do + visual <- visualOpts wn + let grid = Grid { gridElems = [] + , gridSelElems = [] + , gridFilter = T.empty + , gridElementMap = emptyGrid + , gridVisual = visual + , gridRect = Rectangle 0 0 0 0 + } + return $ newWidget grid methods [field sel, field elms] + (const $ return ()) composeI (drawI visual) + where methods = M.fromList + [ ("insert", function methInsert) + , ("removeValue", function methRemoveByValue) + , ("removeName", function methRemoveByName) + , ("clear", function methClear) + , ("filter", function $ methFilter sel) + , ("next", function $ methNext sel) + , ("prev", function $ methPrev sel) + , ("north", function $ move sel north) + , ("south", function $ move sel south) + , ("west", function $ move sel west) + , ("east", function $ move sel east)] + sel = ReadOnlyField "selected" $ gets selection + elms = ReadOnlyField "elements" $ + Dict <$> M.fromList <$> + zip (map Number [1..]) <$> + map (unmold . elementValue) <$> gets gridSelElems + composeI = return (Unlimited, Unlimited) + drawI visual = drawing visual $ \r d fd -> do + updateRect sel 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 +mkGrid _ _ = error "Grids do not have children" -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 @@ -369,19 +376,6 @@ 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 diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,26 +0,0 @@ -`gsmenu` - a generic visual menu -================================ - -`gsmenu` is a program that reads a list of entries from standard input -(one per line) and provides a visual, grid-based interface from which -the user can select one, with either mouse or keyboard. The manual -page contains full documentation. - -Installation ------------- - -Assuming a working Cabal install, just do 'cabal install'. Any -missing dependencies will automatically be downloaded and installed. -You may have to perform a 'cabal update' first to ensure that your -package list is up to date. - -Inspiration ------------ - -This program is mostly a port of the GridSelect contrib for XMonad by -Clemens Fruhwirth. - -Bugs ----- - -Please report any found bugs to the maintainer at . diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/env runhaskell - -import Distribution.Simple.Setup (CopyDest(..),ConfigFlags(..),BuildFlags(..), - CopyFlags(..),RegisterFlags(..),InstallFlags(..), - defaultRegisterFlags,fromFlagOrDefault,Flag(..), - defaultCopyFlags) -import Distribution.Simple -import Distribution.Simple.LocalBuildInfo - (LocalBuildInfo(..),absoluteInstallDirs) -import Distribution.Simple.Configure (configCompilerAux) -import Distribution.PackageDescription (PackageDescription(..)) -import Distribution.Simple.InstallDirs - (InstallDirs(..)) -import Distribution.Simple.Program - (Program(..),ConfiguredProgram(..),ProgramConfiguration(..), - ProgramLocation(..),simpleProgram,lookupProgram, - rawSystemProgramConf) -import Distribution.Simple.Utils -import Distribution.Verbosity -import Data.Char (isSpace, showLitChar) -import Data.List (isSuffixOf,isPrefixOf) -import Data.Maybe (listToMaybe,isJust) -import Data.Version -import Control.Monad (when,unless) -import Text.ParserCombinators.ReadP (readP_to_S) -import System.Exit -import System.IO (hGetContents,hClose,hPutStr,stderr) -import System.IO.Error (try) -import System.Process (runInteractiveProcess,waitForProcess) -import System.Posix -import System.Directory -import System.Info (os) -import System.FilePath - -main = defaultMainWithHooks gsmenuHooks -gsmenuHooks = simpleUserHooks { postInst = gsmenuPostInst - , postCopy = gsmenuPostCopy } - -gsmenu = "gsmenu" - -isWindows :: Bool -isWindows = os == "mingw" -- XXX - -gsmenuPostInst a (InstallFlags { installPackageDB = db, installVerbosity = v }) pd lbi = - do gsmenuPostCopy a (defaultCopyFlags { copyDest = Flag NoCopyDest, copyVerbosity = v }) pd lbi - -gsmenuPostCopy a (CopyFlags { copyDest = cdf, copyVerbosity = vf }) pd lbi = - do let v = fromFlagOrDefault normal vf - cd = fromFlagOrDefault NoCopyDest cdf - dirs = absoluteInstallDirs pd lbi cd - bin = combine (bindir dirs) - when (not isWindows) $ do - copyFileVerbose v ("gsmenu_path") (bin "gsmenu_path") - fs <- getFileStatus (bin "gsmenu") - setFileMode (bin "gsmenu_path") $ fileMode fs - putStrLn $ "Installing manpage in " ++ mandir dirs - createDirectoryIfMissing True $ mandir dirs `combine` "man1" - copyFileVerbose v ("gsmenu.1") (mandir dirs `combine` "man1" `combine` "gsmenu.1") diff --git a/gsmenu.1 b/gsmenu.1 deleted file mode 100644 --- a/gsmenu.1 +++ /dev/null @@ -1,110 +0,0 @@ -.TH GSMENU 1 gsmenu\-4.0 -.SH NAME -gsmenu \- grid menu -.SH SYNOPSIS -.nh -gsmenu -[Sindre options...] -.SH DESCRIPTION -.SS Overview -gsmenu is a generic grid menu for X11, originally a port of the -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 -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 are used only for filtering. -.SS INPUT FORMAT -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" -.fi - -And a list-value can be given by simply writing more double-quoted -strings (this also showcases double quote-escaping): - -.nf -name="quote ""this"" please" tags="bar" "baz" bg="red" -.fi - -The following keys are defined: -.TP -.B name -The string that will be displayed in the grid. 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 -names are supported). -.TP -.B bg -The background colour of the element (#RGB, #RRGGBB, and color -names are supported). -.TP -.B tags -A list of tags of the element, used when filtering. -.TP -.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. -.SS INTERACTION -When the user moves focus to an element and presses Return, that -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: -only items containing this text (possibly in a tag) will be displayed. -.TP -.B Backspace -Remove the last character in the input field, or if empty, open the -topmost filter for editing. -.TP -.B Left/Right/Up/Down (CTRL\-b/CTRL-f/CTRL\-p/CTRL\-n) -Move focus in the grid. -.TP -.B CTRL\-a -Set focus to the leftmost element in the row. -.TP -.B CTRL\-e -Set focus to the rightmost element in the row. -.TP -.B CTRL\-s -Focus on the next element following a spiral path from the center. -.TP -.B CTRL\-r -Focus on the previous element following a spiral path from the center. -.TP -.B CTRL\-w -Remove the topmost filter, if any. -.TP -.B Escape, CTRL\-c, CTRL\-g -Cancel selection and exit gsmenu. -.SH EXIT STATUS -gsmenu returns a -.B 0 -exit status on success, -.B 1 -if there was an internal problem, and -.B 2 -if the user cancelled. -.SH SEE ALSO -.IR sindre (1), -.IR dmenu (1), -.IR xmonad (1) diff --git a/gsmenu.cabal b/gsmenu.cabal --- a/gsmenu.cabal +++ b/gsmenu.cabal @@ -1,28 +1,27 @@ +cabal-version: 2.4 name: gsmenu -version: 3.0 +version: 3.1 homepage: http://sigkill.dk/programs/gsmenu synopsis: A visual generic menu description: Grid-oriented element selection inspired by XMonadContrib's GridSelect. category: Tools -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Troels Henriksen maintainer: athas@sigkill.dk -cabal-version: >= 1.6 -build-type: Custom source-repository head type: git location: git@github.com:Athas/gsmenu.git executable gsmenu - build-depends: X11>=1.5.0.0 && < 1.6, mtl, base==4.*, - containers, parsec==3.*, sindre>=0.2, text, permute + build-depends: X11>=1.5.0.0, mtl, base==4.*, + containers, parsec>=3, sindre>=0.6, text, permute main-is: Main.hs ghc-options: -funbox-strict-fields -Wall - ghc-prof-options: -prof -auto-all -rtsopts - extensions: CPP + ghc-prof-options: -rtsopts + default-language: Haskell2010 diff --git a/gsmenu_path b/gsmenu_path deleted file mode 100644 --- a/gsmenu_path +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh -CACHE=$HOME/.gsmenu_cache -IFS=: - -uptodate() { - test -f "$CACHE" && - for dir in $PATH - do - test ! $dir -nt "$CACHE" || return 1 - done -} - -if ! uptodate -then - for dir in $PATH - do - tags="" - IFS=/ - for part in $dir - do - tags="\"$part\" ${tags}" - done - if [ ${tags} != '' ] - then - tags="tags=$tags" - fi - cd "$dir" && - for file in * - do - test -x "$file" && echo "name=\"$(echo $file|sed 's/"/""/g')\" \"$dir\" $tags" - done - done | sort | uniq > "$CACHE".$$ && - mv "$CACHE".$$ "$CACHE" -fi - -cat "$CACHE"