module Sindre.X11( SindreX11M
, SindreX11Conf(sindreDisplay, sindreXftMgr)
, sindreX11override
, sindreX11dock
, sindreX11
, xopt
, VisualOpts(..)
, visualOpts
, allocColor
, drawing
, drawing'
, X11Field
, Drawer(..)
, setFgColor
, setBgColor
, textExtents
, drawText
, mkDial
, mkLabel
, mkBlank
, mkTextField
, mkInStream
, mkHList
, mkVList
)
where
import Sindre.Sindre
import Sindre.Compiler (badValue, moldM, Constructor, ConstructorM, Param,
param, noParam, paramM)
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 qualified Data.Text.Encoding.Error 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)
data SindreX11Conf = SindreX11Conf {
sindreDisplay :: Display
, sindreVisualOpts :: VisualOpts
, sindreRMDB :: Maybe RMDatabase
, sindreXlock :: Xlock
, sindreEvtVar :: MVar EventThunk
, sindreReshape :: [Rectangle] -> SindreX11M ()
, sindreXftMgr :: Xft.XftMgr
}
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
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 (n1)
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
unlockXlock xlock
threadWaitRead $ Fd $ connectionNumber dpy
lockXlock xlock
waitUntilEvent
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
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
sindreX11override :: String
-> SindreX11M ExitCode
-> 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)
sindreX11 :: String
-> SindreX11M ExitCode
-> 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
sindreX11dock :: String
-> SindreX11M ExitCode
-> 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_y2left_y1)+right*(right_y2right_y1)+
top*(top_x2top_x1)+bot*(bot_x2bot_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]
]
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
lns <- takeMVar linevar
case lns of Just lns' -> getLines' lns' >> getLines
Nothing -> putEv $ NamedEvent "eof" []
getLines' lns = do
more <- tryTakeMVar linevar
case more of Just Nothing -> do
putEv $ NamedEvent "lines" [StringV lns]
putEv $ NamedEvent "eof" []
Just (Just more') -> getLines' $ lns `T.append` more'
Nothing -> putEv $ NamedEvent "lines" [StringV lns]
readLines buf = do
(ls, buf') <- readLinesNonBlocking h buf
unless (B.null ls) $ putMVar linevar $ Just $ decode ls
eof <- hIsEOF h
if eof then do when (buf' /= B.empty) $
putMVar linevar $ Just $ decode buf'
putMVar linevar Nothing
else readLines buf'
_ <- io $ forkIO getLines
_ <- io $ forkIO $ readLines B.empty
return $ newObject h M.empty [] (const $ return ())
where decode = E.decodeUtf8With E.lenientDecode
readLinesNonBlocking :: Handle -> B.ByteString -> IO (B.ByteString, B.ByteString)
readLinesNonBlocking h b = do
b' <- B.hGetNonBlocking h bufferSize
if B.null b' then return $ splitLines b
else do let (ls, b'') = splitLines $ b `B.append` b'
(ls',b''') <- readLinesNonBlocking h b''
return (ls `B.append` ls', b''')
where bufferSize = 1024*1024
splitLines = B.breakEnd (==fromIntegral (ord '\n'))
xopt :: Param SindreX11M a => Maybe String
-> String
-> String
-> 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 "<Not a string property>"
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
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' }
drawing :: VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])
-> Rectangle -> ObjectM a SindreX11M SpaceUse
drawing VisualOpts{..} m r@Rectangle{..} = do
dpy <- back $ asks sindreDisplay
canvas <- back $ gets surfaceCanvas
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)
drawing' :: VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle -> ObjectM a SindreX11M SpaceUse
drawing' vo m = drawing vo $ \r normal focus -> do
m r normal focus
return [r]
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
type X11Field s = FieldDesc s SindreX11M
data Dial = Dial { dialMax :: Integer
, dialVal :: Integer
}
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)
M.empty [field value]
recvEventI composeI (drawI visual)
where composeI = return (Exact 50, Exact 50)
value = ReadWriteField "value" (gets dialVal) $ \v ->
modify (\s -> s { dialVal = clamp 0 v (dialMax s) }) >> redraw
recvEventI (KeyPress (_, CharKey 'n')) = do
dmax <- gets dialMax
changeField_ value $ \v -> return $ clamp 0 (v+1) dmax
recvEventI (KeyPress (_, CharKey 'p')) = do
dmax <- gets dialMax
changeField_ value $ \v -> return $ clamp 0 (v1) dmax
recvEventI _ = return ()
drawI visual = drawing' visual $ \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)
mkDial _ _ = error "Dials do not have children"
mkLabel :: Constructor SindreX11M
mkLabel wr [] = do
lbl <- param "label" <|> return []
visual <- visualOpts wr
return $ newWidget lbl M.empty
[field label]
(const $ return ())
(composeI visual) (drawI visual)
where label = ReadWriteField "label" getLabel setLabel
setLabel v = put v >> fullRedraw
getLabel = get
composeI visual = do
text <- get
case text of
[] -> return (Exact 0, Exact $ 2 * padding + Xft.height (font visual))
_ -> do r <- back $ fmtSize (font visual) text
return (Exact $ rectWidth r,
Exact $ rectHeight r)
drawI visual = drawing' visual $ \r fg _ ->
back . drawFmt fg r =<< get
mkLabel _ _ = error "Labels do not have children"
mkBlank :: Constructor SindreX11M
mkBlank r [] = do
visual <- visualOpts r
return $ newWidget () M.empty [] (const $ return ())
(return (Unlimited, Unlimited))
(drawing' visual $ \_ _ _ -> return ())
mkBlank _ _ = error "Blanks do not have children"
data TextField = TextField { fieldText :: (String, String) }
fieldValue :: TextField -> String
fieldValue = uncurry (++) . first reverse . fieldText
mkTextField :: Constructor SindreX11M
mkTextField r [] = do
v <- param "value" <|> return ""
visual <- visualOpts r
return $ newWidget (TextField ("",v)) methods [field value]
recvEventI (composeI visual) (drawI visual)
where methods = M.fromList []
value = ReadWriteField "value" getValue setValue
getValue = T.pack <$> gets fieldValue
setValue v =
modify $ \s -> s { fieldText = (reverse $ T.unpack v, "") }
recvEventI (KeyPress (S.toList -> [], CharKey c)) =
changingField value $ do
modify $ \(TextField (bef, aft)) -> TextField (c:bef, aft)
fullRedraw
recvEventI (KeyPress k) =
maybe (return ()) (redraw >>) $ M.lookup k (editorCommands value)
recvEventI _ = return ()
composeI visual = do
text <- gets fieldValue
(w,h) <- back $ textExtents (font visual) text
return (Max $ fi w + padding * 2, Exact $ fi h + padding * 2)
drawI visual = drawing' visual $ \Rectangle{..} d _ -> do
(bef,_) <- gets fieldText
text <- gets fieldValue
(befw, _) <- back $ textExtents (font visual) bef
(w, h) <- back $ textExtents (font visual) text
let width = liftM snd . textExtents (font visual)
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)
mkTextField _ _ = error "TextFields do not have children"
editorCommands :: X11Field TextField T.Text
-> M.Map Chord (ObjectM TextField SindreX11M ())
editorCommands value = 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 = changingField value $ do
fullRedraw
modify $ \s -> s { fieldText = first delf $ fieldText s }
delForward delf = changingField value $ do
fullRedraw
modify $ \s -> s { fieldText = second delf $ fieldText s }
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 $ T.toCaseFold $ 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 $ T.toCaseFold 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' <- join $ gets listElemSize <*> pure e
if room >= rdf r' then do (es'', rest) <- elemLine es' $ roomrdf 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
data List = List { listElems :: [ListElem]
, listFilter :: T.Text
, listLine :: NavList
, listElemSize :: ListElem -> ObjectM List SindreX11M Rectangle
, listFilterF :: T.Text -> [ListElem] -> [ListElem]
, listSize :: Rectangle
, listDim :: Rectangle -> Integer
}
listFiltered :: List -> [ListElem]
listFiltered List { listLine = l } =
reverse (linePrev l) ++ contents l ++ lineNext l
selection :: List -> Maybe T.Text
selection l = liftM f $ lineContents $ listLine l
where f (_,(c,_),_) = valueOf c
refilter :: T.Text -> [ListElem] -> [ListElem]
refilter f = sortMatches filterBy (T.toCaseFold f)
methInsert :: X11Field List (Maybe T.Text)
-> T.Text -> ObjectM List SindreX11M ()
methInsert sel vs = changingField sel $ do
s <- get
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 >> put s { listElems = listElems s ++ elems
, listLine = fromMaybe line line' }
where elems = map parseListElem $ T.lines vs
methClear :: X11Field List (Maybe T.Text)
-> ObjectM List SindreX11M ()
methClear sel = changingField sel $ do
modify $ \s -> s { listElems = [] , listLine = NavList [] Nothing [] }
fullRedraw
methFilter :: X11Field List (Maybe T.Text) -> String
-> ObjectM List SindreX11M ()
methFilter sel f =
changingField sel $ do
s <- get
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 >> put s { listFilter = f', listLine = line }
where f' = T.pack f
methMove :: X11Field List (Maybe T.Text)
-> (([ListElem] -> ObjectM List SindreX11M
([(ListElem, Rectangle)], [ListElem]))
-> NavList -> ObjectM List SindreX11M (Maybe NavList))
-> ObjectM List SindreX11M Bool
methMove sel f = do
dimf <- gets listDim
rect <- gets listSize
l <- f (lineElems dimf rect) =<< gets listLine
case l of Nothing -> return False
Just l' -> do
changingField sel $ do
redraw
modify $ \s -> s { listLine = l' }
return True
mkList :: (VisualOpts -> ObjectM List SindreX11M SpaceNeed)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M SpaceUse)
-> (Rectangle -> Integer)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle)
-> Constructor SindreX11M
mkList cf df dim uf wr [] = do
visual <- visualOpts wr
return $ newWidget (List [] T.empty (NavList [] Nothing [])
(elemSize visual) refilter mempty dim)
methods [field sel, field elements]
(const $ return ()) (composeI visual) (drawI visual)
where methods = M.fromList [ ("insert", function $ methInsert sel)
, ("clear", function $ methClear sel)
, ("filter", function $ methFilter sel)
, ("next", function $ methMove sel listNext)
, ("prev", function $ methMove sel listPrev)
, ("first", function $ methMove sel listFirst)
, ("last", function $ methMove sel listLast)]
sel = ReadOnlyField "selected" $ gets selection
elements = ReadOnlyField "elements" $ Dict <$> M.fromList <$>
zip (map Number [1..]) <$> map (unmold . showAs) <$>
gets listFiltered
composeI = cf
drawI visual r = do
l <- get
r' <- uf visual r
when (r' /= listSize l) $ do
line <- lineElems (listDim l) r' $ listFiltered l
modify $ \s -> s { listSize = r', listLine = fromElems line }
df visual r
elemSize visual = back . fmtSize (font visual) . showAs
mkList _ _ _ _ _ _ = error "Lists do not have children"
mkHList :: Constructor SindreX11M
mkHList = mkList composeHoriz drawHoriz rectWidth usable
where composeHoriz = return . (Unlimited,) . Exact . Xft.height . font
prestr = "< "
aftstr = "> "
usable visual r = do
(w1, _) <- back $ textExtents (font visual) prestr
(w2, _) <- back $ textExtents (font visual) aftstr
return r { rectWidth = rectWidth r fi w1 fi w2 }
drawHoriz visual = drawing' visual $ \r d fd -> do
(prestrw,_) <- back $ textExtents (font visual) 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 visual) aftstr
drawText (drawerFgColor d) (drawerFont d)
(x + w aftw) y h aftstr
Nothing -> return ()
mkVList :: Constructor SindreX11M
mkVList k cs = do
n <- param "lines" <|> return 10
mkList (composeVert n) drawVert rectHeight (const return) k cs
where composeVert n visual =
return (Unlimited, Exact $ (Xft.height (font visual) + 2*padding) * n)
drawVert visual = drawing' visual $ \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 ()