Merge remote-tracking branch 'cd/master'

1 files changed, 369 insertions, 0 deletions

diff --git a/tv/5pkgs/xmonad-tv/Util/Rhombus.hs b/tv/5pkgs/xmonad-tv/Util/Rhombus.hs
new file mode 100644
index 000000000..9d46e4127
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/Util/Rhombus.hs
@@ -0,0 +1,369 @@
+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