gsmenu-3.1: Main.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Main
-- Author : Troels Henriksen <athas@sigkill.dk>
-- License : MIT-style (see LICENSE)
--
-- Stability : stable
-- Portability : unportable
--
-- gsmenu, a generic grid-based menu.
--
-----------------------------------------------------------------------------
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.Monad
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Data.Either
import Data.List
import Data.Maybe
import Data.Ord (comparing)
import Data.Word (Word8)
import qualified Data.Map as M
import qualified Data.Text as T
import Text.Printf
import System.Environment
-- | 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; }"
, "<C-g> || <Escape> { exit 2 }"
, "stdin->lines(lines) { grid.insert(lines); }"
, "input.value->changed(from, to) { grid.filter(to) }"
, "<Right> || <C-f> { grid.east(); next }"
, "<Left> || <C-b> { grid.west(); next }"
, "<Up> || <C-p> { grid.north(); next }"
, "<Down> || <C-n> { grid.south(); next }"
, "<Return> { if (grid.selected) { print grid.selected [\"value\"] }; exit }"
, "<C-s> { grid.next(); next }"
, "<C-r> { grid.prev(); next }"
, "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
data Element = Element { elementName :: T.Text
, elementSubnames :: [T.Text]
, elementTags :: [T.Text]
, elementFg :: Xft.Color
, elementBg :: Xft.Color
, elementValue :: T.Text }
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)
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 :: 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 :: Integral a => [(a, a)]
diamond = concatMap diamondLayer [0..]
diamondRestrict :: Integer -> Integer -> [TwoDPos]
diamondRestrict x y =
filter (\(x',y') -> abs x' <= x && abs y' <= y) .
map (\(x', y') -> (x', y')) .
take 1000 $ diamond
data ElementGrid =
ElementGrid { position :: TwoDPos
, elements :: M.Map TwoDPos DisplayedElement }
deriving (Show)
emptyGrid :: ElementGrid
emptyGrid = ElementGrid (0,0) M.empty
gridMove :: (TwoDPos -> TwoDPos) -> ElementGrid -> Maybe ElementGrid
gridMove f grid = const (grid { position = pos' })
<$> M.lookup pos' (elements grid)
where pos' = f $ position grid
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)
gridToList :: ElementGrid -> [TwoDElement]
gridToList = M.toList . elements
gridFromMap :: M.Map TwoDPos DisplayedElement -> TwoDPos -> ElementGrid
gridFromMap = flip ElementGrid
cellWidth :: Num a => a
cellWidth = 130
cellHeight :: Num a => a
cellHeight = 50
cellPadding :: Num a => a
cellPadding = 10
data Grid = Grid { gridElems :: [Element]
, gridSelElems :: [Element]
, gridFilter :: T.Text
, gridElementMap :: ElementGrid
, gridVisual :: VisualOpts
, gridRect :: Rectangle
}
selection :: Grid -> Maybe Element
selection g = liftM displayedElement $ M.lookup (position grid) $ elements grid
where grid = gridElementMap g
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 :: 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
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
elmap <- buildGrid =<< gets gridSelElems
let grid = gridFromMap elmap (0,0)
modify $ \s -> s { gridElementMap =
grid { position = bestpos oldpos $
map fst $ gridToList grid }
}
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 :: 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
(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 (matchEl $ 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 :: 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 :: X11Field Grid (Maybe Element) -> ObjectM Grid SindreX11M ()
methPrev :: X11Field Grid (Maybe Element) -> ObjectM Grid SindreX11M ()
(methNext, methPrev) = (circle next, circle prev)
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
(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 :: 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
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"
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
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)
in ("white", '#' : concatMap (twodigitHex.(round :: Double -> Word8).(*256)) [r, g, b] )
where s = show ts
twodigitHex :: Word8 -> String
twodigitHex = printf "%02x"