371 lines
13 KiB
Haskell
371 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.Debunk
|
||
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
|