370 lines
13 KiB
Haskell
370 lines
13 KiB
Haskell
|
module Util.Rhombus
|
|||
|
|
( defaultRhombusConfig
|
|||
|
|
, MatchMethod(..)
|
|||
|
|
, rhombus
|
|||
|
|
, RhombusConfig(..)
|
|||
|
|
, RhombusState(..)
|
|||
|
|
) where
|
|||
|
|
|
|||
|
|
import Control.Monad ( forM_, zipWithM_ )
|
|||
|
|
import Data.Char
|
|||
|
|
import Data.List
|
|||
|
|
import Data.Ord
|
|||
|
|
import Data.Map ( fromList )
|
|||
|
|
import Data.Maybe ( isJust, fromJust )
|
|||
|
|
import XMonad
|
|||
|
|
import XMonad.StackSet hiding ( filter )
|
|||
|
|
import XMonad.Util.Font
|
|||
|
|
import XMonad.Util.Image ( drawIcon )
|
|||
|
|
import XMonad.Util.XUtils
|
|||
|
|
|
|||
|
|
import Util.Submap
|
|||
|
|
import Util.XUtils
|
|||
|
|
import Util.Font
|
|||
|
|
|
|||
|
|
|
|||
|
|
data MatchMethod = MatchInfix | MatchPrefix
|
|||
|
|
|
|||
|
|
data RhombusConfig = RhombusConfig
|
|||
|
|
{ rc_font :: String
|
|||
|
|
, rc_cellwidth :: Dimension
|
|||
|
|
, rc_margin :: Dimension
|
|||
|
|
, rc_matchmethod :: MatchMethod
|
|||
|
|
, rc_wrap :: Bool
|
|||
|
|
, rc_colors :: Bool -> Bool -> Bool -> (String, String, String)
|
|||
|
|
, rc_paint :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X ()
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
-- TODO currently xft is broken
|
|||
|
|
defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint
|
|||
|
|
where
|
|||
|
|
stupidColors _ _ _ = ("red", "magenta", "yellow")
|
|||
|
|
noPaint _ _ _ _ _ _ _ _ _ = return ()
|
|||
|
|
|
|||
|
|
|
|||
|
|
data RhombusState = RhombusState
|
|||
|
|
{ rs_window :: Window
|
|||
|
|
, rs_search :: String
|
|||
|
|
, rs_font :: XMonadFont
|
|||
|
|
, rs_focus :: (Position, Position)
|
|||
|
|
, rs_strings :: [String]
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
reachableCoords :: RhombusState -> [(Position, Position)]
|
|||
|
|
reachableCoords RhombusState{rs_strings=xs} = take (length xs) wave
|
|||
|
|
|
|||
|
|
|
|||
|
|
matchingReachableCoords :: RhombusConfig -> RhombusState -> [(Position, Position)]
|
|||
|
|
matchingReachableCoords rc rs =
|
|||
|
|
snd $ unzip
|
|||
|
|
$ filter (isXOf (rc_matchmethod rc) (rs_search rs) . fst)
|
|||
|
|
$ zip (rs_strings rs) (reachableCoords rs)
|
|||
|
|
|
|||
|
|
|
|||
|
|
match :: MatchMethod -> String -> [String] -> Maybe String
|
|||
|
|
match m s ws = do
|
|||
|
|
let cands = filter (isXOf m s) ws
|
|||
|
|
if length cands == 1
|
|||
|
|
then Just $ head cands
|
|||
|
|
else Nothing
|
|||
|
|
|
|||
|
|
rhombus :: RhombusConfig -> (String -> X ()) -> [String] -> X ()
|
|||
|
|
rhombus rc viewFunc as = withGrabbedKeyboard $ do
|
|||
|
|
rs <- newRhombus rc as
|
|||
|
|
--redraw rc rs
|
|||
|
|
showWindow (rs_window rs)
|
|||
|
|
rhombusMode viewFunc rc rs
|
|||
|
|
|
|||
|
|
|
|||
|
|
rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X ()
|
|||
|
|
rhombusMode viewFunc rc rs =
|
|||
|
|
case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of
|
|||
|
|
Nothing -> redraw rc rs >> submapString def keys
|
|||
|
|
Just i -> removeRhombus rs >> viewFunc i
|
|||
|
|
where
|
|||
|
|
def (ch:[]) | isPrint ch =
|
|||
|
|
incSearchPushChar ch rs >>= rhombusMode viewFunc rc
|
|||
|
|
|
|||
|
|
def _ =
|
|||
|
|
failbeep >> rhombusMode viewFunc rc rs
|
|||
|
|
|
|||
|
|
keys = fromList $
|
|||
|
|
[ ((0 , xK_BackSpace ), incSearchPopChar rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((0 , xK_Escape ), removeRhombus rs)
|
|||
|
|
, ((0 , xK_Menu ), removeRhombus rs)
|
|||
|
|
, ((0 , xK_Left ), goto rc (-1, 0) rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((0 , xK_Right ), goto rc ( 1, 0) rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((0 , xK_Up ), goto rc ( 0,-1) rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((0 , xK_Down ), goto rc ( 0, 1) rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((0 , xK_Tab ), gotoNextMatch rc rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((_S , xK_Tab ), gotoPrevMatch rc rs >>= rhombusMode viewFunc rc)
|
|||
|
|
, ((0 , xK_Return ), removeRhombus rs >> return (selectFocused rs) >>= viewFunc)
|
|||
|
|
]
|
|||
|
|
|
|||
|
|
_S = shiftMask
|
|||
|
|
|
|||
|
|
|
|||
|
|
-- TODO make failbeep configurable
|
|||
|
|
failbeep = spawn "beep -l 100 -f 500"
|
|||
|
|
|
|||
|
|
|
|||
|
|
goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
|
|||
|
|
goto RhombusConfig{rc_wrap=True} xy rs = maybe (failbeep >> return rs) return $ wrapFocus xy rs
|
|||
|
|
goto RhombusConfig{rc_wrap=False} xy rs = maybe (failbeep >> return rs) return $ moveFocus xy rs
|
|||
|
|
|
|||
|
|
|
|||
|
|
moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
|
|||
|
|
moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do
|
|||
|
|
let focus' = (x + dx, y + dy)
|
|||
|
|
if elem focus' (reachableCoords rs)
|
|||
|
|
then Just rs { rs_focus = focus' }
|
|||
|
|
else Nothing
|
|||
|
|
|
|||
|
|
|
|||
|
|
wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
|
|||
|
|
|
|||
|
|
wrapFocus (0, dy) rs@RhombusState{rs_focus=focus} = do
|
|||
|
|
let column = sortBy (comparing snd) $ filter ((==) (fst focus) . fst) (reachableCoords rs)
|
|||
|
|
i <- elemIndex focus column
|
|||
|
|
return rs { rs_focus = column `modIndex` (i + fromIntegral dy) }
|
|||
|
|
|
|||
|
|
wrapFocus (dx, 0) rs@RhombusState{rs_focus=focus} = do
|
|||
|
|
let column = sortBy (comparing fst) $ filter ((==) (snd focus) . snd) (reachableCoords rs)
|
|||
|
|
i <- elemIndex focus column
|
|||
|
|
return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }
|
|||
|
|
|
|||
|
|
wrapFocus _ _ = Nothing
|
|||
|
|
|
|||
|
|
|
|||
|
|
gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
|
|||
|
|
gotoPrevMatch rc rs@RhombusState{rs_focus=focus} = do
|
|||
|
|
case reverse (matchingReachableCoords rc rs) of
|
|||
|
|
[] -> failbeep >> return rs
|
|||
|
|
xs -> return rs
|
|||
|
|
{ rs_focus = maybe (head xs)
|
|||
|
|
(modIndex xs . (+1))
|
|||
|
|
(focus `elemIndex` xs)
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
|
|||
|
|
gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do
|
|||
|
|
case matchingReachableCoords rc rs of
|
|||
|
|
[] -> failbeep >> return rs
|
|||
|
|
xs -> return rs
|
|||
|
|
{ rs_focus = maybe (head xs)
|
|||
|
|
(modIndex xs . (+1))
|
|||
|
|
(focus `elemIndex` xs)
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
selectFocused :: RhombusState -> String
|
|||
|
|
selectFocused rs =
|
|||
|
|
-- TODO the rhombus must never "focus" something inexistent
|
|||
|
|
fromJust $ lookup (rs_focus rs) $ zip wave (rs_strings rs)
|
|||
|
|
|
|||
|
|
|
|||
|
|
incSearchPushChar :: Char -> RhombusState -> X RhombusState
|
|||
|
|
incSearchPushChar c rs = return rs { rs_search = rs_search rs ++ [c] }
|
|||
|
|
|
|||
|
|
|
|||
|
|
incSearchPopChar :: RhombusState -> X RhombusState
|
|||
|
|
|
|||
|
|
-- only rubout if we have at least one char
|
|||
|
|
incSearchPopChar rs@RhombusState{rs_search=xs@(_:_)} =
|
|||
|
|
return rs { rs_search = init xs }
|
|||
|
|
|
|||
|
|
incSearchPopChar rs = return rs
|
|||
|
|
|
|||
|
|
|
|||
|
|
redraw :: RhombusConfig -> RhombusState -> X ()
|
|||
|
|
redraw rc rs = do
|
|||
|
|
ss <- gets windowset
|
|||
|
|
|
|||
|
|
let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
|
|||
|
|
|
|||
|
|
-- TODO this let is duplicated in newRhombus
|
|||
|
|
let scale x = x * cell_w `div` s_width -- TODO use bw
|
|||
|
|
cell_w = rc_cellwidth rc
|
|||
|
|
cell_h = scale s_height
|
|||
|
|
|
|||
|
|
-- txy is the top-left corner of the first (center) cell
|
|||
|
|
-- XXX div and (-) are not distributive
|
|||
|
|
-- we could round $ (s_* - cell_*) / 2, though...
|
|||
|
|
tx = fi $ s_width `div` 2 - cell_w `div` 2
|
|||
|
|
ty = fi $ s_height `div` 2 - cell_h `div` 2
|
|||
|
|
|
|||
|
|
margin = rc_margin rc
|
|||
|
|
|
|||
|
|
-- dxy are the outer cell dimensions (i.e. including the border)
|
|||
|
|
dx = fi $ cell_w + 2 + margin
|
|||
|
|
dy = fi $ cell_h + 2 + margin
|
|||
|
|
|
|||
|
|
paint = rc_paint rc
|
|||
|
|
xmf = rs_font rs
|
|||
|
|
tags = rs_strings rs
|
|||
|
|
--currentTag = last tags
|
|||
|
|
|
|||
|
|
withDisplay $ \ d -> do
|
|||
|
|
-- XXX we cannot use withPixmapAndGC because rc_paint is an X monad
|
|||
|
|
p <- io $ createPixmap d (rs_window rs) s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d)
|
|||
|
|
g <- io $ createGC d p
|
|||
|
|
|
|||
|
|
-- TODO fixme
|
|||
|
|
color_black <- stringToPixel d "black"
|
|||
|
|
|
|||
|
|
forZipWithM_ tags (reachableCoords rs) $ \ tag oxy@(ox, oy) -> do
|
|||
|
|
|
|||
|
|
let focus = oxy == rs_focus rs
|
|||
|
|
match = isXOf (rc_matchmethod rc) (rs_search rs) tag
|
|||
|
|
current = tag == last tags
|
|||
|
|
(_b_color, _bg_color, _fg_color) = rc_colors rc focus match current
|
|||
|
|
--cell_x = (ox * dx) + x - fi (cell_w `div` 2)
|
|||
|
|
--cell_y = (oy * dy) + y - fi (cell_h `div` 2)
|
|||
|
|
cell_x = (ox * dx) + tx + 1
|
|||
|
|
cell_y = (oy * dy) + ty + 1
|
|||
|
|
|
|||
|
|
b_color <- stringToPixel d _b_color
|
|||
|
|
bg_color <- stringToPixel d _bg_color
|
|||
|
|
fg_color <- stringToPixel d _fg_color
|
|||
|
|
|
|||
|
|
-- draw background
|
|||
|
|
io $ setForeground d g bg_color
|
|||
|
|
io $ fillRectangle d p g cell_x cell_y cell_w cell_h
|
|||
|
|
|
|||
|
|
-- draw border
|
|||
|
|
io $ setForeground d g b_color
|
|||
|
|
io $ drawLines d p g
|
|||
|
|
[ Point (cell_x - 1) (cell_y - 1)
|
|||
|
|
, Point (fi cell_w + 1) 0
|
|||
|
|
, Point 0 (fi cell_h + 1)
|
|||
|
|
, Point (-(fi cell_w + 1)) 0
|
|||
|
|
, Point 0 (-(fi cell_h + 1))
|
|||
|
|
]
|
|||
|
|
coordModePrevious
|
|||
|
|
|
|||
|
|
-- custom draw
|
|||
|
|
paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) focus match current
|
|||
|
|
|
|||
|
|
-- paint text
|
|||
|
|
-- TODO custom paint text?
|
|||
|
|
-- TODO withCopyArea
|
|||
|
|
io $ withPixmapAndGC d p s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) $ \ f_pm f_gc -> do
|
|||
|
|
withPixmapAndGC d f_pm s_width s_height 1 $ \ clip_mask clip_gc -> do
|
|||
|
|
setForeground d clip_gc 0
|
|||
|
|
setBackground d clip_gc 0
|
|||
|
|
fillRectangle d clip_mask clip_gc 0 0 s_width s_height
|
|||
|
|
setForeground d clip_gc 1
|
|||
|
|
|
|||
|
|
let r = Rectangle cell_x cell_y cell_w cell_h
|
|||
|
|
|
|||
|
|
printStringCentered d clip_mask xmf clip_gc r tag
|
|||
|
|
|
|||
|
|
setForeground d f_gc fg_color
|
|||
|
|
setBackground d f_gc color_black -- TODO
|
|||
|
|
|
|||
|
|
printStringCentered d f_pm xmf f_gc r tag
|
|||
|
|
|
|||
|
|
setClipMask d f_gc clip_mask
|
|||
|
|
|
|||
|
|
copyArea d f_pm p f_gc 0 0 s_width s_height 0 0
|
|||
|
|
|
|||
|
|
io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0
|
|||
|
|
io $ freePixmap d p
|
|||
|
|
io $ freeGC d g
|
|||
|
|
|
|||
|
|
|
|||
|
|
newRhombus :: RhombusConfig -> [String] -> X RhombusState
|
|||
|
|
newRhombus rc tags = do
|
|||
|
|
ss <- gets windowset
|
|||
|
|
|
|||
|
|
let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
|
|||
|
|
(_, def_win_bg, _) = rc_colors rc False True False
|
|||
|
|
|
|||
|
|
-- TODO this let is duplicated in redraw
|
|||
|
|
let scale x = x * cell_w `div` s_width -- TODO use bw
|
|||
|
|
cell_w = rc_cellwidth rc
|
|||
|
|
cell_h = scale s_height
|
|||
|
|
|
|||
|
|
-- TODO don't delete this let but use it instead of s_{width,height}
|
|||
|
|
-- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords
|
|||
|
|
-- win_width = (maximum xcoords - minimum xcoords) * dx
|
|||
|
|
-- win_height = (maximum ycoords - minimum ycoords) * dy
|
|||
|
|
|
|||
|
|
-- txy is the top-left corner of the first (center) cell
|
|||
|
|
-- XXX div and (-) are not distributive
|
|||
|
|
-- we could round $ (s_* - cell_*) / 2, though...
|
|||
|
|
tx = fi $ s_width `div` 2 - cell_w `div` 2
|
|||
|
|
ty = fi $ s_height `div` 2 - cell_h `div` 2
|
|||
|
|
|
|||
|
|
margin = rc_margin rc
|
|||
|
|
|
|||
|
|
-- dxy are the outer cell dimensions (i.e. including the border)
|
|||
|
|
dx = fi $ cell_w + 2 + margin
|
|||
|
|
dy = fi $ cell_h + 2 + margin
|
|||
|
|
|
|||
|
|
fn <- initXMF (rc_font rc)
|
|||
|
|
win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True
|
|||
|
|
|
|||
|
|
withDisplay $ \ d ->
|
|||
|
|
io $ shapeWindow d win $ \ p g ->
|
|||
|
|
forZipWithM_ tags wave $ \ _ (ox, oy) ->
|
|||
|
|
fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2)
|
|||
|
|
|
|||
|
|
return $ RhombusState win "" fn (0,0) tags
|
|||
|
|
|
|||
|
|
|
|||
|
|
removeRhombus :: RhombusState -> X ()
|
|||
|
|
removeRhombus (RhombusState w _ fn _ _) = do
|
|||
|
|
deleteWindow w
|
|||
|
|
releaseXMF fn
|
|||
|
|
|
|||
|
|
wave :: [(Position, Position)]
|
|||
|
|
wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..])
|
|||
|
|
where
|
|||
|
|
wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
|
|||
|
|
wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]
|
|||
|
|
|
|||
|
|
commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys
|
|||
|
|
commonPrefix _ _ = []
|
|||
|
|
|
|||
|
|
|
|||
|
|
isXOf :: MatchMethod -> String -> String -> Bool
|
|||
|
|
isXOf MatchInfix = isInfixOf
|
|||
|
|
isXOf MatchPrefix = isPrefixOf
|
|||
|
|
|
|||
|
|
|
|||
|
|
findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int
|
|||
|
|
findXIndex MatchInfix = findInfixIndex
|
|||
|
|
findXIndex MatchPrefix = findPrefixIndex
|
|||
|
|
|
|||
|
|
|
|||
|
|
findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
|
|||
|
|
findInfixIndex needle haystack
|
|||
|
|
= (\x -> if null x then Nothing else Just (fst $ head x))
|
|||
|
|
. dropWhile (\(_,x) -> not $ isPrefixOf needle x)
|
|||
|
|
$ zip [0..] (tails haystack)
|
|||
|
|
|
|||
|
|
|
|||
|
|
findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
|
|||
|
|
findPrefixIndex needle haystack =
|
|||
|
|
if isPrefixOf needle haystack
|
|||
|
|
then Just 0
|
|||
|
|
else Nothing
|
|||
|
|
|
|||
|
|
|
|||
|
|
modIndex :: Integral i => [a] -> i -> a
|
|||
|
|
modIndex xs i = xs `genericIndex` (i `mod` genericLength xs)
|
|||
|
|
|
|||
|
|
|
|||
|
|
forZipWithM_ a b f = zipWithM_ f a b
|
|||
|
|
|
|||
|
|
|
|||
|
|
withGrabbedKeyboard f = do
|
|||
|
|
XConf { theRoot = root, display = d } <- ask
|
|||
|
|
catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
|
|||
|
|
(return ())
|
|||
|
|
io $ ungrabKeyboard d currentTime
|