{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Sindre.X11 -- License : MIT-style (see LICENSE) -- -- Stability : provisional -- Portability : unportable -- -- X11 backend for Sindre. For internationalised keyboard input to -- work, make sure the locale is correctly set. -- ----------------------------------------------------------------------------- module Sindre.X11( SindreX11M , SindreX11Conf(sindreDisplay, sindreXftMgr) , sindreX11override , sindreX11dock , sindreX11 , xopt , VisualOpts(..) , visualOpts , allocColor , drawing , drawing' , Drawer(..) , setFgColor , setBgColor , textExtents , drawText , mkDial , mkLabel , mkBlank , mkTextField , mkInStream , mkHList , mkVList ) where import Sindre.Sindre import Sindre.Compiler import Sindre.Formatting import Sindre.KeyVal ((<$?>), (<||>)) import qualified Sindre.KeyVal as KV import Sindre.Lib import Sindre.Runtime import Sindre.Util import Sindre.Widgets import Graphics.X11.Xlib hiding ( refreshKeyboardMapping , Rectangle , badValue , resourceManagerString , textWidth , allocColor , textExtents ) import Graphics.X11.XRM import qualified Graphics.X11.Xft as Xft import Graphics.X11.Xim import Graphics.X11.Xinerama import Graphics.X11.Xlib.Extras hiding (Event, getEvent) import Graphics.X11.Xshape import qualified Graphics.X11.Xlib as X import qualified Graphics.X11.Xlib.Extras as X import System.Environment import System.Exit import System.IO import System.Posix.Types import Control.Arrow(first,second) import Control.Concurrent import Control.Applicative import Control.Exception import Control.Monad.Reader import Control.Monad.State import Data.Bits import Data.Char hiding (Control) import Data.Maybe import Data.List import qualified Data.ByteString as B import qualified Data.Map as M import Data.Monoid import Data.Ord import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as E import Prelude hiding (catch) fromXRect :: X.Rectangle -> Rectangle fromXRect r = Rectangle { rectX = fi $ rect_x r , rectY = fi $ rect_y r , rectWidth = fi $ rect_width r , rectHeight = fi $ rect_height r } type EventThunk = Sindre SindreX11M (Maybe Event) data Surface = Surface { surfaceBounds :: Rectangle , surfaceShape :: Drawable , surfaceMaskGC :: GC , surfaceUnmaskGC :: GC , surfaceCanvas :: Drawable , surfaceWindow :: Window , surfaceWindowGC :: GC , surfaceScreen :: Screen , surfaceXftDraw :: Xft.Draw } newSurfaceWithGC :: Display -> Xft.XftMgr -> Screen -> Window -> GC -> Rectangle -> IO Surface newSurfaceWithGC dpy mgr scr win wingc r = do pm <- createPixmap dpy win (fi $ rectWidth r) (fi $ rectHeight r) 1 maskgc <- createGC dpy pm setForeground dpy maskgc 0 unmaskgc <- createGC dpy pm setForeground dpy unmaskgc 1 canvas <- createPixmap dpy win (fi $ rectWidth r) (fi $ rectHeight r) $ defaultDepthOfScreen scr drw <- Xft.openDraw mgr canvas (defaultVisualOfScreen scr) (defaultColormap dpy $ defaultScreen dpy) drw' <- maybe (fail "Could not allocate Xft drawable") return drw return $ Surface r { rectX = 0, rectY = 0 } pm maskgc unmaskgc canvas win wingc scr drw' newSurface :: Display -> Xft.XftMgr -> Screen -> Window -> Rectangle -> IO Surface newSurface dpy mgr scr win r = do wingc <- createGC dpy win setGraphicsExposures dpy wingc False newSurfaceWithGC dpy mgr scr win wingc r resizeSurface :: Display -> Xft.XftMgr -> Surface -> Rectangle -> IO Surface resizeSurface dpy mgr s r = do mapM_ (freeGC dpy) [surfaceMaskGC s, surfaceUnmaskGC s] mapM_ (freePixmap dpy) [surfaceShape s, surfaceCanvas s] newSurfaceWithGC dpy mgr (surfaceScreen s) (surfaceWindow s) (surfaceWindowGC s) r setShape :: Display -> Surface -> [Rectangle] -> IO () setShape dpy s rects = do fillRectangle dpy (surfaceShape s) (surfaceMaskGC s) 0 0 (fi $ rectWidth $ surfaceBounds s) (fi $ rectHeight $ surfaceBounds s) forM_ rects $ \rect -> fillRectangle dpy (surfaceShape s) (surfaceUnmaskGC s) (fi $ rectX rect) (fi $ rectY rect) (fi $ rectWidth rect) (fi $ rectHeight rect) xshapeCombineMask dpy (surfaceWindow s) shapeBounding 0 0 (surfaceShape s) shapeSet copySurface :: Display -> Surface -> [Rectangle] -> IO () copySurface dpy s rects = do let Rectangle{..} = mconcat rects copyArea dpy (surfaceCanvas s) (surfaceWindow s) (surfaceWindowGC s) (fi rectX) (fi rectY) (fi rectWidth) (fi rectHeight) (fi rectX) (fi rectY) -- | The read-only configuration of the X11 backend, created during -- backend initialisation. data SindreX11Conf = SindreX11Conf { sindreDisplay :: Display -- ^ The display that we are connected to. , sindreVisualOpts :: VisualOpts -- ^ The default visual options (color, font, etc) used if no -- others are specified for a widget. , sindreRMDB :: Maybe RMDatabase -- ^ The X11 resource database (Xdefaults/Xresources). , sindreXlock :: Xlock -- ^ Synchronisation lock for Xlib access. , sindreEvtVar :: MVar EventThunk -- ^ Channel through which events are sent by other threads to the -- Sindre command loop. , sindreReshape :: [Rectangle] -> SindreX11M () -- ^ Function to set the shape of the X11 window to the union of the -- given rectangles. , sindreXftMgr :: Xft.XftMgr -- ^ Bookkeeping primitive for Xft font handling. } -- | Sindre backend using Xlib. newtype SindreX11M a = SindreX11M (ReaderT SindreX11Conf (StateT Surface IO) a) deriving ( Functor, Monad, MonadIO , MonadReader SindreX11Conf, MonadState Surface, Applicative) runSindreX11 :: SindreX11M a -> SindreX11Conf -> Surface -> IO a runSindreX11 (SindreX11M m) = evalStateT . runReaderT m instance MonadBackend SindreX11M where type BackEvent SindreX11M = (KeySym, String, X.Event) type RootPosition SindreX11M = (Align, Align) redrawRoot = do SindreX11Conf{ sindreReshape=reshape } <- back ask sur <- back get (orient, rootwr) <- gets rootWidget reqs <- compose rootwr let winsize = surfaceBounds sur orient' = fromMaybe (AlignCenter, AlignCenter) orient rect = adjustRect orient' winsize $ fitRect winsize reqs usage <- draw rootwr $ Just rect back $ reshape usage redrawRegion usage redrawRegion rects = back $ do SindreX11Conf{ sindreDisplay=dpy } <- ask sur <- get io $ copySurface dpy sur rects >> sync dpy False waitForBackEvent = do back unlockX evvar <- back $ asks sindreEvtVar evm <- io $ takeMVar evvar ev <- evm back lockX maybe waitForBackEvent return ev getBackEvent = do io yield back (io . tryTakeMVar =<< asks sindreEvtVar) >>= fromMaybe (return Nothing) printVal s = io $ putStr s *> hFlush stdout textExtents :: Xft.Font -> String -> SindreX11M (Int, Int) textExtents font s = do dpy <- asks sindreDisplay w <- io $ Xft.textWidth dpy font s return (w, Xft.height font) drawText :: (Integral x, Integral y, Integral z) => Xft.Color -> Xft.Font -> x -> y -> z -> String -> SindreX11M () drawText col font x y h str = do drw <- gets surfaceXftDraw (_,h') <- textExtents font str let y' = Xft.ascent font + align AlignCenter (fi y) h' (fi y+fi h) io $ Xft.drawString drw col font x y' str drawFmt :: Drawer -> Rectangle -> FormatString -> SindreX11M () drawFmt d Rectangle{..} fs = do mgr <- asks sindreXftMgr drw <- gets surfaceXftDraw d'' <- case startBg fs of Nothing -> return d Just col -> io . setBgColor d =<< allocColor mgr col io $ Xft.drawRect drw (drawerBgColor d'') rectX rectY (padding::Int) rectHeight let proc (x,d') (Fg fg) = do col <- allocColor mgr fg return (x, d' { drawerFgColor = col }) proc (x,d') (DefFg) = return (x, d' { drawerFgColor = drawerFgColor d }) proc (x,d') (Bg bg) = do col <- allocColor mgr bg return (x, d' { drawerBgColor = col }) proc (x,d') (DefBg) = return (x, d' { drawerBgColor = drawerBgColor d }) proc (x,d') (Text t) = do let s = T.unpack t (w,_) <- textExtents (drawerFont d') s io $ Xft.drawRect drw (drawerBgColor d') x rectY w rectHeight drawText (drawerFgColor d') (drawerFont d') x (rectY + padding) (rectHeight - padding) s return (x+w, d') (endx, d') <- foldM proc (fi rectX + padding, d'') fs io $ Xft.drawRect drw (drawerBgColor d') endx rectY (max 0 $ fi rectX + fi rectWidth - endx) rectHeight fmtSize :: Xft.Font -> FormatString -> SindreX11M Rectangle fmtSize font s = do (w,h) <- textExtents font s' return $ Rectangle 0 0 (fi w + 2 * padding) (fi h + 2 * padding) where s' = T.unpack $ textContents s getModifiers :: KeyMask -> S.Set KeyModifier getModifiers m = foldl add S.empty modifiers where add s (x, mods) | x .&. m /= 0 = S.insert mods s | otherwise = s modifiers = [ (controlMask, Control) , (mod1Mask, Meta) , (shiftMask, Shift) ] setupDisplay :: String -> IO Display setupDisplay dstr = openDisplay dstr `catch` \e -> error $ "Cannot open display \"" ++ dstr ++ "\": " ++ show (e :: IOException) grabInput :: Display -> Window -> IO GrabStatus grabInput dpy win = do grabButton dpy button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none grab (1000 :: Int) where grab 0 = return alreadyGrabbed grab n = do status <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime if status /= grabSuccess then threadDelay 1000 >> grab (n-1) else return status findRectangle :: Display -> Window -> IO X.Rectangle findRectangle dpy rootw = do (win, _) <- getInputFocus dpy (x,y) <- if rootw == win then windowWithPointer else windowWithFocus =<< getWindowAttributes dpy win let contains rect = fi x >= rect_x rect && fi (rect_width rect) + rect_x rect > fi x && fi y >= rect_y rect && fi (rect_height rect) + rect_y rect > fi y fromJust <$> find contains <$> getScreenInfo dpy where windowWithPointer = do (_, _, _, x, y, _, _, _) <- queryPointer dpy rootw return (x,y) windowWithFocus attr = do (_, x, y, _) <- translateCoordinates dpy rootw rootw (fi $ wa_x attr) (fi $ wa_y attr) return (fi x,fi y) mkWindow :: Display -> Screen -> Window -> Bool -> Position -> Position -> Dimension -> Dimension -> IO Window mkWindow dpy s rw o x y w h = do let visual = defaultVisualOfScreen s attrmask = cWOverrideRedirect black = blackPixelOfScreen s white = whitePixelOfScreen s io $ allocaSetWindowAttributes $ \attrs -> do set_override_redirect attrs o set_background_pixel attrs white set_border_pixel attrs black createWindow dpy rw x y w h 0 copyFromParent inputOutput visual attrmask attrs type Xlock = MVar () lockXlock :: MonadIO m => Xlock -> m () lockXlock xlock = io $ takeMVar xlock lockX :: SindreX11M () lockX = do xlock <- asks sindreXlock io $ takeMVar xlock unlockXlock :: MonadIO m => Xlock -> m () unlockXlock xlock = io $ putMVar xlock () unlockX :: SindreX11M () unlockX = do xlock <- asks sindreXlock io $ putMVar xlock () getX11Event :: Display -> Window -> XIC -> IO (KeySym, String, X.Event) getX11Event dpy win ic = do (str,keysym,event) <- allocaXEvent $ \e -> do nextEvent dpy e ev <- X.getEvent e (ks,s) <- ifM ((ev_event_type ev /= keyPress ||) <$> filterEvent e win) (return (Nothing, Nothing)) (utf8LookupString ic e) return (ks,s,ev) return ( fromMaybe xK_VoidSymbol keysym , fromMaybe "" str , event) processX11Event :: (KeySym, String, X.Event) -> EventThunk processX11Event (ks, s, KeyEvent {ev_event_type = t, ev_state = m }) | t == keyPress = return $ (KeyPress . mods) <$> case s of _ | s `elem` ["\127", "\8", "\13", "", "\27"] -> Just $ CtrlKey $ keysymToString ks [c] | not (isPrint c) -> case keysymToString ks of [ks'] -> Just $ CharKey ks' ks' -> Just $ CtrlKey ks' [c] -> Just $ CharKey c _ -> Nothing where mods (CharKey c) = (Shift `S.delete` getModifiers m, CharKey c) mods (CtrlKey c) = (getModifiers m, CtrlKey c) processX11Event (_, _, ExposeEvent { ev_x = x, ev_y = y , ev_width = w, ev_height = h }) = redrawRegion [Rectangle (fi x) (fi y) (fi w) (fi h)] >> return Nothing processX11Event (_, _, ConfigureEvent { ev_window = win , ev_width = w, ev_height = h }) = do back $ do onsurface <- (==win) <$> gets surfaceWindow when onsurface $ do sur <- (pure resizeSurface <*> asks sindreDisplay <*> asks sindreXftMgr <*> get <*> pure (Rectangle 0 0 (fi w) (fi h))) put =<< io sur redrawRoot >> return Nothing processX11Event (_, _, AnyEvent { ev_event_type = t }) | t == visibilityNotify = do back $ do dpy <- asks sindreDisplay win <- gets surfaceWindow io $ raiseWindow dpy win redrawRoot return Nothing processX11Event _ = return Nothing eventReader :: Display -> Window -> XIC -> MVar EventThunk -> Xlock -> IO () eventReader dpy win ic evvar xlock = forever $ do lockXlock xlock waitUntilEvent xev <- getX11Event dpy win ic unlockXlock xlock putMVar evvar $ processX11Event xev where waitUntilEvent = do cnt <- eventsQueued dpy queuedAfterFlush when (cnt == 0) $ do -- The following two lines have a race condition. unlockXlock xlock threadWaitRead $ Fd $ connectionNumber dpy lockXlock xlock waitUntilEvent -- | Get the value for a named color if it exists maybeAllocColor :: Xft.XftMgr -> String -> IO (Maybe Xft.Color) maybeAllocColor mgr c = Xft.openColorName mgr vis colormap c where colormap = defaultColormap dpy $ defaultScreen dpy dpy = Xft.mgrDisplay mgr vis = defaultVisualOfScreen $ defaultScreenOfDisplay dpy allocColor :: MonadIO m => Xft.XftMgr -> String -> m Xft.Color allocColor dpy c = io (maybeAllocColor dpy c) >>= maybe (fail $ "Unknown color '"++c++"'") return sindreEventMask :: EventMask sindreEventMask = exposureMask .|. structureNotifyMask sindreX11Cfg :: String -> Bool -> IO (SindreX11Conf, Surface) sindreX11Cfg dstr o = do sl <- supportsLocale unless sl $ putStrLn "Current locale is not supported" >> exitFailure _ <- setLocaleModifiers "" dpy <- setupDisplay dstr let scr = defaultScreenOfDisplay dpy xlock <- newMVar () mgr <- Xft.newXftMgr dpy scr (lockXlock xlock) (unlockXlock xlock) rmInitialize s <- resourceManagerString dpy db <- case s of Nothing -> return Nothing Just s' -> rmGetStringDatabase s' rect <- findRectangle dpy (rootWindowOfScreen scr) win <- mkWindow dpy scr (rootWindowOfScreen scr) o (rect_x rect) (rect_y rect) (rect_width rect) (rect_height rect) surface <- newSurface dpy mgr scr win (fromXRect rect) setShape dpy surface [] im <- openIM dpy Nothing Nothing Nothing ic <- createIC im [XIMPreeditNothing, XIMStatusNothing] win evvar <- newEmptyMVar _ <- forkIO $ eventReader dpy win ic evvar xlock visopts <- defVisualOpts mgr return (SindreX11Conf { sindreDisplay = dpy , sindreVisualOpts = visopts , sindreRMDB = db , sindreEvtVar = evvar , sindreXlock = xlock , sindreReshape = reshape , sindreXftMgr = mgr }, surface) where reshape rs = do sur <- get dpy <- asks sindreDisplay io $ setShape dpy sur rs -- | Options regarding visual appearance of widgets (colors and -- fonts). data VisualOpts = VisualOpts { foreground :: Xft.Color , background :: Xft.Color , focusForeground :: Xft.Color , focusBackground :: Xft.Color , font :: Xft.Font } defVisualOpts :: Xft.XftMgr -> IO VisualOpts defVisualOpts mgr = do font <- Xft.openFontName mgr "Monospace" case font of Just font' -> pure VisualOpts <*> f fg <*> f bg <*> f ffg <*> f fbg <*> pure font' Nothing -> fail "Cannot open Monospace font" where (fg, bg, ffg, fbg) = ("black", "grey", "white", "blue") f = allocColor mgr -- | Execute Sindre in the X11 backend, grabbing control of the entire -- display and staying on top. sindreX11override :: String -- ^ The display string (usually the value of the -- environment variable @$DISPLAY@ or @:0@) -> SindreX11M ExitCode -- ^ The function returned by -- 'Sindre.Compiler.compileSindre' after command line -- options have been given -> IO ExitCode sindreX11override dstr start = do (cfg, sur) <- sindreX11Cfg dstr True _ <- io $ mapRaised (sindreDisplay cfg) (surfaceWindow sur) status <- grabInput (sindreDisplay cfg) (surfaceWindow sur) io $ selectInput (sindreDisplay cfg) (surfaceWindow sur) $ sindreEventMask .|. visibilityChangeMask unless (status == grabSuccess) $ error "Could not establish keyboard grab" runSindreX11 (lockX >> start) cfg sur <* Xft.freeXftMgr (sindreXftMgr cfg) -- | Execute Sindre in the X11 backend as an ordinary client visible -- to the window manager. sindreX11 :: String -- ^ The display string (usually the value of the -- environment variable @$DISPLAY@ or @:0@) -> SindreX11M ExitCode -- ^ The function returned by -- 'Sindre.Compiler.compileSindre' after command line -- options have been given -> IO ExitCode sindreX11 dstr start = do (cfg, sur) <- sindreX11Cfg dstr False _ <- io $ mapRaised (sindreDisplay cfg) (surfaceWindow sur) selectInput (sindreDisplay cfg) (surfaceWindow sur) $ keyPressMask .|. keyReleaseMask .|. sindreEventMask runSindreX11 (lockX >> start) cfg sur -- | Execute Sindre in the X11 backend as a dock/statusbar. sindreX11dock :: String -- ^ The display string (usually the value of the -- environment variable @$DISPLAY@ or @:0@) -> SindreX11M ExitCode -- ^ The function returned by -- 'Sindre.Compiler.compileSindre' after command line -- options have been given -> IO ExitCode sindreX11dock dstr start = do (cfg, sur) <- sindreX11Cfg dstr False let d = sindreDisplay cfg w = surfaceWindow sur a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False c1 <- internAtom d "CARDINAL" False a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False c2 <- internAtom d "ATOM" False v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False let reshape rs = do io $ changeProperty32 d w a1 c1 propModeReplace $ map fi $ getStrutValues (mconcat rs) (surfaceBounds sur) sindreReshape cfg rs changeProperty32 d w a2 c2 propModeReplace [fi v] selectInput (sindreDisplay cfg) (surfaceWindow sur) sindreEventMask lowerWindow (sindreDisplay cfg) (surfaceWindow sur) _ <- mapWindow (sindreDisplay cfg) (surfaceWindow sur) runSindreX11 (lockX >> start) cfg { sindreReshape = reshape } sur where strutArea [left, right, top, bot, left_y1, left_y2, right_y1, right_y2, top_x1, top_x2, bot_x1, bot_x2] = left*(left_y2-left_y1)+right*(right_y2-right_y1)+ top*(top_x2-top_x1)+bot*(bot_x2-bot_x1) strutArea _ = 0 getStrutValues r1 r2 = minimumBy (comparing strutArea) [[0,0,rectY r1+rectHeight r1,0, 0,0,0,0,rectX r1,rectX r1 + rectWidth r1,0,0], [0,0,0,rectHeight r2 - rectY r1, 0,0,0,0,0,0,rectX r1,rectX r1 + rectWidth r1], [rectX r1+rectWidth r1,0,0,0, rectY r1,rectY r1 + rectHeight r1,0,0,0,0,0,0], [0,rectWidth r2 - rectX r1,0,0, 0,0,rectY r1,rectY r1 + rectHeight r1,0,0,0,0] ] data InStream = InStream Handle instance (MonadIO m, MonadBackend m) => Object m InStream where -- | An input stream object wrapping the given 'Handle'. Input is -- purely event-driven and line-oriented: the event @lines@ is sent -- (roughly) for each sequence of lines that can be read without -- blocking, with the payload being a single string value containing -- the lines read since the last time the event was sent. When end of -- file is reached, the @eof@ event (no payload) is sent. mkInStream :: Handle -> ObjectRef -> SindreX11M (NewObject SindreX11M) mkInStream h r = do evvar <- asks sindreEvtVar linevar <- io newEmptyMVar let putEv ev = putMVar evvar $ return $ Just $ ev $ ObjectSrc r getLines = do line <- takeMVar linevar case line of Just line' -> getLines' [line'] >> getLines Nothing -> putEv $ NamedEvent "eof" [] getLines' lns = do line <- yield >> tryTakeMVar linevar case line of Just Nothing -> do putEv $ NamedEvent "lines" [asStr lns] putEv $ NamedEvent "eof" [] Just (Just line') -> getLines' $ line' : lns Nothing -> putEv $ NamedEvent "lines" [asStr lns] readLines = forever (putMVar linevar =<< Just <$> E.decodeUtf8 <$> B.hGetLine h) `catch` (\(_::IOException) -> putMVar linevar Nothing) _ <- io $ forkIO getLines _ <- io $ forkIO readLines return $ NewObject $ InStream h where asStr = StringV . T.unlines . reverse -- | Performs a lookup in the X resources database for a given -- property. The class used is @/Sindre/./class/./property/@ and the -- name is @/progname/./name/./property/@, where /progname/ is the -- value of 'getProgName'. xopt :: Param SindreX11M a => Maybe String -- ^ Name of widget, using @_@ if 'Nothing' is passed -> String -- ^ Widget class -> String -- ^ Property name -> ConstructorM SindreX11M a xopt name clss attr = do progname <- io getProgName let clss' = "Sindre" ++ "." ++ clss ++ "." ++ attr name' = progname ++ "." ++ fromMaybe "_" name ++ "." ++ attr mdb <- back $ asks sindreRMDB case mdb of Nothing -> noParam name' Just db -> do res <- io $ rmGetResource db name' clss' case res of Nothing -> noParam name' Just ("String", v) -> do v' <- io $ rmValue v maybe (badValue name' $ string v') return =<< back (moldM $ string v') Just _ -> badValue name' $ string "" instance Param SindreX11M Xft.Color where moldM (mold -> Just c) = io . flip maybeAllocColor c =<< asks sindreXftMgr moldM _ = return Nothing instance Param SindreX11M Xft.Font where moldM (true -> False) = return Nothing moldM (mold -> Just s) = do mgr <- asks sindreXftMgr io $ Xft.openFontName mgr s moldM _ = return Nothing -- | Read visual options from either widget parameters or the X -- resources database using 'xopt', or a combination. The following -- graphical components are read: -- -- [@Foreground color@] From @fg@ parameter or @foreground@ X -- property. -- -- [@Background color@] From @bg@ parameter or @background@ X -- property. -- -- [@Focus foreground color@] From @ffg@ parameter or -- @focusForeground@ X property. -- -- [@Focus background color@] From @fbg@ parameter or -- @focusBackground@ X property. visualOpts :: WidgetRef -> ConstructorM SindreX11M VisualOpts visualOpts (_, clss, name) = do VisualOpts {..} <- back $ asks sindreVisualOpts flipcol <- param "highlight" <|> return False let pert = if flipcol then flip (,) else (,) (fgs, ffgs) = pert ("foreground", foreground) ("focusForeground", focusForeground) (bgs, fbgs) = pert ("background", background) ("focusBackground", focusBackground) font' <- paramM "font" <|> xopt name clss "font" <|> return font fg <- paramM "fg" <|> xopt name clss (fst fgs) <|> pure (snd fgs) bg <- paramM "bg" <|> xopt name clss (fst bgs) <|> pure (snd bgs) ffg <- paramM "ffg" <|> xopt name clss (fst ffgs) <|> pure (snd ffgs) fbg <- paramM "fbg" <|> xopt name clss (fst fbgs) <|> pure (snd fbgs) return VisualOpts { foreground = fg, background = bg, focusForeground = ffg, focusBackground = fbg, font = font' } -- | Helper function that makes it easier it write consistent widgets -- in the X11 backend. The widget is automatically filled with its -- (nonfocus) background color. You are supposed to use this in the -- 'drawI' method of a 'Widget' instance definition. An example: -- -- @ -- drawI = drawing myWidgetWin myWidgetVisual $ \r fg bg ffg fbg -> do -- fg drawString 0 5 \"foreground\" -- bg drawString 0 15 \"background\" -- ffg drawString 0 25 \"focus foreground\" -- fbg drawString 0 35 \"focus background\" -- @ drawing :: (a -> VisualOpts) -> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle]) -- ^ The body of the @drawing@ call - this function is called -- with a rectangle representing the area of the widget, and -- 'Drawer's for "foreground," "background", "focus -- foreground", and "focus background" respectively. -> Rectangle -> ObjectM a SindreX11M SpaceUse drawing vf m r@Rectangle{..} = do dpy <- back $ asks sindreDisplay canvas <- back $ gets surfaceCanvas VisualOpts{..} <- vf <$> get let mkgc fg bg = io $ do gc <- createGC dpy canvas setForeground dpy gc $ Xft.pixel fg setBackground dpy gc $ Xft.pixel bg return gc let pass fgc bgc = do fggc <- mkgc fgc bgc bggc <- mkgc bgc fgc return $ Drawer (\f -> f dpy canvas fggc) (\f -> f dpy canvas bggc) font fgc bgc gcsOf d = [fg d $ \_ _ gc -> gc, bg d $ \_ _ gc -> gc] normal <- pass foreground background focus <- pass focusForeground focusBackground io $ bg normal fillRectangle (fi rectX) (fi rectY) (fi rectWidth) (fi rectHeight) m r normal focus <* io (mapM_ (freeGC dpy) (gcsOf normal++gcsOf focus) >> sync dpy False) -- | Variant of @drawing@ that assumes the entire rectangle is used. drawing' :: (a -> VisualOpts) -> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ()) -> Rectangle -> ObjectM a SindreX11M SpaceUse drawing' vf m = drawing vf $ \r normal focus -> do m r normal focus return [r] -- | A small function that automatically passes appropriate 'Display', -- 'Window' and 'GC' values to an Xlib drawing function (that, -- conveniently, always accepts these arguments in the same order). type CoreDrawer f = (Display -> Drawable -> GC -> f) -> f data Drawer = Drawer { fg :: forall f. CoreDrawer f , bg :: forall f. CoreDrawer f , drawerFont :: Xft.Font , drawerFgColor :: Xft.Color , drawerBgColor :: Xft.Color } setFgColor :: Drawer -> Xft.Color -> IO Drawer setFgColor d c = do fg d $ \dpy _ gc -> setForeground dpy gc $ Xft.pixel c bg d $ \dpy _ gc -> setBackground dpy gc $ Xft.pixel c return d { drawerFgColor = c } setBgColor :: Drawer -> Xft.Color -> IO Drawer setBgColor d c = do fg d $ \dpy _ gc -> setBackground dpy gc $ Xft.pixel c bg d $ \dpy _ gc -> setForeground dpy gc $ Xft.pixel c return d { drawerBgColor = c } padding :: Integral a => a padding = 2 data Dial = Dial { dialMax :: Integer , dialVal :: Integer , dialVisual :: VisualOpts } instance Object SindreX11M Dial where fieldSetI "value" (mold -> Just v) = do modify $ \s -> s { dialVal = clamp 0 v (dialMax s) } redraw >> unmold <$> gets dialVal fieldSetI _ _ = return $ Number 0 fieldGetI "value" = unmold <$> gets dialVal fieldGetI _ = return $ Number 0 recvEventI (KeyPress (_, CharKey 'n')) = changeFields [("value", unmold . dialVal)] $ \s -> do redraw return s { dialVal = clamp 0 (dialVal s+1) (dialMax s) } recvEventI (KeyPress (_, CharKey 'p')) = changeFields [("value", unmold . dialVal)] $ \s -> do redraw return s { dialVal = clamp 0 (dialVal s-1) (dialMax s) } recvEventI _ = return () instance Widget SindreX11M Dial where composeI = return (Exact 50, Exact 50) drawI = drawing' dialVisual $ \Rectangle{..} d _ -> do val <- gets dialVal maxval <- gets dialMax io $ do let unitAng = 2*pi / fi maxval angle = (-unitAng) * fi val :: Double dim = min rectWidth rectHeight - 1 cornerX = fi rectX + (rectWidth - dim) `div` 2 cornerY = fi rectY + (rectHeight - dim) `div` 2 fg d drawArc (fi cornerX) (fi cornerY) (fi dim) (fi dim) 0 (360*64) fg d fillArc (fi cornerX) (fi cornerY) (fi dim) (fi dim) (90*64) (round $ angle * (180/pi) * 64) fg d drawRectangle (fi cornerX) (fi cornerY) (fi dim) (fi dim) -- | A simple dial using an arc segment to indicate the value compared -- to the max value. Accepts @max@ and @value@ parameters (both -- integers, default values 12 and 0), and a single field: @value@. -- @@ and @

@ are used to increase and decrease the value. mkDial :: Constructor SindreX11M mkDial r [] = do maxv <- param "max" <|> return 12 val <- param "value" <|> return 0 visual <- visualOpts r sindre $ return $ NewWidget $ Dial maxv val visual mkDial _ _ = error "Dials do not have children" data Label = Label { labelText :: FormatString , labelVisual :: VisualOpts } instance Object SindreX11M Label where fieldSetI "label" v = do modify $ \s -> s { labelText = fromMaybe [Text $ T.pack $ show v] $ mold v } fullRedraw gets (unmold . labelText) fieldSetI _ _ = return $ Number 0 fieldGetI "label" = gets (unmold . labelText) fieldGetI _ = return $ Number 0 instance Widget SindreX11M Label where composeI = do font <- gets (font . labelVisual) text <- gets labelText case text of [] -> return (Exact 0, Exact $ 2 * padding + Xft.height font) _ -> do r <- back $ fmtSize font text return (Exact $ rectWidth r, Exact $ rectHeight r) drawI = drawing' labelVisual $ \r fg _ -> do label <- gets labelText back $ drawFmt fg r label -- | Label displaying the text contained in the field @label@, which -- is also accepted as a widget parameter (defaults to the empty -- string). mkLabel :: Constructor SindreX11M mkLabel r [] = do label <- param "label" <|> return [] visual <- visualOpts r return $ NewWidget $ Label label visual mkLabel _ _ = error "Labels do not have children" data Blank = Blank { blankVisual :: VisualOpts } instance Object SindreX11M Blank where fieldSetI _ _ = return $ Number 0 fieldGetI _ = return $ Number 0 instance Widget SindreX11M Blank where composeI = return (Unlimited, Unlimited) drawI = drawing' blankVisual $ \_ _ _ -> return () -- | A blank widget, showing only background color, that can use as -- much or as little room as necessary. Useful for constraining the -- layout of other widgets. mkBlank :: Constructor SindreX11M mkBlank r [] = do visual <- visualOpts r return $ NewWidget $ Blank visual mkBlank _ _ = error "Blanks do not have children" data TextField = TextField { fieldText :: (String, String) , fieldVisual :: VisualOpts } fieldValue :: TextField -> String fieldValue = uncurry (++) . first reverse . fieldText instance Object SindreX11M TextField where fieldSetI "value" (mold -> Just v) = do modify $ \s -> s { fieldText = (reverse v, "") } fullRedraw return $ string v fieldSetI _ _ = return $ Number 0 fieldGetI "value" = string <$> fieldValue <$> get fieldGetI _ = return $ Number 0 recvEventI (KeyPress (S.toList -> [], CharKey c)) = changeFields [("value", unmold . fieldValue)] $ \s -> do let (bef, aft) = fieldText s fullRedraw return s { fieldText = (c:bef, aft) } recvEventI (KeyPress k) = maybe (return ()) (redraw >>) $ M.lookup k editorCommands recvEventI _ = return () editorCommands :: M.Map Chord (ObjectM TextField SindreX11M ()) editorCommands = M.fromList [ (chord [] "Right", moveForward $ splitAt 1) , (chord [Control] 'f', moveForward $ splitAt 1) , (chord [] "Left", moveBackward $ splitAt 1) , (chord [Control] 'b', moveBackward $ splitAt 1) , (chord [Meta] 'f', do moveForward (break isAlphaNum) moveForward (span isAlphaNum)) , (chord [Meta] 'b', do moveBackward (break isAlphaNum) moveBackward (span isAlphaNum)) , (chord [Control] 'a', moveBackward (,"")) , (chord [Control] 'e', moveForward (,"")) , (chord [] "Home", moveBackward ("",)) , (chord [] "End", moveForward ("",)) , (chord [Control] 'w', delBackward word) , (chord [Control] "BackSpace", delBackward word) , (chord [Meta] 'd', delForward word) , (chord [Control] 'k', delForward $ const "") , (chord [Control] 'u', delBackward $ const "") , (chord [] "BackSpace", delBackward $ drop 1) , (chord [Control] 'd', delForward $ drop 1)] where word = dropWhile isAlphaNum . dropWhile (not . isAlphaNum) moveForward f = modify $ \s -> let (bef, (pre, post)) = second f $ fieldText s in s { fieldText = (reverse pre ++ bef, post) } moveBackward f = modify $ \s -> let ((pre, post), aft) = first f $ fieldText s in s { fieldText = (post, reverse pre ++ aft) } delBackward delf = changeFields [("value", unmold . fieldValue)] $ \s -> do fullRedraw return s { fieldText = first delf $ fieldText s } delForward delf = changeFields [("value", unmold . fieldValue)] $ \s -> do fullRedraw return s { fieldText = second delf $ fieldText s } instance Widget SindreX11M TextField where composeI = do font <- gets (font . fieldVisual) text <- gets fieldValue (w,h) <- back $ textExtents font text return (Max $ fi w + padding * 2, Exact $ fi h + padding * 2) drawI = drawing' fieldVisual $ \Rectangle{..} d _ -> do (bef,_) <- gets fieldText text <- gets fieldValue font <- gets (font . fieldVisual) (befw, _) <- back $ textExtents font bef (w, h) <- back $ textExtents font text let width = liftM snd . textExtents font text' <- if w <= fi rectWidth then return text else do fits <- back $ filterM (liftM (<= fi rectWidth) . width) $ tails $ reverse text case fits of [] -> return "" (t:_) -> return $ reverse t back $ drawText (drawerFgColor d) (drawerFont d) (rectX+padding) (rectY+padding) (rectHeight - padding*2) text' when (padding+befw <= fi rectWidth) $ io $ fg d drawLine (fi rectX+padding+fi befw) (fi rectY+padding) (fi rectX+padding+fi befw) (fi rectY+padding+fi h) -- | Single-line text field, whose single field @value@ (also a -- parameter, defaults to the empty string) is the contents of the -- editing buffer. mkTextField :: Constructor SindreX11M mkTextField r [] = do v <- param "value" <|> return "" visual <- visualOpts r return $ NewWidget $ TextField ("",v) visual mkTextField _ _ = error "TextFields do not have children" data ListElem = ListElem { showAs :: FormatString , valueOf :: T.Text , filterBy :: T.Text } deriving (Show, Eq, Ord) parseListElem :: T.Text -> ListElem parseListElem s = case KV.parseKV p s of Left _ -> el Right (v,val) -> case parseFormatString v of Left _ -> el Right s' -> ListElem (pad s') val (textContents s') where p = elf <$?> (Nothing, Just <$> KV.value (T.pack "show")) <||> KV.value (T.pack "value") elf s' v' = (fromMaybe v' s', v') pad s' = maybeToList (Bg <$> startBg s') ++ [Text $ T.pack " "] ++ s' ++ [Text $ T.pack " "] el = ListElem [Text $ T.concat [T.pack " ", s, T.pack " "]] s s data NavList = NavList { linePrev :: [ListElem] , lineContents :: Maybe ([(ListElem, Rectangle)], (ListElem, Rectangle), [(ListElem, Rectangle)]) , lineNext :: [ListElem] } type Movement m = ([ListElem] -> m ([(ListElem, Rectangle)], [ListElem])) -> NavList -> m (Maybe NavList) contents :: NavList -> [ListElem] contents NavList { lineContents = Just (pre, cur, aft) } = reverse (map fst pre)++[fst cur]++map fst aft contents _ = [] selected :: NavList -> Maybe ListElem selected NavList { lineContents = Just (_, (cur, _), _) } = Just cur selected _ = Nothing listPrev :: Monad m => Movement m listPrev _ l@NavList { lineContents = Just (pre:pre', cur, aft) } = return $ Just l { lineContents = Just (pre', pre, cur:aft) } listPrev more l = do (conts', rest) <- more (linePrev l) case conts' of [] -> return Nothing x:xs -> return $ Just $ NavList rest (Just (xs, x, [])) (contents l++lineNext l) listNext :: Monad m => Movement m listNext _ l@NavList { lineContents = Just (pre, cur, aft:aft') } = return $ Just l { lineContents = Just (cur:pre, aft, aft') } listNext more l = do (conts', rest) <- more $ lineNext l case conts' of [] -> return Nothing x:xs -> return $ Just $ NavList (reverse (contents l)++linePrev l) (Just ([], x, xs)) rest listLast :: Monad m => Movement m listLast more l = do (line, rest) <- more $ reverse (contents l ++ lineNext l) ++ linePrev l case line of [] -> return Nothing x:xs -> return $ Just $ NavList rest (Just (xs, x, [])) [] listFirst :: Monad m => Movement m listFirst more l = do (line, rest) <- more $ reverse (linePrev l) ++ contents l ++ lineNext l case line of [] -> return Nothing x:xs -> return $ Just $ NavList [] (Just ([], x, xs)) rest moveUntil :: (MonadIO m, Monad m) => Movement m -> (NavList -> Bool) -> Movement m moveUntil mov p more l | p l = return $ Just l | otherwise = do l' <- mov more l case l' of Nothing -> return Nothing Just l'' -> moveUntil mov p more l'' lineElems :: (Rectangle -> Integer) -> Rectangle -> [ListElem] -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem]) lineElems rdf r l = elemLine l $ rdf r where elemLine [] _ = return ([], []) elemLine es@(e:es') room = do r' <- elemRect e if room >= rdf r' then do (es'', rest) <- elemLine es' $ room-rdf r' return ((e,r'):es'', rest) else return ([], es) fromElems :: ([(ListElem, Rectangle)], [ListElem]) -> NavList fromElems ([], rest) = NavList [] Nothing rest fromElems (x:xs, rest) = NavList [] (Just ([], x, xs)) rest elemRect :: ListElem -> ObjectM List SindreX11M Rectangle elemRect e = do font <- gets (font . listVisual) back $ fmtSize font (showAs e) data List = List { listElems :: [ListElem] , listFilter :: T.Text , listLine :: NavList , listVisual :: VisualOpts , listCompose :: ObjectM List SindreX11M SpaceNeed , listDraw :: Rectangle -> ObjectM List SindreX11M SpaceUse , listFilterF :: T.Text -> [ListElem] -> [ListElem] , listUsableRect :: Rectangle -> ObjectM List SindreX11M Rectangle , listSize :: Rectangle , listDim :: Rectangle -> Integer } listFiltered :: List -> [ListElem] listFiltered List { listLine = l } = reverse (linePrev l) ++ contents l ++ lineNext l selection :: List -> Value selection l = maybe falsity f $ lineContents $ listLine l where f (_,(c,_),_) = StringV $ valueOf c refilter :: (T.Text -> T.Text) -> T.Text -> [ListElem] -> [ListElem] refilter tr f ts = case T.words $ tr f of [] -> ts f'@(x:_) -> exacts++prefixes++infixes where matches = filter (\t -> all (flip T.isInfixOf $ cmpBy t) f') ts (exacts, nonexacts) = partition ((==f) . cmpBy) matches (prefixes, infixes) = partition (T.isPrefixOf x . cmpBy) nonexacts cmpBy = filterBy methInsert :: T.Text -> ObjectM List SindreX11M () methInsert vs = changeFields [("selected", selection)] $ \s -> do let v = listFilterF s (listFilter s) $ listFiltered s ++ elems p l = selected l == selected (listLine s) more = lineElems (listDim s) (listSize s) line <- fromElems <$> more v line' <- moveUntil listNext p more line fullRedraw >> return s { listElems = listElems s ++ elems , listLine = fromMaybe line line' } where elems = map parseListElem $ T.lines vs methClear :: ObjectM List SindreX11M () methClear = do modify $ \s -> s { listElems = [] , listLine = NavList [] Nothing [] } fullRedraw methFilter :: String -> ObjectM List SindreX11M () methFilter f = changeFields [("selected", selection)] $ \s -> do let v = listFilterF s f' $ if listFilter s `T.isPrefixOf` f' then listFiltered s else listElems s line <- fromElems <$> lineElems (listDim s) (listSize s) v redraw >> return s { listFilter = f', listLine = line } where f' = T.pack f methMove :: (([ListElem] -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])) -> NavList -> ObjectM List SindreX11M (Maybe NavList)) -> ObjectM List SindreX11M Bool methMove f = do dimf <- gets listDim rect <- gets listSize l <- f (lineElems dimf rect) =<< gets listLine case l of Nothing -> return False Just l' -> do changeFields [("selected", selection)] $ \s -> do redraw return s { listLine = l' } return True instance Object SindreX11M List where fieldSetI _ _ = return $ Number 0 fieldGetI "selected" = selection <$> get fieldGetI "elements" = Dict <$> M.fromList <$> zip (map Number [1..]) <$> map (unmold . showAs) <$> listFiltered <$> get fieldGetI _ = return $ Number 0 callMethodI "insert" = function methInsert callMethodI "clear" = function methClear callMethodI "filter" = function methFilter callMethodI "next" = function $ methMove listNext callMethodI "prev" = function $ methMove listPrev callMethodI "first" = function $ methMove listFirst callMethodI "last" = function $ methMove listLast callMethodI m = fail $ "Unknown method '" ++ m ++ "'" instance Widget SindreX11M List where composeI = join $ gets listCompose drawI r = do l <- get r' <- listUsableRect l r when (r' /= listSize l) $ do line <- lineElems (listDim l) r' $ listFiltered l modify $ \s -> s { listSize = r', listLine = fromElems line } listDraw l r mkList :: ObjectM List SindreX11M SpaceNeed -> (Rectangle -> ObjectM List SindreX11M SpaceUse) -> (Rectangle -> Integer) -> (Rectangle -> ObjectM List SindreX11M Rectangle) -> Constructor SindreX11M mkList cf df dim uf r [] = do visual <- visualOpts r insensitive <- param "i" <|> return False let trf = if insensitive then T.toCaseFold else id return $ NewWidget $ List [] T.empty (NavList [] Nothing []) visual cf df (refilter trf) uf mempty dim mkList _ _ _ _ _ _ = error "Lists do not have children" -- | Horizontal dmenu-style list containing a list of elements, one of -- which is the \"selected\" element. If the parameter @i@ is given a -- true value, element matching will be case-insensitive. The -- following methods are supported: -- -- [@insert(string)@] Split @string@ into lines and add each line as -- an element. -- -- [@clear()@] Delete all elements. -- -- [@filter(string)@] Only display those elements that contain @string@. -- -- [@next()@] Move selection right. -- -- [@prev()@] Move selection left. -- -- [@first()@] Move to leftmost element. -- -- [@last()@] Move to rightmost element. -- -- The field @selected@ is the selected element. mkHList :: Constructor SindreX11M mkHList = mkList composeHoriz drawHoriz rectWidth usable where composeHoriz = ((Unlimited,) . Exact . Xft.height) <$> gets (font . listVisual) prestr = "< " aftstr = "> " usable r = do font <- gets (font . listVisual) (w1, _) <- back $ textExtents font prestr (w2, _) <- back $ textExtents font aftstr return r { rectWidth = rectWidth r - fi w1 - fi w2 } drawHoriz = drawing' listVisual $ \r d fd -> do font <- gets (font . listVisual) (prestrw,_) <- back $ textExtents font prestr let (x,y,w,h) = ( fi $ rectX r, rectY r , fi $ rectWidth r, rectHeight r) drawElem d' x' (e,r') = back $ do drawFmt d' (r' { rectX = x', rectY = rectY r }) $ showAs e return $ x'+rectWidth r' line <- gets listLine case lineContents line of Just (pre, cur, aft) -> do unless (null $ linePrev line) $ back $ drawText (drawerFgColor d) (drawerFont d) x y h prestr x' <- foldM (drawElem d) (fi $ prestrw + fi x) $ reverse pre x'' <- drawElem fd x' cur foldM_ (drawElem d) x'' aft unless (null $ lineNext line) $ back $ do (aftw,_) <- textExtents font aftstr drawText (drawerFgColor d) (drawerFont d) (x + w - aftw) y h aftstr Nothing -> return () -- | As 'mkHList', except the list is vertical. The parameter @lines@ -- (default value 10) is the number of lines shown. mkVList :: Constructor SindreX11M mkVList k cs = do n <- param "lines" <|> return 10 mkList (composeVert n) drawVert rectHeight return k cs where composeVert n = do font <- gets (font . listVisual) return ( Unlimited, Exact $ (Xft.height font + 2*padding) * n) drawVert = drawing' listVisual $ \r d fd -> do let fr y r' = r { rectY = y, rectHeight = rectHeight r' } drawElem d' y (e, r') = do drawFmt d' (fr y r') $ showAs e return $ y + rectHeight r' line <- gets (lineContents . listLine) case line of Just (pre, cur, aft) -> back $ do y' <- foldM (drawElem d) (rectY r) $ reverse pre y'' <- drawElem fd y' cur foldM_ (drawElem d) y'' aft Nothing -> return ()