{-# 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'
                 , X11Field
                 , Drawer(..)
                 , setFgColor
                 , setBgColor
                 , textExtents
                 , drawText
                 , mkDial
                 , mkLabel
                 , mkBlank
                 , mkTextField
                 , mkInStream
                 , mkHList
                 , mkVList
                 , mkGraph
                 )
    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

fromXRect :: X.Rectangle -> Rectangle
fromXRect :: Rectangle -> Rectangle
fromXRect Rectangle
r =
    Rectangle :: Integer -> Integer -> Integer -> Integer -> Rectangle
Rectangle { rectX :: Integer
rectX = Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Position -> Integer) -> Position -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Position
rect_x Rectangle
r
              , rectY :: Integer
rectY = Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Position -> Integer) -> Position -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Position
rect_y Rectangle
r
              , rectWidth :: Integer
rectWidth = Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Dimension -> Integer) -> Dimension -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_width Rectangle
r
              , rectHeight :: Integer
rectHeight = Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Dimension -> Integer) -> Dimension -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
r }

type EventThunk = Sindre SindreX11M (Maybe Event)

data Surface = Surface {
    Surface -> Rectangle
surfaceBounds   :: Rectangle
  , Surface -> Drawable
surfaceShape    :: Drawable
  , Surface -> GC
surfaceMaskGC   :: GC
  , Surface -> GC
surfaceUnmaskGC :: GC
  , Surface -> Drawable
surfaceCanvas   :: Drawable
  , Surface -> Drawable
surfaceWindow   :: Window
  , Surface -> GC
surfaceWindowGC :: GC
  , Surface -> Screen
surfaceScreen   :: Screen
  , Surface -> Draw
surfaceXftDraw  :: Xft.Draw
  }

newSurfaceWithGC :: Display -> Xft.XftMgr -> Screen -> Window -> GC -> Rectangle -> IO Surface
newSurfaceWithGC :: Display
-> XftMgr -> Screen -> Drawable -> GC -> Rectangle -> IO Surface
newSurfaceWithGC Display
dpy XftMgr
mgr Screen
scr Drawable
win GC
wingc Rectangle
r = do
  Drawable
pm       <- Display
-> Drawable -> Dimension -> Dimension -> CInt -> IO Drawable
createPixmap Display
dpy Drawable
win (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectWidth Rectangle
r) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectHeight Rectangle
r) CInt
1
  GC
maskgc   <- Display -> Drawable -> IO GC
createGC Display
dpy Drawable
pm
  Display -> GC -> Drawable -> IO ()
setForeground Display
dpy GC
maskgc Drawable
0
  GC
unmaskgc <- Display -> Drawable -> IO GC
createGC Display
dpy Drawable
pm
  Display -> GC -> Drawable -> IO ()
setForeground Display
dpy GC
unmaskgc Drawable
1
  Drawable
canvas   <- Display
-> Drawable -> Dimension -> Dimension -> CInt -> IO Drawable
createPixmap Display
dpy Drawable
win (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectWidth Rectangle
r) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectHeight Rectangle
r) (CInt -> IO Drawable) -> CInt -> IO Drawable
forall a b. (a -> b) -> a -> b
$
              Screen -> CInt
defaultDepthOfScreen Screen
scr
  Maybe Draw
drw      <- XftMgr -> Drawable -> Visual -> Drawable -> IO (Maybe Draw)
Xft.openDraw XftMgr
mgr Drawable
canvas (Screen -> Visual
defaultVisualOfScreen Screen
scr)
              (Display -> Dimension -> Drawable
defaultColormap Display
dpy (Dimension -> Drawable) -> Dimension -> Drawable
forall a b. (a -> b) -> a -> b
$ Display -> Dimension
defaultScreen Display
dpy)
  Draw
drw'     <- IO Draw -> (Draw -> IO Draw) -> Maybe Draw -> IO Draw
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Draw
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not allocate Xft drawable") Draw -> IO Draw
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Draw
drw
  Surface -> IO Surface
forall (m :: * -> *) a. Monad m => a -> m a
return (Surface -> IO Surface) -> Surface -> IO Surface
forall a b. (a -> b) -> a -> b
$ Rectangle
-> Drawable
-> GC
-> GC
-> Drawable
-> Drawable
-> GC
-> Screen
-> Draw
-> Surface
Surface Rectangle
r { rectX :: Integer
rectX = Integer
0, rectY :: Integer
rectY = Integer
0 } Drawable
pm GC
maskgc
                   GC
unmaskgc Drawable
canvas Drawable
win GC
wingc Screen
scr Draw
drw'

newSurface :: Display -> Xft.XftMgr -> Screen -> Window -> Rectangle -> IO Surface
newSurface :: Display -> XftMgr -> Screen -> Drawable -> Rectangle -> IO Surface
newSurface Display
dpy XftMgr
mgr Screen
scr Drawable
win Rectangle
r = do GC
wingc <- Display -> Drawable -> IO GC
createGC Display
dpy Drawable
win
                                  Display -> GC -> Bool -> IO ()
setGraphicsExposures Display
dpy GC
wingc Bool
False
                                  Display
-> XftMgr -> Screen -> Drawable -> GC -> Rectangle -> IO Surface
newSurfaceWithGC Display
dpy XftMgr
mgr Screen
scr Drawable
win GC
wingc Rectangle
r

resizeSurface :: Display -> Xft.XftMgr -> Surface -> Rectangle -> IO Surface
resizeSurface :: Display -> XftMgr -> Surface -> Rectangle -> IO Surface
resizeSurface Display
dpy XftMgr
mgr Surface
s Rectangle
r = do
  (GC -> IO ()) -> [GC] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> GC -> IO ()
freeGC Display
dpy) [Surface -> GC
surfaceMaskGC Surface
s, Surface -> GC
surfaceUnmaskGC Surface
s]
  (Drawable -> IO ()) -> [Drawable] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> Drawable -> IO ()
freePixmap Display
dpy) [Surface -> Drawable
surfaceShape Surface
s, Surface -> Drawable
surfaceCanvas Surface
s]
  Display
-> XftMgr -> Screen -> Drawable -> GC -> Rectangle -> IO Surface
newSurfaceWithGC Display
dpy XftMgr
mgr (Surface -> Screen
surfaceScreen Surface
s) (Surface -> Drawable
surfaceWindow Surface
s) (Surface -> GC
surfaceWindowGC Surface
s) Rectangle
r

setShape :: Display -> Surface -> [Rectangle] -> IO ()
setShape :: Display -> Surface -> [Rectangle] -> IO ()
setShape Display
dpy Surface
s [Rectangle]
rects = do
  Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
dpy (Surface -> Drawable
surfaceShape Surface
s) (Surface -> GC
surfaceMaskGC Surface
s) Position
0 Position
0
   (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectWidth (Rectangle -> Integer) -> Rectangle -> Integer
forall a b. (a -> b) -> a -> b
$ Surface -> Rectangle
surfaceBounds Surface
s) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectHeight (Rectangle -> Integer) -> Rectangle -> Integer
forall a b. (a -> b) -> a -> b
$ Surface -> Rectangle
surfaceBounds Surface
s)
  [Rectangle] -> (Rectangle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Rectangle]
rects ((Rectangle -> IO ()) -> IO ()) -> (Rectangle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rectangle
rect ->
    Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
dpy (Surface -> Drawable
surfaceShape Surface
s) (Surface -> GC
surfaceUnmaskGC Surface
s)
      (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Position) -> Integer -> Position
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectX Rectangle
rect)
      (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Position) -> Integer -> Position
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectY Rectangle
rect)
      (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectWidth Rectangle
rect)
      (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Dimension) -> Integer -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectHeight Rectangle
rect)
  Display
-> Drawable -> CInt -> CInt -> CInt -> Drawable -> CInt -> IO ()
xshapeCombineMask Display
dpy (Surface -> Drawable
surfaceWindow Surface
s) CInt
shapeBounding
    CInt
0 CInt
0 (Surface -> Drawable
surfaceShape Surface
s) CInt
shapeSet

copySurface :: Display -> Surface -> [Rectangle] -> IO ()
copySurface :: Display -> Surface -> [Rectangle] -> IO ()
copySurface Display
dpy Surface
s [Rectangle]
rects = do
  let Rectangle{Integer
rectHeight :: Integer
rectWidth :: Integer
rectY :: Integer
rectX :: Integer
rectHeight :: Rectangle -> Integer
rectWidth :: Rectangle -> Integer
rectY :: Rectangle -> Integer
rectX :: Rectangle -> Integer
..} = [Rectangle] -> Rectangle
forall a. Monoid a => [a] -> a
mconcat [Rectangle]
rects
  Display
-> Drawable
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea Display
dpy (Surface -> Drawable
surfaceCanvas Surface
s) (Surface -> Drawable
surfaceWindow Surface
s) (Surface -> GC
surfaceWindowGC Surface
s)
    (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectY) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectWidth) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectHeight) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectY)

-- | The read-only configuration of the X11 backend, created during
-- backend initialisation.
data SindreX11Conf = SindreX11Conf {
    SindreX11Conf -> Display
sindreDisplay    :: Display
  -- ^ The display that we are connected to.
  , SindreX11Conf -> VisualOpts
sindreVisualOpts :: VisualOpts
  -- ^ The default visual options (color, font, etc) used if no
  -- others are specified for a widget.
  , SindreX11Conf -> Maybe RMDatabase
sindreRMDB       :: Maybe RMDatabase
  -- ^ The X11 resource database (Xdefaults/Xresources).
  , SindreX11Conf -> Xlock
sindreXlock      :: Xlock
  -- ^ Synchronisation lock for Xlib access.
  , SindreX11Conf -> MVar EventThunk
sindreEvtVar     :: MVar EventThunk
  -- ^ Channel through which events are sent by other threads to the
  -- Sindre command loop.
  , SindreX11Conf -> [Rectangle] -> SindreX11M ()
sindreReshape    :: [Rectangle] -> SindreX11M ()
  -- ^ Function to set the shape of the X11 window to the union of the
  -- given rectangles.
  , SindreX11Conf -> XftMgr
sindreXftMgr     :: Xft.XftMgr
  -- ^ Bookkeeping primitive for Xft font handling.
  }

-- | Sindre backend using Xlib.
newtype SindreX11M a = SindreX11M (ReaderT SindreX11Conf (StateT Surface IO) a)
  deriving ( a -> SindreX11M b -> SindreX11M a
(a -> b) -> SindreX11M a -> SindreX11M b
(forall a b. (a -> b) -> SindreX11M a -> SindreX11M b)
-> (forall a b. a -> SindreX11M b -> SindreX11M a)
-> Functor SindreX11M
forall a b. a -> SindreX11M b -> SindreX11M a
forall a b. (a -> b) -> SindreX11M a -> SindreX11M b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SindreX11M b -> SindreX11M a
$c<$ :: forall a b. a -> SindreX11M b -> SindreX11M a
fmap :: (a -> b) -> SindreX11M a -> SindreX11M b
$cfmap :: forall a b. (a -> b) -> SindreX11M a -> SindreX11M b
Functor, Applicative SindreX11M
a -> SindreX11M a
Applicative SindreX11M
-> (forall a b.
    SindreX11M a -> (a -> SindreX11M b) -> SindreX11M b)
-> (forall a b. SindreX11M a -> SindreX11M b -> SindreX11M b)
-> (forall a. a -> SindreX11M a)
-> Monad SindreX11M
SindreX11M a -> (a -> SindreX11M b) -> SindreX11M b
SindreX11M a -> SindreX11M b -> SindreX11M b
forall a. a -> SindreX11M a
forall a b. SindreX11M a -> SindreX11M b -> SindreX11M b
forall a b. SindreX11M a -> (a -> SindreX11M b) -> SindreX11M b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SindreX11M a
$creturn :: forall a. a -> SindreX11M a
>> :: SindreX11M a -> SindreX11M b -> SindreX11M b
$c>> :: forall a b. SindreX11M a -> SindreX11M b -> SindreX11M b
>>= :: SindreX11M a -> (a -> SindreX11M b) -> SindreX11M b
$c>>= :: forall a b. SindreX11M a -> (a -> SindreX11M b) -> SindreX11M b
$cp1Monad :: Applicative SindreX11M
Monad, Monad SindreX11M
Monad SindreX11M
-> (forall a. IO a -> SindreX11M a) -> MonadIO SindreX11M
IO a -> SindreX11M a
forall a. IO a -> SindreX11M a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> SindreX11M a
$cliftIO :: forall a. IO a -> SindreX11M a
$cp1MonadIO :: Monad SindreX11M
MonadIO, Monad SindreX11M
Monad SindreX11M
-> (forall a. String -> SindreX11M a) -> MonadFail SindreX11M
String -> SindreX11M a
forall a. String -> SindreX11M a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> SindreX11M a
$cfail :: forall a. String -> SindreX11M a
$cp1MonadFail :: Monad SindreX11M
MonadFail
           , MonadReader SindreX11Conf, MonadState Surface, Functor SindreX11M
a -> SindreX11M a
Functor SindreX11M
-> (forall a. a -> SindreX11M a)
-> (forall a b.
    SindreX11M (a -> b) -> SindreX11M a -> SindreX11M b)
-> (forall a b c.
    (a -> b -> c) -> SindreX11M a -> SindreX11M b -> SindreX11M c)
-> (forall a b. SindreX11M a -> SindreX11M b -> SindreX11M b)
-> (forall a b. SindreX11M a -> SindreX11M b -> SindreX11M a)
-> Applicative SindreX11M
SindreX11M a -> SindreX11M b -> SindreX11M b
SindreX11M a -> SindreX11M b -> SindreX11M a
SindreX11M (a -> b) -> SindreX11M a -> SindreX11M b
(a -> b -> c) -> SindreX11M a -> SindreX11M b -> SindreX11M c
forall a. a -> SindreX11M a
forall a b. SindreX11M a -> SindreX11M b -> SindreX11M a
forall a b. SindreX11M a -> SindreX11M b -> SindreX11M b
forall a b. SindreX11M (a -> b) -> SindreX11M a -> SindreX11M b
forall a b c.
(a -> b -> c) -> SindreX11M a -> SindreX11M b -> SindreX11M c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SindreX11M a -> SindreX11M b -> SindreX11M a
$c<* :: forall a b. SindreX11M a -> SindreX11M b -> SindreX11M a
*> :: SindreX11M a -> SindreX11M b -> SindreX11M b
$c*> :: forall a b. SindreX11M a -> SindreX11M b -> SindreX11M b
liftA2 :: (a -> b -> c) -> SindreX11M a -> SindreX11M b -> SindreX11M c
$cliftA2 :: forall a b c.
(a -> b -> c) -> SindreX11M a -> SindreX11M b -> SindreX11M c
<*> :: SindreX11M (a -> b) -> SindreX11M a -> SindreX11M b
$c<*> :: forall a b. SindreX11M (a -> b) -> SindreX11M a -> SindreX11M b
pure :: a -> SindreX11M a
$cpure :: forall a. a -> SindreX11M a
$cp1Applicative :: Functor SindreX11M
Applicative)

runSindreX11 :: SindreX11M a -> SindreX11Conf -> Surface -> IO a
runSindreX11 :: SindreX11M a -> SindreX11Conf -> Surface -> IO a
runSindreX11 (SindreX11M ReaderT SindreX11Conf (StateT Surface IO) a
m) = StateT Surface IO a -> Surface -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Surface IO a -> Surface -> IO a)
-> (SindreX11Conf -> StateT Surface IO a)
-> SindreX11Conf
-> Surface
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SindreX11Conf (StateT Surface IO) a
-> SindreX11Conf -> StateT Surface IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT SindreX11Conf (StateT Surface IO) a
m

instance MonadBackend SindreX11M where
  type BackEvent SindreX11M = (KeySym, String, X.Event)
  type RootPosition SindreX11M = (Align, Align)

  redrawRoot :: Sindre SindreX11M ()
redrawRoot = do
    SindreX11Conf{ sindreReshape :: SindreX11Conf -> [Rectangle] -> SindreX11M ()
sindreReshape=[Rectangle] -> SindreX11M ()
reshape } <- SindreX11M SindreX11Conf -> Sindre SindreX11M SindreX11Conf
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back SindreX11M SindreX11Conf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Surface
sur <- SindreX11M Surface -> Sindre SindreX11M Surface
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back SindreX11M Surface
forall s (m :: * -> *). MonadState s m => m s
get
    (Maybe (Align, Align)
orient, WidgetRef
rootwr) <- (SindreEnv SindreX11M -> (Maybe (Align, Align), WidgetRef))
-> Sindre SindreX11M (Maybe (Align, Align), WidgetRef)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SindreEnv SindreX11M -> (Maybe (Align, Align), WidgetRef)
forall (m :: * -> *).
SindreEnv m -> (Maybe (RootPosition m), WidgetRef)
rootWidget
    SpaceNeed
reqs <- WidgetRef -> Sindre SindreX11M SpaceNeed
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
WidgetRef -> m im SpaceNeed
compose WidgetRef
rootwr
    let winsize :: Rectangle
winsize = Surface -> Rectangle
surfaceBounds Surface
sur
        orient' :: (Align, Align)
orient' = (Align, Align) -> Maybe (Align, Align) -> (Align, Align)
forall a. a -> Maybe a -> a
fromMaybe (Align
AlignCenter, Align
AlignCenter) Maybe (Align, Align)
orient
        rect :: Rectangle
rect = (Align, Align) -> Rectangle -> Rectangle -> Rectangle
adjustRect (Align, Align)
orient' Rectangle
winsize (Rectangle -> Rectangle) -> Rectangle -> Rectangle
forall a b. (a -> b) -> a -> b
$ Rectangle -> SpaceNeed -> Rectangle
fitRect Rectangle
winsize SpaceNeed
reqs
    [Rectangle]
usage <- WidgetRef -> Maybe Rectangle -> Sindre SindreX11M [Rectangle]
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
WidgetRef -> Maybe Rectangle -> m im [Rectangle]
draw WidgetRef
rootwr (Maybe Rectangle -> Sindre SindreX11M [Rectangle])
-> Maybe Rectangle -> Sindre SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just Rectangle
rect
    SindreX11M () -> Sindre SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> Sindre SindreX11M ())
-> SindreX11M () -> Sindre SindreX11M ()
forall a b. (a -> b) -> a -> b
$ [Rectangle] -> SindreX11M ()
reshape [Rectangle]
usage
    [Rectangle] -> Sindre SindreX11M ()
forall (m :: * -> *). MonadBackend m => [Rectangle] -> Sindre m ()
redrawRegion [Rectangle]
usage

  redrawRegion :: [Rectangle] -> Sindre SindreX11M ()
redrawRegion [Rectangle]
rects = SindreX11M () -> Sindre SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> Sindre SindreX11M ())
-> SindreX11M () -> Sindre SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
    SindreX11Conf{ sindreDisplay :: SindreX11Conf -> Display
sindreDisplay=Display
dpy } <- SindreX11M SindreX11Conf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Surface
sur <- SindreX11M Surface
forall s (m :: * -> *). MonadState s m => m s
get
    IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Display -> Surface -> [Rectangle] -> IO ()
copySurface Display
dpy Surface
sur [Rectangle]
rects IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Display -> Bool -> IO ()
sync Display
dpy Bool
False

  waitForBackEvent :: Sindre SindreX11M Event
waitForBackEvent = do
    SindreX11M () -> Sindre SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back SindreX11M ()
unlockX
    MVar EventThunk
evvar <- SindreX11M (MVar EventThunk) -> Sindre SindreX11M (MVar EventThunk)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (MVar EventThunk)
 -> Sindre SindreX11M (MVar EventThunk))
-> SindreX11M (MVar EventThunk)
-> Sindre SindreX11M (MVar EventThunk)
forall a b. (a -> b) -> a -> b
$ (SindreX11Conf -> MVar EventThunk) -> SindreX11M (MVar EventThunk)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> MVar EventThunk
sindreEvtVar
    EventThunk
evm <- IO EventThunk -> Sindre SindreX11M EventThunk
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventThunk -> Sindre SindreX11M EventThunk)
-> IO EventThunk -> Sindre SindreX11M EventThunk
forall a b. (a -> b) -> a -> b
$ MVar EventThunk -> IO EventThunk
forall a. MVar a -> IO a
takeMVar MVar EventThunk
evvar
    Maybe Event
ev  <- EventThunk
evm
    SindreX11M () -> Sindre SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back SindreX11M ()
lockX
    Sindre SindreX11M Event
-> (Event -> Sindre SindreX11M Event)
-> Maybe Event
-> Sindre SindreX11M Event
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Sindre SindreX11M Event
forall (m :: * -> *). MonadBackend m => Sindre m Event
waitForBackEvent Event -> Sindre SindreX11M Event
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
ev

  getBackEvent :: EventThunk
getBackEvent =
    SindreX11M (Maybe EventThunk)
-> Sindre SindreX11M (Maybe EventThunk)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (IO (Maybe EventThunk) -> SindreX11M (Maybe EventThunk)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe EventThunk) -> SindreX11M (Maybe EventThunk))
-> (MVar EventThunk -> IO (Maybe EventThunk))
-> MVar EventThunk
-> SindreX11M (Maybe EventThunk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar EventThunk -> IO (Maybe EventThunk)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (MVar EventThunk -> SindreX11M (Maybe EventThunk))
-> SindreX11M (MVar EventThunk) -> SindreX11M (Maybe EventThunk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SindreX11Conf -> MVar EventThunk) -> SindreX11M (MVar EventThunk)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> MVar EventThunk
sindreEvtVar) Sindre SindreX11M (Maybe EventThunk)
-> (Maybe EventThunk -> EventThunk) -> EventThunk
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
         EventThunk -> Maybe EventThunk -> EventThunk
forall a. a -> Maybe a -> a
fromMaybe (Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
forall a. Maybe a
Nothing)

  printVal :: String -> SindreX11M ()
printVal String
s = IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
s IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Handle -> IO ()
hFlush Handle
stdout

textExtents :: Xft.Font -> String -> SindreX11M (Int, Int)
textExtents :: Font -> String -> SindreX11M (Int, Int)
textExtents Font
font String
s = do Display
dpy <- (SindreX11Conf -> Display) -> SindreX11M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Display
sindreDisplay
                        Int
w  <- IO Int -> SindreX11M Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Int -> SindreX11M Int) -> IO Int -> SindreX11M Int
forall a b. (a -> b) -> a -> b
$ Display -> Font -> String -> IO Int
forall a. Integral a => Display -> Font -> String -> IO a
Xft.textWidth Display
dpy Font
font String
s
                        (Int, Int) -> SindreX11M (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
w, Font -> Int
forall a. Integral a => Font -> a
Xft.height Font
font)

drawText :: (Integral x, Integral y, Integral z) => Xft.Color -> Xft.Font
         -> x -> y -> z -> String -> SindreX11M ()
drawText :: Color -> Font -> x -> y -> z -> String -> SindreX11M ()
drawText Color
col Font
font x
x y
y z
h String
str = do
  Draw
drw <- (Surface -> Draw) -> SindreX11M Draw
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Surface -> Draw
surfaceXftDraw
  (Int
_,Int
h') <- Font -> String -> SindreX11M (Int, Int)
textExtents Font
font String
str
  let y' :: Int
y' = Font -> Int
forall a. Integral a => Font -> a
Xft.ascent Font
font Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Align -> Int -> Int -> Int -> Int
forall a. Integral a => Align -> a -> a -> a -> a
align Align
AlignCenter (y -> Int
forall a b. (Integral a, Num b) => a -> b
fi y
y) Int
h' (y -> Int
forall a b. (Integral a, Num b) => a -> b
fi y
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+z -> Int
forall a b. (Integral a, Num b) => a -> b
fi z
h)
  IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Draw -> Color -> Font -> x -> Int -> String -> IO ()
forall x y.
(Integral x, Integral y) =>
Draw -> Color -> Font -> x -> y -> String -> IO ()
Xft.drawString Draw
drw Color
col Font
font x
x Int
y' String
str

drawFmt :: Drawer -> Rectangle -> FormatString -> SindreX11M ()
drawFmt :: Drawer -> Rectangle -> FormatString -> SindreX11M ()
drawFmt Drawer
d Rectangle{Integer
rectHeight :: Integer
rectWidth :: Integer
rectY :: Integer
rectX :: Integer
rectHeight :: Rectangle -> Integer
rectWidth :: Rectangle -> Integer
rectY :: Rectangle -> Integer
rectX :: Rectangle -> Integer
..} FormatString
fs = do
  XftMgr
mgr <- (SindreX11Conf -> XftMgr) -> SindreX11M XftMgr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> XftMgr
sindreXftMgr
  Draw
drw <- (Surface -> Draw) -> SindreX11M Draw
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Surface -> Draw
surfaceXftDraw
  Drawer
d'' <- case FormatString -> Maybe String
startBg FormatString
fs of Maybe String
Nothing -> Drawer -> SindreX11M Drawer
forall (m :: * -> *) a. Monad m => a -> m a
return Drawer
d
                            Just String
col -> IO Drawer -> SindreX11M Drawer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Drawer -> SindreX11M Drawer)
-> (Color -> IO Drawer) -> Color -> SindreX11M Drawer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Drawer -> Color -> IO Drawer
setBgColor Drawer
d (Color -> SindreX11M Drawer)
-> SindreX11M Color -> SindreX11M Drawer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XftMgr -> String -> SindreX11M Color
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
XftMgr -> String -> m Color
allocColor XftMgr
mgr String
col
  IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Draw -> Color -> Integer -> Integer -> Int -> Integer -> IO ()
forall x y w h.
(Integral x, Integral y, Integral w, Integral h) =>
Draw -> Color -> x -> y -> w -> h -> IO ()
Xft.drawRect Draw
drw (Drawer -> Color
drawerBgColor Drawer
d'') Integer
rectX Integer
rectY (Int
forall a. Integral a => a
padding::Int) Integer
rectHeight
  let proc :: (Int, Drawer) -> Format -> SindreX11M (Int, Drawer)
proc (Int
x,Drawer
d') (Fg String
fg) = do Color
col <- XftMgr -> String -> SindreX11M Color
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
XftMgr -> String -> m Color
allocColor XftMgr
mgr String
fg
                               (Int, Drawer) -> SindreX11M (Int, Drawer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x, Drawer
d' { drawerFgColor :: Color
drawerFgColor = Color
col })
      proc (Int
x,Drawer
d') (Format
DefFg) = (Int, Drawer) -> SindreX11M (Int, Drawer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x, Drawer
d' { drawerFgColor :: Color
drawerFgColor = Drawer -> Color
drawerFgColor Drawer
d })
      proc (Int
x,Drawer
d') (Bg String
bg) = do Color
col <- XftMgr -> String -> SindreX11M Color
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
XftMgr -> String -> m Color
allocColor XftMgr
mgr String
bg
                               (Int, Drawer) -> SindreX11M (Int, Drawer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x, Drawer
d' { drawerBgColor :: Color
drawerBgColor = Color
col })
      proc (Int
x,Drawer
d') (Format
DefBg) = (Int, Drawer) -> SindreX11M (Int, Drawer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x, Drawer
d' { drawerBgColor :: Color
drawerBgColor = Drawer -> Color
drawerBgColor Drawer
d })
      proc (Int
x,Drawer
d') (Text Text
t) = do
        let s :: String
s = Text -> String
T.unpack Text
t
        (Int
w,Int
_) <- Font -> String -> SindreX11M (Int, Int)
textExtents (Drawer -> Font
drawerFont Drawer
d') String
s
        IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Draw -> Color -> Int -> Integer -> Int -> Integer -> IO ()
forall x y w h.
(Integral x, Integral y, Integral w, Integral h) =>
Draw -> Color -> x -> y -> w -> h -> IO ()
Xft.drawRect Draw
drw (Drawer -> Color
drawerBgColor Drawer
d') Int
x Integer
rectY Int
w Integer
rectHeight
        Color
-> Font -> Int -> Integer -> Integer -> String -> SindreX11M ()
forall x y z.
(Integral x, Integral y, Integral z) =>
Color -> Font -> x -> y -> z -> String -> SindreX11M ()
drawText (Drawer -> Color
drawerFgColor Drawer
d') (Drawer -> Font
drawerFont Drawer
d')
          Int
x (Integer
rectY Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
forall a. Integral a => a
padding) (Integer
rectHeight Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
forall a. Integral a => a
padding) String
s
        (Int, Drawer) -> SindreX11M (Int, Drawer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
w, Drawer
d')
  (Int
endx, Drawer
d') <- ((Int, Drawer) -> Format -> SindreX11M (Int, Drawer))
-> (Int, Drawer) -> FormatString -> SindreX11M (Int, Drawer)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, Drawer) -> Format -> SindreX11M (Int, Drawer)
proc (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Integral a => a
padding, Drawer
d'') FormatString
fs
  IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Draw -> Color -> Int -> Integer -> Int -> Integer -> IO ()
forall x y w h.
(Integral x, Integral y, Integral w, Integral h) =>
Draw -> Color -> x -> y -> w -> h -> IO ()
Xft.drawRect Draw
drw (Drawer -> Color
drawerBgColor Drawer
d') Int
endx Integer
rectY
         (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endx) Integer
rectHeight

fmtSize :: Xft.Font -> FormatString -> SindreX11M Rectangle
fmtSize :: Font -> FormatString -> SindreX11M Rectangle
fmtSize Font
font FormatString
s = do
  (Int
w,Int
h) <- Font -> String -> SindreX11M (Int, Int)
textExtents Font
font String
s'
  Rectangle -> SindreX11M Rectangle
forall (m :: * -> *) a. Monad m => a -> m a
return (Rectangle -> SindreX11M Rectangle)
-> Rectangle -> SindreX11M Rectangle
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer -> Integer -> Rectangle
Rectangle Integer
0 Integer
0 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Int
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
forall a. Integral a => a
padding) (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Int
h Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
forall a. Integral a => a
padding)
  where s' :: String
s' = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FormatString -> Text
textContents FormatString
s

getModifiers :: KeyMask -> S.Set KeyModifier
getModifiers :: KeyMask -> Set KeyModifier
getModifiers KeyMask
m = (Set KeyModifier -> (KeyMask, KeyModifier) -> Set KeyModifier)
-> Set KeyModifier -> [(KeyMask, KeyModifier)] -> Set KeyModifier
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set KeyModifier -> (KeyMask, KeyModifier) -> Set KeyModifier
add Set KeyModifier
forall a. Set a
S.empty [(KeyMask, KeyModifier)]
modifiers
    where add :: Set KeyModifier -> (KeyMask, KeyModifier) -> Set KeyModifier
add Set KeyModifier
s (KeyMask
x, KeyModifier
mods) | KeyMask
x KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.&. KeyMask
m KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyMask
0 = KeyModifier -> Set KeyModifier -> Set KeyModifier
forall a. Ord a => a -> Set a -> Set a
S.insert KeyModifier
mods Set KeyModifier
s
                          | Bool
otherwise    = Set KeyModifier
s
          modifiers :: [(KeyMask, KeyModifier)]
modifiers = [ (KeyMask
controlMask, KeyModifier
Control)
                      , (KeyMask
mod1Mask, KeyModifier
Meta)
                      , (KeyMask
shiftMask, KeyModifier
Shift) ]

setupDisplay :: String -> IO Display
setupDisplay :: String -> IO Display
setupDisplay String
dstr =
  String -> IO Display
openDisplay String
dstr IO Display -> (IOException -> IO Display) -> IO Display
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e ->
    String -> IO Display
forall a. HasCallStack => String -> a
error (String -> IO Display) -> String -> IO Display
forall a b. (a -> b) -> a -> b
$ String
"Cannot open display \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\": "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)

grabInput :: Display -> Window -> IO GrabStatus
grabInput :: Display -> Drawable -> IO CInt
grabInput Display
dpy Drawable
win = do
  Display
-> Dimension
-> KeyMask
-> Drawable
-> Bool
-> Drawable
-> CInt
-> CInt
-> Drawable
-> Drawable
-> IO ()
grabButton Display
dpy Dimension
button1 KeyMask
anyModifier Drawable
win Bool
True Drawable
buttonReleaseMask CInt
grabModeAsync CInt
grabModeAsync Drawable
none Drawable
none
  Int -> IO CInt
grab (Int
1000 :: Int)
  where grab :: Int -> IO CInt
grab Int
0 = CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
alreadyGrabbed
        grab Int
n = do CInt
status <- Display -> Drawable -> Bool -> CInt -> CInt -> Drawable -> IO CInt
grabKeyboard Display
dpy Drawable
win Bool
True CInt
grabModeAsync CInt
grabModeAsync Drawable
currentTime
                    if CInt
status CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
grabSuccess
                      then Int -> IO ()
threadDelay Int
1000 IO () -> IO CInt -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO CInt
grab (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                      else CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
status

findRectangle :: Display -> Window -> IO X.Rectangle
findRectangle :: Display -> Drawable -> IO Rectangle
findRectangle Display
dpy Drawable
rootw = do
  (Drawable
win, CInt
_) <- Display -> IO (Drawable, CInt)
getInputFocus Display
dpy
  (CInt
x,CInt
y) <- if Drawable
rootw Drawable -> Drawable -> Bool
forall a. Eq a => a -> a -> Bool
== Drawable
win then IO (CInt, CInt)
windowWithPointer
                           else WindowAttributes -> IO (CInt, CInt)
windowWithFocus (WindowAttributes -> IO (CInt, CInt))
-> IO WindowAttributes -> IO (CInt, CInt)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> Drawable -> IO WindowAttributes
getWindowAttributes Display
dpy Drawable
win
  let contains :: Rectangle -> Bool
contains Rectangle
rect = CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Rectangle -> Position
rect_x Rectangle
rect Bool -> Bool -> Bool
&&
                      Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
rect) Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Rectangle -> Position
rect_x Rectangle
rect Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
x Bool -> Bool -> Bool
&&
                      CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
y Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Rectangle -> Position
rect_y Rectangle
rect Bool -> Bool -> Bool
&&
                      Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
rect) Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Rectangle -> Position
rect_y Rectangle
rect Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
y
  [Rectangle]
sinfo <- Display -> IO [Rectangle]
getScreenInfo Display
dpy
  case ((Rectangle -> Bool) -> [Rectangle] -> Maybe Rectangle
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Rectangle -> Bool
contains [Rectangle]
sinfo, [Rectangle]
sinfo) of
    (Just Rectangle
r, [Rectangle]
_)    -> Rectangle -> IO Rectangle
forall (m :: * -> *) a. Monad m => a -> m a
return Rectangle
r
    (Maybe Rectangle
Nothing, Rectangle
r:[Rectangle]
_) -> Rectangle -> IO Rectangle
forall (m :: * -> *) a. Monad m => a -> m a
return Rectangle
r -- When does this happen?
    (Maybe Rectangle
Nothing, [])  -> String -> IO Rectangle
forall a. HasCallStack => String -> a
error String
"Cannot find any screens"
  where windowWithPointer :: IO (CInt, CInt)
windowWithPointer = do
          (Bool
_, Drawable
_, Drawable
_, CInt
x, CInt
y, CInt
_, CInt
_, KeyMask
_) <- Display
-> Drawable
-> IO (Bool, Drawable, Drawable, CInt, CInt, CInt, CInt, KeyMask)
queryPointer Display
dpy Drawable
rootw
          (CInt, CInt) -> IO (CInt, CInt)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
x,CInt
y)
        windowWithFocus :: WindowAttributes -> IO (CInt, CInt)
windowWithFocus WindowAttributes
attr = do
          (Bool
_, Position
x, Position
y, Drawable
_) <- Display
-> Drawable
-> Drawable
-> Position
-> Position
-> IO (Bool, Position, Position, Drawable)
translateCoordinates Display
dpy Drawable
rootw Drawable
rootw
                          (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
attr) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
attr)
          (CInt, CInt) -> IO (CInt, CInt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Position
x,Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Position
y)

mkWindow :: Display -> Screen -> Window -> Bool -> Position
                  -> Position -> Dimension -> Dimension -> IO Window
mkWindow :: Display
-> Screen
-> Drawable
-> Bool
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Drawable
mkWindow Display
dpy Screen
s Drawable
rw Bool
o Position
x Position
y Dimension
w Dimension
h = do
  let visual :: Visual
visual   = Screen -> Visual
defaultVisualOfScreen Screen
s
      attrmask :: Drawable
attrmask = Drawable
cWOverrideRedirect
      black :: Drawable
black    = Screen -> Drawable
blackPixelOfScreen Screen
s
      white :: Drawable
white    = Screen -> Drawable
whitePixelOfScreen Screen
s
  IO Drawable -> IO Drawable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Drawable -> IO Drawable) -> IO Drawable -> IO Drawable
forall a b. (a -> b) -> a -> b
$ (Ptr SetWindowAttributes -> IO Drawable) -> IO Drawable
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Drawable) -> IO Drawable)
-> (Ptr SetWindowAttributes -> IO Drawable) -> IO Drawable
forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
attrs -> do
    Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attrs Bool
o
    Ptr SetWindowAttributes -> Drawable -> IO ()
set_background_pixel Ptr SetWindowAttributes
attrs Drawable
white
    Ptr SetWindowAttributes -> Drawable -> IO ()
set_border_pixel Ptr SetWindowAttributes
attrs Drawable
black
    Display
-> Drawable
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> Drawable
-> Ptr SetWindowAttributes
-> IO Drawable
createWindow Display
dpy Drawable
rw Position
x Position
y Dimension
w Dimension
h CInt
0 CInt
copyFromParent
                 CInt
inputOutput Visual
visual Drawable
attrmask Ptr SetWindowAttributes
attrs

type Xlock = MVar ()

lockXlock :: MonadIO m => Xlock -> m ()
lockXlock :: Xlock -> m ()
lockXlock Xlock
xlock = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Xlock -> IO ()
forall a. MVar a -> IO a
takeMVar Xlock
xlock
lockX :: SindreX11M ()
lockX :: SindreX11M ()
lockX = do Xlock
xlock <- (SindreX11Conf -> Xlock) -> SindreX11M Xlock
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Xlock
sindreXlock
           IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Xlock -> IO ()
forall a. MVar a -> IO a
takeMVar Xlock
xlock

unlockXlock :: MonadIO m => Xlock -> m ()
unlockXlock :: Xlock -> m ()
unlockXlock Xlock
xlock = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Xlock -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar Xlock
xlock ()
unlockX :: SindreX11M ()
unlockX :: SindreX11M ()
unlockX = do Xlock
xlock <- (SindreX11Conf -> Xlock) -> SindreX11M Xlock
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Xlock
sindreXlock
             IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Xlock -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar Xlock
xlock ()

getX11Event :: Display -> Window -> XIC -> IO (KeySym, String, X.Event)
getX11Event :: Display -> Drawable -> XIC -> IO (Drawable, String, Event)
getX11Event Display
dpy Drawable
win XIC
ic = do
  (Maybe String
str,Maybe Drawable
keysym,Event
event) <-
    (XEventPtr -> IO (Maybe String, Maybe Drawable, Event))
-> IO (Maybe String, Maybe Drawable, Event)
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (Maybe String, Maybe Drawable, Event))
 -> IO (Maybe String, Maybe Drawable, Event))
-> (XEventPtr -> IO (Maybe String, Maybe Drawable, Event))
-> IO (Maybe String, Maybe Drawable, Event)
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
      Display -> XEventPtr -> IO ()
nextEvent Display
dpy XEventPtr
e
      Event
ev <- XEventPtr -> IO Event
X.getEvent XEventPtr
e
      (Maybe String
ks,Maybe Drawable
s) <- IO Bool
-> IO (Maybe String, Maybe Drawable)
-> IO (Maybe String, Maybe Drawable)
-> IO (Maybe String, Maybe Drawable)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((Event -> Dimension
ev_event_type Event
ev Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
/= Dimension
keyPress Bool -> Bool -> Bool
||) (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                     XEventPtr -> Drawable -> IO Bool
filterEvent XEventPtr
e Drawable
win)
                    ((Maybe String, Maybe Drawable) -> IO (Maybe String, Maybe Drawable)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, Maybe Drawable
forall a. Maybe a
Nothing))
                    (XIC -> XEventPtr -> IO (Maybe String, Maybe Drawable)
utf8LookupString XIC
ic XEventPtr
e)
      (Maybe String, Maybe Drawable, Event)
-> IO (Maybe String, Maybe Drawable, Event)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
ks,Maybe Drawable
s,Event
ev)
  (Drawable, String, Event) -> IO (Drawable, String, Event)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Drawable -> Maybe Drawable -> Drawable
forall a. a -> Maybe a -> a
fromMaybe Drawable
xK_VoidSymbol Maybe Drawable
keysym
         , String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
str
         , Event
event)

processX11Event :: (KeySym, String, X.Event) -> EventThunk
processX11Event :: (Drawable, String, Event) -> EventThunk
processX11Event (Drawable
ks, String
s, KeyEvent {ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_state :: Event -> KeyMask
ev_state = KeyMask
m })
    | Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress =
      Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Event -> EventThunk) -> Maybe Event -> EventThunk
forall a b. (a -> b) -> a -> b
$ (Chord -> Event
KeyPress (Chord -> Event) -> (Key -> Chord) -> Key -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Chord
mods) (Key -> Event) -> Maybe Key -> Maybe Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             case String
s of
               String
_ | String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"\127", String
"\8", String
"\13", String
"", String
"\27"] ->
                 Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ String -> Key
CtrlKey (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Drawable -> String
keysymToString Drawable
ks
               [Char
c] | Bool -> Bool
not (Char -> Bool
isPrint Char
c) ->
                 case Drawable -> String
keysymToString Drawable
ks of
                   [Char
ks'] -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ Char -> Key
CharKey Char
ks'
                   String
ks'   -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ String -> Key
CtrlKey String
ks'
               [Char
c]  -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ Char -> Key
CharKey Char
c
               String
_ -> Maybe Key
forall a. Maybe a
Nothing
      where mods :: Key -> Chord
mods (CharKey Char
c) = (KeyModifier
Shift KeyModifier -> Set KeyModifier -> Set KeyModifier
forall a. Ord a => a -> Set a -> Set a
`S.delete` KeyMask -> Set KeyModifier
getModifiers KeyMask
m, Char -> Key
CharKey Char
c)
            mods (CtrlKey String
c) = (KeyMask -> Set KeyModifier
getModifiers KeyMask
m, String -> Key
CtrlKey String
c)
processX11Event (Drawable
_, String
_, ExposeEvent { ev_x :: Event -> CInt
ev_x = CInt
x, ev_y :: Event -> CInt
ev_y = CInt
y
                                   , ev_width :: Event -> CInt
ev_width = CInt
w, ev_height :: Event -> CInt
ev_height = CInt
h }) =
  [Rectangle] -> Sindre SindreX11M ()
forall (m :: * -> *). MonadBackend m => [Rectangle] -> Sindre m ()
redrawRegion [Integer -> Integer -> Integer -> Integer -> Rectangle
Rectangle (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
x) (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
y) (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
w) (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
h)] Sindre SindreX11M () -> EventThunk -> EventThunk
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
forall a. Maybe a
Nothing
processX11Event (Drawable
_, String
_, ConfigureEvent { ev_window :: Event -> Drawable
ev_window = Drawable
win
                                      , ev_width :: Event -> CInt
ev_width = CInt
w, ev_height :: Event -> CInt
ev_height = CInt
h }) = do
  SindreX11M () -> Sindre SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> Sindre SindreX11M ())
-> SindreX11M () -> Sindre SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do Bool
onsurface <- (Drawable -> Drawable -> Bool
forall a. Eq a => a -> a -> Bool
==Drawable
win) (Drawable -> Bool) -> SindreX11M Drawable -> SindreX11M Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Surface -> Drawable) -> SindreX11M Drawable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Surface -> Drawable
surfaceWindow
            Bool -> SindreX11M () -> SindreX11M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
onsurface (SindreX11M () -> SindreX11M ()) -> SindreX11M () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
              IO Surface
sur <- (Display -> XftMgr -> Surface -> Rectangle -> IO Surface)
-> SindreX11M
     (Display -> XftMgr -> Surface -> Rectangle -> IO Surface)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Display -> XftMgr -> Surface -> Rectangle -> IO Surface
resizeSurface
                            SindreX11M
  (Display -> XftMgr -> Surface -> Rectangle -> IO Surface)
-> SindreX11M Display
-> SindreX11M (XftMgr -> Surface -> Rectangle -> IO Surface)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SindreX11Conf -> Display) -> SindreX11M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Display
sindreDisplay
                            SindreX11M (XftMgr -> Surface -> Rectangle -> IO Surface)
-> SindreX11M XftMgr
-> SindreX11M (Surface -> Rectangle -> IO Surface)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SindreX11Conf -> XftMgr) -> SindreX11M XftMgr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> XftMgr
sindreXftMgr SindreX11M (Surface -> Rectangle -> IO Surface)
-> SindreX11M Surface -> SindreX11M (Rectangle -> IO Surface)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SindreX11M Surface
forall s (m :: * -> *). MonadState s m => m s
get
                            SindreX11M (Rectangle -> IO Surface)
-> SindreX11M Rectangle -> SindreX11M (IO Surface)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rectangle -> SindreX11M Rectangle
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Integer -> Integer -> Integer -> Rectangle
Rectangle Integer
0 Integer
0 (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
w) (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
h))
              Surface -> SindreX11M ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Surface -> SindreX11M ()) -> SindreX11M Surface -> SindreX11M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Surface -> SindreX11M Surface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO Surface
sur
  Sindre SindreX11M ()
forall (m :: * -> *). MonadBackend m => Sindre m ()
redrawRoot Sindre SindreX11M () -> EventThunk -> EventThunk
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
forall a. Maybe a
Nothing
processX11Event (Drawable
_, String
_, AnyEvent { ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t })
  | Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
visibilityNotify = do SindreX11M () -> Sindre SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> Sindre SindreX11M ())
-> SindreX11M () -> Sindre SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
                                 Display
dpy <- (SindreX11Conf -> Display) -> SindreX11M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Display
sindreDisplay
                                 Drawable
win <- (Surface -> Drawable) -> SindreX11M Drawable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Surface -> Drawable
surfaceWindow
                                 IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Display -> Drawable -> IO ()
raiseWindow Display
dpy Drawable
win
                               Sindre SindreX11M ()
forall (m :: * -> *). MonadBackend m => Sindre m ()
redrawRoot
                               Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
forall a. Maybe a
Nothing
processX11Event (Drawable, String, Event)
_ = Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
forall a. Maybe a
Nothing

eventReader :: Display -> Window -> XIC -> MVar EventThunk ->
               Xlock -> IO ()
eventReader :: Display -> Drawable -> XIC -> MVar EventThunk -> Xlock -> IO ()
eventReader Display
dpy Drawable
win XIC
ic MVar EventThunk
evvar Xlock
xlock = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Xlock -> IO ()
forall (m :: * -> *). MonadIO m => Xlock -> m ()
lockXlock Xlock
xlock
    IO ()
waitUntilEvent
    (Drawable, String, Event)
xev <- Display -> Drawable -> XIC -> IO (Drawable, String, Event)
getX11Event Display
dpy Drawable
win XIC
ic
    Xlock -> IO ()
forall (m :: * -> *). MonadIO m => Xlock -> m ()
unlockXlock Xlock
xlock
    MVar EventThunk -> EventThunk -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar EventThunk
evvar (EventThunk -> IO ()) -> EventThunk -> IO ()
forall a b. (a -> b) -> a -> b
$ (Drawable, String, Event) -> EventThunk
processX11Event (Drawable, String, Event)
xev
      where waitUntilEvent :: IO ()
waitUntilEvent = do
              CInt
cnt <- Display -> CInt -> IO CInt
eventsQueued Display
dpy CInt
queuedAfterFlush
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
cnt CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                -- The following two lines have a race condition.
                Xlock -> IO ()
forall (m :: * -> *). MonadIO m => Xlock -> m ()
unlockXlock Xlock
xlock
                Fd -> IO ()
threadWaitRead (Fd -> IO ()) -> Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Fd
Fd (CInt -> Fd) -> CInt -> Fd
forall a b. (a -> b) -> a -> b
$ Display -> CInt
connectionNumber Display
dpy
                Xlock -> IO ()
forall (m :: * -> *). MonadIO m => Xlock -> m ()
lockXlock Xlock
xlock
                IO ()
waitUntilEvent

-- | Get the value for a named color if it exists
maybeAllocColor :: Xft.XftMgr -> String -> IO (Maybe Xft.Color)
maybeAllocColor :: XftMgr -> String -> IO (Maybe Color)
maybeAllocColor XftMgr
mgr = XftMgr -> Visual -> Drawable -> String -> IO (Maybe Color)
Xft.openColorName XftMgr
mgr Visual
vis Drawable
colormap
  where colormap :: Drawable
colormap = Display -> Dimension -> Drawable
defaultColormap Display
dpy (Dimension -> Drawable) -> Dimension -> Drawable
forall a b. (a -> b) -> a -> b
$ Display -> Dimension
defaultScreen Display
dpy
        dpy :: Display
dpy      = XftMgr -> Display
Xft.mgrDisplay XftMgr
mgr
        vis :: Visual
vis      = Screen -> Visual
defaultVisualOfScreen (Screen -> Visual) -> Screen -> Visual
forall a b. (a -> b) -> a -> b
$ Display -> Screen
defaultScreenOfDisplay Display
dpy

allocColor :: (MonadIO m, MonadFail m) => Xft.XftMgr -> String -> m Xft.Color
allocColor :: XftMgr -> String -> m Color
allocColor XftMgr
dpy String
c = IO (Maybe Color) -> m (Maybe Color)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (XftMgr -> String -> IO (Maybe Color)
maybeAllocColor XftMgr
dpy String
c) m (Maybe Color) -> (Maybe Color -> m Color) -> m Color
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     m Color -> (Color -> m Color) -> Maybe Color -> m Color
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Color
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Color) -> String -> m Color
forall a b. (a -> b) -> a -> b
$ String
"Unknown color '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") Color -> m Color
forall (m :: * -> *) a. Monad m => a -> m a
return

sindreEventMask :: EventMask
sindreEventMask :: Drawable
sindreEventMask = Drawable
exposureMask Drawable -> Drawable -> Drawable
forall a. Bits a => a -> a -> a
.|. Drawable
structureNotifyMask

sindreX11Cfg :: String -> Bool -> IO (SindreX11Conf, Surface)
sindreX11Cfg :: String -> Bool -> IO (SindreX11Conf, Surface)
sindreX11Cfg String
dstr Bool
o = do
  Bool
sl <- IO Bool
supportsLocale
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Current locale is not supported" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
  String
_ <- String -> IO String
setLocaleModifiers String
""
  Display
dpy <- String -> IO Display
setupDisplay String
dstr
  let scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
dpy
  Xlock
xlock <- () -> IO Xlock
forall a. a -> IO (MVar a)
newMVar ()
  XftMgr
mgr <- Display -> Screen -> IO () -> IO () -> IO XftMgr
Xft.newXftMgr Display
dpy Screen
scr (Xlock -> IO ()
forall (m :: * -> *). MonadIO m => Xlock -> m ()
lockXlock Xlock
xlock) (Xlock -> IO ()
forall (m :: * -> *). MonadIO m => Xlock -> m ()
unlockXlock Xlock
xlock)
  IO ()
rmInitialize
  Maybe String
s <- Display -> IO (Maybe String)
resourceManagerString Display
dpy
  Maybe RMDatabase
db <- case Maybe String
s of Maybe String
Nothing -> Maybe RMDatabase -> IO (Maybe RMDatabase)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RMDatabase
forall a. Maybe a
Nothing
                  Just String
s' -> String -> IO (Maybe RMDatabase)
rmGetStringDatabase String
s'
  Rectangle
rect <- Display -> Drawable -> IO Rectangle
findRectangle Display
dpy (Screen -> Drawable
rootWindowOfScreen Screen
scr)
  Drawable
win <- Display
-> Screen
-> Drawable
-> Bool
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Drawable
mkWindow Display
dpy Screen
scr (Screen -> Drawable
rootWindowOfScreen Screen
scr) Bool
o
         (Rectangle -> Position
rect_x Rectangle
rect) (Rectangle -> Position
rect_y Rectangle
rect) (Rectangle -> Dimension
rect_width Rectangle
rect) (Rectangle -> Dimension
rect_height Rectangle
rect)
  Surface
surface <- Display -> XftMgr -> Screen -> Drawable -> Rectangle -> IO Surface
newSurface Display
dpy XftMgr
mgr Screen
scr Drawable
win (Rectangle -> Rectangle
fromXRect Rectangle
rect)
  Display -> Surface -> [Rectangle] -> IO ()
setShape Display
dpy Surface
surface []
  XIM
im <- Display
-> Maybe XrmDatabase -> Maybe String -> Maybe String -> IO XIM
openIM Display
dpy Maybe XrmDatabase
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
  XIC
ic <- XIM -> [XNInputStyle] -> Drawable -> IO XIC
createIC XIM
im [XNInputStyle
XIMPreeditNothing, XNInputStyle
XIMStatusNothing] Drawable
win
  MVar EventThunk
evvar <- IO (MVar EventThunk)
forall a. IO (MVar a)
newEmptyMVar
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Display -> Drawable -> XIC -> MVar EventThunk -> Xlock -> IO ()
eventReader Display
dpy Drawable
win XIC
ic MVar EventThunk
evvar Xlock
xlock
  VisualOpts
visopts <- XftMgr -> IO VisualOpts
defVisualOpts XftMgr
mgr
  (SindreX11Conf, Surface) -> IO (SindreX11Conf, Surface)
forall (m :: * -> *) a. Monad m => a -> m a
return (SindreX11Conf :: Display
-> VisualOpts
-> Maybe RMDatabase
-> Xlock
-> MVar EventThunk
-> ([Rectangle] -> SindreX11M ())
-> XftMgr
-> SindreX11Conf
SindreX11Conf
          { sindreDisplay :: Display
sindreDisplay = Display
dpy
          , sindreVisualOpts :: VisualOpts
sindreVisualOpts = VisualOpts
visopts
          , sindreRMDB :: Maybe RMDatabase
sindreRMDB = Maybe RMDatabase
db
          , sindreEvtVar :: MVar EventThunk
sindreEvtVar = MVar EventThunk
evvar
          , sindreXlock :: Xlock
sindreXlock = Xlock
xlock
          , sindreReshape :: [Rectangle] -> SindreX11M ()
sindreReshape = [Rectangle] -> SindreX11M ()
forall (m :: * -> *).
(MonadState Surface m, MonadReader SindreX11Conf m, MonadIO m) =>
[Rectangle] -> m ()
reshape
          , sindreXftMgr :: XftMgr
sindreXftMgr = XftMgr
mgr }, Surface
surface)
    where reshape :: [Rectangle] -> m ()
reshape [Rectangle]
rs = do Surface
sur <- m Surface
forall s (m :: * -> *). MonadState s m => m s
get
                          Display
dpy <- (SindreX11Conf -> Display) -> m Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Display
sindreDisplay
                          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> Surface -> [Rectangle] -> IO ()
setShape Display
dpy Surface
sur [Rectangle]
rs

-- | Options regarding visual appearance of widgets (colors and
-- fonts).
data VisualOpts = VisualOpts {
      VisualOpts -> Color
foreground      :: Xft.Color
    , VisualOpts -> Color
background      :: Xft.Color
    , VisualOpts -> Color
focusForeground :: Xft.Color
    , VisualOpts -> Color
focusBackground :: Xft.Color
    , VisualOpts -> Font
font            :: Xft.Font
    }

defVisualOpts :: Xft.XftMgr -> IO VisualOpts
defVisualOpts :: XftMgr -> IO VisualOpts
defVisualOpts XftMgr
mgr = do
  Maybe Font
font   <- XftMgr -> String -> IO (Maybe Font)
Xft.openFontName XftMgr
mgr String
"Monospace"
  case Maybe Font
font of Just Font
font' ->
                 (Color -> Color -> Color -> Color -> Font -> VisualOpts)
-> IO (Color -> Color -> Color -> Color -> Font -> VisualOpts)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color -> Color -> Color -> Color -> Font -> VisualOpts
VisualOpts IO (Color -> Color -> Color -> Color -> Font -> VisualOpts)
-> IO Color -> IO (Color -> Color -> Color -> Font -> VisualOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Color
f String
fg IO (Color -> Color -> Color -> Font -> VisualOpts)
-> IO Color -> IO (Color -> Color -> Font -> VisualOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Color
f String
bg IO (Color -> Color -> Font -> VisualOpts)
-> IO Color -> IO (Color -> Font -> VisualOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Color
f String
ffg IO (Color -> Font -> VisualOpts)
-> IO Color -> IO (Font -> VisualOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Color
f String
fbg
                        IO (Font -> VisualOpts) -> IO Font -> IO VisualOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Font -> IO Font
forall (f :: * -> *) a. Applicative f => a -> f a
pure Font
font'
               Maybe Font
Nothing    -> String -> IO VisualOpts
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot open Monospace font"
  where (String
fg, String
bg, String
ffg, String
fbg) = (String
"black", String
"grey", String
"white", String
"blue")
        f :: String -> IO Color
f = XftMgr -> String -> IO Color
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
XftMgr -> String -> m Color
allocColor XftMgr
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 :: String -> SindreX11M ExitCode -> IO ExitCode
sindreX11override String
dstr SindreX11M ExitCode
start = do
  (SindreX11Conf
cfg, Surface
sur) <- String -> Bool -> IO (SindreX11Conf, Surface)
sindreX11Cfg String
dstr Bool
True
  CInt
_ <- IO CInt -> IO CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Display -> Drawable -> IO CInt
mapRaised (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur)
  CInt
status <- Display -> Drawable -> IO CInt
grabInput (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur)
  IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Display -> Drawable -> Drawable -> IO ()
selectInput (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur) (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$
     Drawable
sindreEventMask Drawable -> Drawable -> Drawable
forall a. Bits a => a -> a -> a
.|. Drawable
visibilityChangeMask
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
status CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. HasCallStack => String -> a
error String
"Could not establish keyboard grab"
  SindreX11M ExitCode -> SindreX11Conf -> Surface -> IO ExitCode
forall a. SindreX11M a -> SindreX11Conf -> Surface -> IO a
runSindreX11 (SindreX11M ()
lockX SindreX11M () -> SindreX11M ExitCode -> SindreX11M ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SindreX11M ExitCode
start) SindreX11Conf
cfg Surface
sur IO ExitCode -> IO () -> IO ExitCode
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* XftMgr -> IO ()
Xft.freeXftMgr (SindreX11Conf -> XftMgr
sindreXftMgr SindreX11Conf
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 :: String -> SindreX11M ExitCode -> IO ExitCode
sindreX11 String
dstr SindreX11M ExitCode
start = do
  (SindreX11Conf
cfg, Surface
sur) <- String -> Bool -> IO (SindreX11Conf, Surface)
sindreX11Cfg String
dstr Bool
False
  CInt
_ <- IO CInt -> IO CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Display -> Drawable -> IO CInt
mapRaised (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur)
  Display -> Drawable -> Drawable -> IO ()
selectInput (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur) (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$
    Drawable
keyPressMask Drawable -> Drawable -> Drawable
forall a. Bits a => a -> a -> a
.|. Drawable
keyReleaseMask Drawable -> Drawable -> Drawable
forall a. Bits a => a -> a -> a
.|. Drawable
sindreEventMask
  SindreX11M ExitCode -> SindreX11Conf -> Surface -> IO ExitCode
forall a. SindreX11M a -> SindreX11Conf -> Surface -> IO a
runSindreX11 (SindreX11M ()
lockX SindreX11M () -> SindreX11M ExitCode -> SindreX11M ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SindreX11M ExitCode
start) SindreX11Conf
cfg Surface
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 :: String -> SindreX11M ExitCode -> IO ExitCode
sindreX11dock String
dstr SindreX11M ExitCode
start = do
  (SindreX11Conf
cfg, Surface
sur) <- String -> Bool -> IO (SindreX11Conf, Surface)
sindreX11Cfg String
dstr Bool
False
  let d :: Display
d = SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg
      w :: Drawable
w = Surface -> Drawable
surfaceWindow Surface
sur
  Drawable
a1 <- Display -> String -> Bool -> IO Drawable
internAtom Display
d String
"_NET_WM_STRUT_PARTIAL"    Bool
False
  Drawable
c1 <- Display -> String -> Bool -> IO Drawable
internAtom Display
d String
"CARDINAL"                 Bool
False
  Drawable
a2 <- Display -> String -> Bool -> IO Drawable
internAtom Display
d String
"_NET_WM_WINDOW_TYPE"      Bool
False
  Drawable
c2 <- Display -> String -> Bool -> IO Drawable
internAtom Display
d String
"ATOM"                     Bool
False
  Drawable
v  <- Display -> String -> Bool -> IO Drawable
internAtom Display
d String
"_NET_WM_WINDOW_TYPE_DOCK" Bool
False
  let reshape :: [Rectangle] -> SindreX11M ()
reshape [Rectangle]
rs = do
        IO () -> SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> SindreX11M ()) -> IO () -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Display
-> Drawable -> Drawable -> Drawable -> CInt -> [CLong] -> IO ()
changeProperty32 Display
d Drawable
w Drawable
a1 Drawable
c1 CInt
propModeReplace ([CLong] -> IO ()) -> [CLong] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Integer -> CLong) -> [Integer] -> [CLong]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fi ([Integer] -> [CLong]) -> [Integer] -> [CLong]
forall a b. (a -> b) -> a -> b
$
          Rectangle -> Rectangle -> [Integer]
getStrutValues ([Rectangle] -> Rectangle
forall a. Monoid a => [a] -> a
mconcat [Rectangle]
rs) (Surface -> Rectangle
surfaceBounds Surface
sur)
        SindreX11Conf -> [Rectangle] -> SindreX11M ()
sindreReshape SindreX11Conf
cfg [Rectangle]
rs
  Display
-> Drawable -> Drawable -> Drawable -> CInt -> [CLong] -> IO ()
changeProperty32 Display
d Drawable
w Drawable
a2 Drawable
c2 CInt
propModeReplace [Drawable -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Drawable
v]
  Display -> Drawable -> Drawable -> IO ()
selectInput (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur) Drawable
sindreEventMask
  Display -> Drawable -> IO ()
lowerWindow (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur)
  ()
_ <- Display -> Drawable -> IO ()
mapWindow (SindreX11Conf -> Display
sindreDisplay SindreX11Conf
cfg) (Surface -> Drawable
surfaceWindow Surface
sur)
  SindreX11M ExitCode -> SindreX11Conf -> Surface -> IO ExitCode
forall a. SindreX11M a -> SindreX11Conf -> Surface -> IO a
runSindreX11 (SindreX11M ()
lockX SindreX11M () -> SindreX11M ExitCode -> SindreX11M ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SindreX11M ExitCode
start) SindreX11Conf
cfg { sindreReshape :: [Rectangle] -> SindreX11M ()
sindreReshape = [Rectangle] -> SindreX11M ()
reshape } Surface
sur
    where strutArea :: [p] -> p
strutArea [p
left, p
right, p
top, p
bot,
                     p
left_y1, p
left_y2, p
right_y1, p
right_y2,
                     p
top_x1, p
top_x2, p
bot_x1, p
bot_x2] =
                           p
leftp -> p -> p
forall a. Num a => a -> a -> a
*(p
left_y2p -> p -> p
forall a. Num a => a -> a -> a
-p
left_y1)p -> p -> p
forall a. Num a => a -> a -> a
+p
rightp -> p -> p
forall a. Num a => a -> a -> a
*(p
right_y2p -> p -> p
forall a. Num a => a -> a -> a
-p
right_y1)p -> p -> p
forall a. Num a => a -> a -> a
+
                           p
topp -> p -> p
forall a. Num a => a -> a -> a
*(p
top_x2p -> p -> p
forall a. Num a => a -> a -> a
-p
top_x1)p -> p -> p
forall a. Num a => a -> a -> a
+p
botp -> p -> p
forall a. Num a => a -> a -> a
*(p
bot_x2p -> p -> p
forall a. Num a => a -> a -> a
-p
bot_x1)
          strutArea [p]
_ = p
0
          getStrutValues :: Rectangle -> Rectangle -> [Integer]
getStrutValues Rectangle
r1 Rectangle
r2 = ([Integer] -> [Integer] -> Ordering) -> [[Integer]] -> [Integer]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (([Integer] -> Integer) -> [Integer] -> [Integer] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Integer] -> Integer
forall p. Num p => [p] -> p
strutArea)
            [[Integer
0,Integer
0,Rectangle -> Integer
rectY Rectangle
r1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Rectangle -> Integer
rectHeight Rectangle
r1,Integer
0,
              Integer
0,Integer
0,Integer
0,Integer
0,Rectangle -> Integer
rectX Rectangle
r1,Rectangle -> Integer
rectX Rectangle
r1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Rectangle -> Integer
rectWidth Rectangle
r1,Integer
0,Integer
0],
             [Integer
0,Integer
0,Integer
0,Rectangle -> Integer
rectHeight Rectangle
r2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Rectangle -> Integer
rectY Rectangle
r1,
              Integer
0,Integer
0,Integer
0,Integer
0,Integer
0,Integer
0,Rectangle -> Integer
rectX Rectangle
r1,Rectangle -> Integer
rectX Rectangle
r1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Rectangle -> Integer
rectWidth Rectangle
r1],
             [Rectangle -> Integer
rectX Rectangle
r1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Rectangle -> Integer
rectWidth Rectangle
r1,Integer
0,Integer
0,Integer
0,
              Rectangle -> Integer
rectY Rectangle
r1,Rectangle -> Integer
rectY Rectangle
r1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Rectangle -> Integer
rectHeight Rectangle
r1,Integer
0,Integer
0,Integer
0,Integer
0,Integer
0,Integer
0],
             [Integer
0,Rectangle -> Integer
rectWidth Rectangle
r2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Rectangle -> Integer
rectX Rectangle
r1,Integer
0,Integer
0,
              Integer
0,Integer
0,Rectangle -> Integer
rectY Rectangle
r1,Rectangle -> Integer
rectY Rectangle
r1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Rectangle -> Integer
rectHeight Rectangle
r1,Integer
0,Integer
0,Integer
0,Integer
0]
             ]

-- | 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 :: Handle -> WidgetRef -> SindreX11M (NewObject SindreX11M)
mkInStream Handle
h WidgetRef
r = do
  MVar EventThunk
evvar <- (SindreX11Conf -> MVar EventThunk) -> SindreX11M (MVar EventThunk)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> MVar EventThunk
sindreEvtVar
  MVar (Maybe Text)
linevar <- IO (MVar (Maybe Text)) -> SindreX11M (MVar (Maybe Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO (MVar (Maybe Text))
forall a. IO (MVar a)
newEmptyMVar
  let putEv :: (EventSource -> Event) -> IO ()
putEv EventSource -> Event
ev = MVar EventThunk -> EventThunk -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar EventThunk
evvar (EventThunk -> IO ()) -> EventThunk -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Event -> EventThunk
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Event -> EventThunk) -> Maybe Event -> EventThunk
forall a b. (a -> b) -> a -> b
$ Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ EventSource -> Event
ev (EventSource -> Event) -> EventSource -> Event
forall a b. (a -> b) -> a -> b
$ WidgetRef -> EventSource
ObjectSrc WidgetRef
r
      getLines :: IO ()
getLines = do
        Maybe Text
lns <- MVar (Maybe Text) -> IO (Maybe Text)
forall a. MVar a -> IO a
takeMVar MVar (Maybe Text)
linevar
        case Maybe Text
lns of Just Text
lns' -> Text -> IO ()
getLines' Text
lns' IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
getLines
                    Maybe Text
Nothing   -> (EventSource -> Event) -> IO ()
putEv ((EventSource -> Event) -> IO ())
-> (EventSource -> Event) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [Value] -> EventSource -> Event
NamedEvent String
"eof" []
      getLines' :: Text -> IO ()
getLines' Text
lns = do
        Maybe (Maybe Text)
more <- MVar (Maybe Text) -> IO (Maybe (Maybe Text))
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar (Maybe Text)
linevar
        case Maybe (Maybe Text)
more of Just Maybe Text
Nothing -> do
                       (EventSource -> Event) -> IO ()
putEv ((EventSource -> Event) -> IO ())
-> (EventSource -> Event) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [Value] -> EventSource -> Event
NamedEvent String
"lines" [Text -> Value
StringV Text
lns]
                       (EventSource -> Event) -> IO ()
putEv ((EventSource -> Event) -> IO ())
-> (EventSource -> Event) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [Value] -> EventSource -> Event
NamedEvent String
"eof" []
                     Just (Just Text
more') -> Text -> IO ()
getLines' (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
lns Text -> Text -> Text
`T.append` Text
more'
                     Maybe (Maybe Text)
Nothing -> (EventSource -> Event) -> IO ()
putEv ((EventSource -> Event) -> IO ())
-> (EventSource -> Event) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [Value] -> EventSource -> Event
NamedEvent String
"lines" [Text -> Value
StringV Text
lns]
      readLines :: ByteString -> IO ()
readLines ByteString
buf = do
        (ByteString
ls, ByteString
buf') <- Handle -> ByteString -> IO (ByteString, ByteString)
readLinesNonBlocking Handle
h ByteString
buf
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
ls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe Text) -> Maybe Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe Text)
linevar (Maybe Text -> IO ()) -> Maybe Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decode ByteString
ls
        Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
        if Bool
eof then do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
buf' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
B.empty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                         MVar (Maybe Text) -> Maybe Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe Text)
linevar (Maybe Text -> IO ()) -> Maybe Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decode ByteString
buf'
                       MVar (Maybe Text) -> Maybe Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe Text)
linevar Maybe Text
forall a. Maybe a
Nothing
               else ByteString -> IO ()
readLines ByteString
buf'
  ThreadId
_ <- IO ThreadId -> SindreX11M ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ThreadId -> SindreX11M ThreadId)
-> IO ThreadId -> SindreX11M ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
getLines
  ThreadId
_ <- IO ThreadId -> SindreX11M ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ThreadId -> SindreX11M ThreadId)
-> IO ThreadId -> SindreX11M ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
readLines ByteString
B.empty
  NewObject SindreX11M -> SindreX11M (NewObject SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewObject SindreX11M -> SindreX11M (NewObject SindreX11M))
-> NewObject SindreX11M -> SindreX11M (NewObject SindreX11M)
forall a b. (a -> b) -> a -> b
$ Handle
-> Map String (Method Handle SindreX11M)
-> [Field Handle SindreX11M]
-> (Event -> ObjectM Handle SindreX11M ())
-> NewObject SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> NewObject im
newObject Handle
h Map String (Method Handle SindreX11M)
forall k a. Map k a
M.empty [] (ObjectM Handle SindreX11M ()
-> Event -> ObjectM Handle SindreX11M ()
forall a b. a -> b -> a
const (ObjectM Handle SindreX11M ()
 -> Event -> ObjectM Handle SindreX11M ())
-> ObjectM Handle SindreX11M ()
-> Event
-> ObjectM Handle SindreX11M ()
forall a b. (a -> b) -> a -> b
$ () -> ObjectM Handle SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    where decode :: ByteString -> Text
decode = OnDecodeError -> ByteString -> Text
E.decodeUtf8With OnDecodeError
E.lenientDecode

readLinesNonBlocking :: Handle -> B.ByteString -> IO (B.ByteString, B.ByteString)
readLinesNonBlocking :: Handle -> ByteString -> IO (ByteString, ByteString)
readLinesNonBlocking Handle
h ByteString
b = do
  ByteString
b' <- Handle -> Int -> IO ByteString
B.hGetNonBlocking Handle
h Int
bufferSize
  if ByteString -> Bool
B.null ByteString
b' then (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString) -> IO (ByteString, ByteString))
-> (ByteString, ByteString) -> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
splitLines ByteString
b
               else do let (ByteString
ls, ByteString
b'') = ByteString -> (ByteString, ByteString)
splitLines (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
b ByteString -> ByteString -> ByteString
`B.append` ByteString
b'
                       (ByteString
ls',ByteString
b''') <- Handle -> ByteString -> IO (ByteString, ByteString)
readLinesNonBlocking Handle
h ByteString
b''
                       (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
ls ByteString -> ByteString -> ByteString
`B.append` ByteString
ls', ByteString
b''')
  where bufferSize :: Int
bufferSize = Int
1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024
        splitLines :: ByteString -> (ByteString, ByteString)
splitLines = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.breakEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'\n'))

-- | 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 :: Maybe String -> String -> String -> ConstructorM SindreX11M a
xopt Maybe String
name String
clss String
attr = do
  String
progname <- IO String -> ConstructorM SindreX11M String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO String
getProgName
  let clss' :: String
clss' = String
"Sindre" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
clss String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
attr
      name' :: String
name' = String
progname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"_" Maybe String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
attr
  Maybe RMDatabase
mdb <- SindreX11M (Maybe RMDatabase)
-> ConstructorM SindreX11M (Maybe RMDatabase)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Maybe RMDatabase)
 -> ConstructorM SindreX11M (Maybe RMDatabase))
-> SindreX11M (Maybe RMDatabase)
-> ConstructorM SindreX11M (Maybe RMDatabase)
forall a b. (a -> b) -> a -> b
$ (SindreX11Conf -> Maybe RMDatabase)
-> SindreX11M (Maybe RMDatabase)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Maybe RMDatabase
sindreRMDB
  case Maybe RMDatabase
mdb of
    Maybe RMDatabase
Nothing -> String -> ConstructorM SindreX11M a
forall (m :: * -> *) a. String -> ConstructorM m a
noParam String
name'
    Just RMDatabase
db -> do
      Maybe (String, RMValue)
res <- IO (Maybe (String, RMValue))
-> ConstructorM SindreX11M (Maybe (String, RMValue))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe (String, RMValue))
 -> ConstructorM SindreX11M (Maybe (String, RMValue)))
-> IO (Maybe (String, RMValue))
-> ConstructorM SindreX11M (Maybe (String, RMValue))
forall a b. (a -> b) -> a -> b
$ RMDatabase -> String -> String -> IO (Maybe (String, RMValue))
rmGetResource RMDatabase
db String
name' String
clss'
      case Maybe (String, RMValue)
res of
        Maybe (String, RMValue)
Nothing -> String -> ConstructorM SindreX11M a
forall (m :: * -> *) a. String -> ConstructorM m a
noParam String
name'
        Just (String
"String", RMValue
v) -> do
          String
v' <- IO String -> ConstructorM SindreX11M String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> ConstructorM SindreX11M String)
-> IO String -> ConstructorM SindreX11M String
forall a b. (a -> b) -> a -> b
$ RMValue -> IO String
rmValue RMValue
v
          ConstructorM SindreX11M a
-> (a -> ConstructorM SindreX11M a)
-> Maybe a
-> ConstructorM SindreX11M a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Value -> ConstructorM SindreX11M a
forall (m :: * -> *) a. String -> Value -> ConstructorM m a
badValue String
name' (Value -> ConstructorM SindreX11M a)
-> Value -> ConstructorM SindreX11M a
forall a b. (a -> b) -> a -> b
$ String -> Value
string String
v') a -> ConstructorM SindreX11M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ConstructorM SindreX11M a)
-> ConstructorM SindreX11M (Maybe a) -> ConstructorM SindreX11M a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SindreX11M (Maybe a) -> ConstructorM SindreX11M (Maybe a)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (Value -> SindreX11M (Maybe a)
forall (m :: * -> *) a. Param m a => Value -> m (Maybe a)
moldM (Value -> SindreX11M (Maybe a)) -> Value -> SindreX11M (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> Value
string String
v')
        Just (String, RMValue)
_ -> String -> Value -> ConstructorM SindreX11M a
forall (m :: * -> *) a. String -> Value -> ConstructorM m a
badValue String
name' (Value -> ConstructorM SindreX11M a)
-> Value -> ConstructorM SindreX11M a
forall a b. (a -> b) -> a -> b
$ String -> Value
string String
"<Not a string property>"

instance Param SindreX11M Xft.Color where
  moldM :: Value -> SindreX11M (Maybe Color)
moldM (Value -> Maybe String
forall a. Mold a => Value -> Maybe a
mold -> Just String
c) =
    IO (Maybe Color) -> SindreX11M (Maybe Color)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Color) -> SindreX11M (Maybe Color))
-> (XftMgr -> IO (Maybe Color))
-> XftMgr
-> SindreX11M (Maybe Color)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XftMgr -> String -> IO (Maybe Color))
-> String -> XftMgr -> IO (Maybe Color)
forall a b c. (a -> b -> c) -> b -> a -> c
flip XftMgr -> String -> IO (Maybe Color)
maybeAllocColor String
c (XftMgr -> SindreX11M (Maybe Color))
-> SindreX11M XftMgr -> SindreX11M (Maybe Color)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SindreX11Conf -> XftMgr) -> SindreX11M XftMgr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> XftMgr
sindreXftMgr
  moldM Value
_ = Maybe Color -> SindreX11M (Maybe Color)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Color
forall a. Maybe a
Nothing

instance Param SindreX11M Xft.Font where
  moldM :: Value -> SindreX11M (Maybe Font)
moldM (Value -> Bool
true -> Bool
False) = Maybe Font -> SindreX11M (Maybe Font)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Font
forall a. Maybe a
Nothing
  moldM (Value -> Maybe String
forall a. Mold a => Value -> Maybe a
mold -> Just String
s) = do
    XftMgr
mgr <- (SindreX11Conf -> XftMgr) -> SindreX11M XftMgr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> XftMgr
sindreXftMgr
    IO (Maybe Font) -> SindreX11M (Maybe Font)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Font) -> SindreX11M (Maybe Font))
-> IO (Maybe Font) -> SindreX11M (Maybe Font)
forall a b. (a -> b) -> a -> b
$ XftMgr -> String -> IO (Maybe Font)
Xft.openFontName XftMgr
mgr String
s
  moldM Value
_ = Maybe Font -> SindreX11M (Maybe Font)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Font
forall a. Maybe a
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 :: WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts (Int
_, String
clss, Maybe String
name) = do
  VisualOpts {Font
Color
font :: Font
focusBackground :: Color
focusForeground :: Color
background :: Color
foreground :: Color
font :: VisualOpts -> Font
focusBackground :: VisualOpts -> Color
focusForeground :: VisualOpts -> Color
background :: VisualOpts -> Color
foreground :: VisualOpts -> Color
..} <- SindreX11M VisualOpts -> ConstructorM SindreX11M VisualOpts
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M VisualOpts -> ConstructorM SindreX11M VisualOpts)
-> SindreX11M VisualOpts -> ConstructorM SindreX11M VisualOpts
forall a b. (a -> b) -> a -> b
$ (SindreX11Conf -> VisualOpts) -> SindreX11M VisualOpts
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> VisualOpts
sindreVisualOpts
  Bool
flipcol <- String -> ConstructorM SindreX11M Bool
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"highlight" ConstructorM SindreX11M Bool
-> ConstructorM SindreX11M Bool -> ConstructorM SindreX11M Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> ConstructorM SindreX11M Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  let pert :: (String, Color)
-> (String, Color) -> ((String, Color), (String, Color))
pert = if Bool
flipcol then ((String, Color)
 -> (String, Color) -> ((String, Color), (String, Color)))
-> (String, Color)
-> (String, Color)
-> ((String, Color), (String, Color))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) else (,)
      ((String, Color)
fgs, (String, Color)
ffgs) = (String, Color)
-> (String, Color) -> ((String, Color), (String, Color))
pert (String
"foreground", Color
foreground)
                         (String
"focusForeground", Color
focusForeground)
      ((String, Color)
bgs, (String, Color)
fbgs) = (String, Color)
-> (String, Color) -> ((String, Color), (String, Color))
pert (String
"background", Color
background)
                         (String
"focusBackground", Color
focusBackground)
  Font
font' <- String -> ConstructorM SindreX11M Font
forall (m :: * -> *) a.
(Param m a, MonadBackend m) =>
String -> ConstructorM m a
paramM String
"font" ConstructorM SindreX11M Font
-> ConstructorM SindreX11M Font -> ConstructorM SindreX11M Font
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> String -> String -> ConstructorM SindreX11M Font
forall a.
Param SindreX11M a =>
Maybe String -> String -> String -> ConstructorM SindreX11M a
xopt Maybe String
name String
clss String
"font" ConstructorM SindreX11M Font
-> ConstructorM SindreX11M Font -> ConstructorM SindreX11M Font
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Font -> ConstructorM SindreX11M Font
forall (m :: * -> *) a. Monad m => a -> m a
return Font
font
  Color
fg <- String -> ConstructorM SindreX11M Color
forall (m :: * -> *) a.
(Param m a, MonadBackend m) =>
String -> ConstructorM m a
paramM String
"fg" ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> String -> String -> ConstructorM SindreX11M Color
forall a.
Param SindreX11M a =>
Maybe String -> String -> String -> ConstructorM SindreX11M a
xopt Maybe String
name String
clss ((String, Color) -> String
forall a b. (a, b) -> a
fst (String, Color)
fgs) ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Color) -> Color
forall a b. (a, b) -> b
snd (String, Color)
fgs)
  Color
bg <- String -> ConstructorM SindreX11M Color
forall (m :: * -> *) a.
(Param m a, MonadBackend m) =>
String -> ConstructorM m a
paramM String
"bg" ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> String -> String -> ConstructorM SindreX11M Color
forall a.
Param SindreX11M a =>
Maybe String -> String -> String -> ConstructorM SindreX11M a
xopt Maybe String
name String
clss ((String, Color) -> String
forall a b. (a, b) -> a
fst (String, Color)
bgs) ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Color) -> Color
forall a b. (a, b) -> b
snd (String, Color)
bgs)
  Color
ffg <- String -> ConstructorM SindreX11M Color
forall (m :: * -> *) a.
(Param m a, MonadBackend m) =>
String -> ConstructorM m a
paramM String
"ffg" ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> String -> String -> ConstructorM SindreX11M Color
forall a.
Param SindreX11M a =>
Maybe String -> String -> String -> ConstructorM SindreX11M a
xopt Maybe String
name String
clss ((String, Color) -> String
forall a b. (a, b) -> a
fst (String, Color)
ffgs) ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Color) -> Color
forall a b. (a, b) -> b
snd (String, Color)
ffgs)
  Color
fbg <- String -> ConstructorM SindreX11M Color
forall (m :: * -> *) a.
(Param m a, MonadBackend m) =>
String -> ConstructorM m a
paramM String
"fbg" ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String -> String -> String -> ConstructorM SindreX11M Color
forall a.
Param SindreX11M a =>
Maybe String -> String -> String -> ConstructorM SindreX11M a
xopt Maybe String
name String
clss ((String, Color) -> String
forall a b. (a, b) -> a
fst (String, Color)
fbgs) ConstructorM SindreX11M Color
-> ConstructorM SindreX11M Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Color -> ConstructorM SindreX11M Color
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Color) -> Color
forall a b. (a, b) -> b
snd (String, Color)
fbgs)
  VisualOpts -> ConstructorM SindreX11M VisualOpts
forall (m :: * -> *) a. Monad m => a -> m a
return VisualOpts :: Color -> Color -> Color -> Color -> Font -> VisualOpts
VisualOpts { foreground :: Color
foreground = Color
fg, background :: Color
background = Color
bg,
                      focusForeground :: Color
focusForeground = Color
ffg, focusBackground :: Color
focusBackground = Color
fbg,
                      font :: Font
font = 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 :: 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 :: VisualOpts
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing VisualOpts{Font
Color
font :: Font
focusBackground :: Color
focusForeground :: Color
background :: Color
foreground :: Color
font :: VisualOpts -> Font
focusBackground :: VisualOpts -> Color
focusForeground :: VisualOpts -> Color
background :: VisualOpts -> Color
foreground :: VisualOpts -> Color
..} Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle]
m r :: Rectangle
r@Rectangle{Integer
rectHeight :: Integer
rectWidth :: Integer
rectY :: Integer
rectX :: Integer
rectHeight :: Rectangle -> Integer
rectWidth :: Rectangle -> Integer
rectY :: Rectangle -> Integer
rectX :: Rectangle -> Integer
..} = do
  Display
dpy <- SindreX11M Display -> ObjectM a SindreX11M Display
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M Display -> ObjectM a SindreX11M Display)
-> SindreX11M Display -> ObjectM a SindreX11M Display
forall a b. (a -> b) -> a -> b
$ (SindreX11Conf -> Display) -> SindreX11M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SindreX11Conf -> Display
sindreDisplay
  Drawable
canvas <- SindreX11M Drawable -> ObjectM a SindreX11M Drawable
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M Drawable -> ObjectM a SindreX11M Drawable)
-> SindreX11M Drawable -> ObjectM a SindreX11M Drawable
forall a b. (a -> b) -> a -> b
$ (Surface -> Drawable) -> SindreX11M Drawable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Surface -> Drawable
surfaceCanvas
  let mkgc :: Color -> Color -> ObjectM a SindreX11M GC
mkgc Color
fg Color
bg = IO GC -> ObjectM a SindreX11M GC
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO GC -> ObjectM a SindreX11M GC)
-> IO GC -> ObjectM a SindreX11M GC
forall a b. (a -> b) -> a -> b
$ do GC
gc <- Display -> Drawable -> IO GC
createGC Display
dpy Drawable
canvas
                           Display -> GC -> Drawable -> IO ()
setForeground Display
dpy GC
gc (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Drawable
Xft.pixel Color
fg
                           Display -> GC -> Drawable -> IO ()
setBackground Display
dpy GC
gc (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Drawable
Xft.pixel Color
bg
                           GC -> IO GC
forall (m :: * -> *) a. Monad m => a -> m a
return GC
gc
  let pass :: Color -> Color -> ObjectM a SindreX11M Drawer
pass Color
fgc Color
bgc = do GC
fggc <- Color -> Color -> ObjectM a SindreX11M GC
mkgc Color
fgc Color
bgc
                        GC
bggc <- Color -> Color -> ObjectM a SindreX11M GC
mkgc Color
bgc Color
fgc
                        Drawer -> ObjectM a SindreX11M Drawer
forall (m :: * -> *) a. Monad m => a -> m a
return (Drawer -> ObjectM a SindreX11M Drawer)
-> Drawer -> ObjectM a SindreX11M Drawer
forall a b. (a -> b) -> a -> b
$ (forall f. CoreDrawer f)
-> (forall f. CoreDrawer f) -> Font -> Color -> Color -> Drawer
Drawer (\Display -> Drawable -> GC -> f
f -> Display -> Drawable -> GC -> f
f Display
dpy Drawable
canvas GC
fggc)
                                        (\Display -> Drawable -> GC -> f
f -> Display -> Drawable -> GC -> f
f Display
dpy Drawable
canvas GC
bggc)
                                        Font
font Color
fgc Color
bgc
      gcsOf :: Drawer -> [GC]
gcsOf Drawer
d = [Drawer -> forall f. CoreDrawer f
fg Drawer
d CoreDrawer GC -> CoreDrawer GC
forall a b. (a -> b) -> a -> b
$ \Display
_ Drawable
_ GC
gc -> GC
gc, Drawer -> forall f. CoreDrawer f
bg Drawer
d CoreDrawer GC -> CoreDrawer GC
forall a b. (a -> b) -> a -> b
$ \Display
_ Drawable
_ GC
gc -> GC
gc]
  Drawer
normal <- Color -> Color -> ObjectM a SindreX11M Drawer
pass Color
foreground Color
background
  Drawer
focus  <- Color -> Color -> ObjectM a SindreX11M Drawer
pass Color
focusForeground Color
focusBackground
  IO () -> ObjectM a SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ObjectM a SindreX11M ())
-> IO () -> ObjectM a SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Drawer
-> CoreDrawer
     (Position -> Position -> Dimension -> Dimension -> IO ())
Drawer -> forall f. CoreDrawer f
bg Drawer
normal Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectY)
                               (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectWidth) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectHeight)
  Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle]
m Rectangle
r Drawer
normal Drawer
focus
    ObjectM a SindreX11M [Rectangle]
-> ObjectM a SindreX11M () -> ObjectM a SindreX11M [Rectangle]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO () -> ObjectM a SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io ((GC -> IO ()) -> [GC] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> GC -> IO ()
freeGC Display
dpy) (Drawer -> [GC]
gcsOf Drawer
normal[GC] -> [GC] -> [GC]
forall a. [a] -> [a] -> [a]
++Drawer -> [GC]
gcsOf Drawer
focus) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Display -> Bool -> IO ()
sync Display
dpy Bool
False)

-- | Variant of @drawing@ that assumes the entire rectangle is used.
drawing' :: VisualOpts
         -> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
         -> Rectangle -> ObjectM a SindreX11M SpaceUse
drawing' :: VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
vo Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ()
m = VisualOpts
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing VisualOpts
vo ((Rectangle
  -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])
 -> Rectangle -> ObjectM a SindreX11M [Rectangle])
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle
r Drawer
normal Drawer
focus -> do
  Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ()
m Rectangle
r Drawer
normal Drawer
focus
  [Rectangle] -> ObjectM a SindreX11M [Rectangle]
forall (m :: * -> *) a. Monad m => a -> m a
return [Rectangle
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 { Drawer -> forall f. CoreDrawer f
fg :: forall f. CoreDrawer f
                     , Drawer -> forall f. CoreDrawer f
bg :: forall f. CoreDrawer f
                     , Drawer -> Font
drawerFont :: Xft.Font
                     , Drawer -> Color
drawerFgColor :: Xft.Color
                     , Drawer -> Color
drawerBgColor :: Xft.Color
                     }

setFgColor :: Drawer -> Xft.Color -> IO Drawer
setFgColor :: Drawer -> Color -> IO Drawer
setFgColor Drawer
d Color
c = do
  Drawer -> forall f. CoreDrawer f
fg Drawer
d CoreDrawer (IO ()) -> CoreDrawer (IO ())
forall a b. (a -> b) -> a -> b
$ \Display
dpy Drawable
_ GC
gc -> Display -> GC -> Drawable -> IO ()
setForeground Display
dpy GC
gc (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Drawable
Xft.pixel Color
c
  Drawer -> forall f. CoreDrawer f
bg Drawer
d CoreDrawer (IO ()) -> CoreDrawer (IO ())
forall a b. (a -> b) -> a -> b
$ \Display
dpy Drawable
_ GC
gc -> Display -> GC -> Drawable -> IO ()
setBackground Display
dpy GC
gc (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Drawable
Xft.pixel Color
c
  Drawer -> IO Drawer
forall (m :: * -> *) a. Monad m => a -> m a
return Drawer
d { drawerFgColor :: Color
drawerFgColor = Color
c }

setBgColor :: Drawer -> Xft.Color -> IO Drawer
setBgColor :: Drawer -> Color -> IO Drawer
setBgColor Drawer
d Color
c = do
  Drawer -> forall f. CoreDrawer f
fg Drawer
d CoreDrawer (IO ()) -> CoreDrawer (IO ())
forall a b. (a -> b) -> a -> b
$ \Display
dpy Drawable
_ GC
gc -> Display -> GC -> Drawable -> IO ()
setBackground Display
dpy GC
gc (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Drawable
Xft.pixel Color
c
  Drawer -> forall f. CoreDrawer f
bg Drawer
d CoreDrawer (IO ()) -> CoreDrawer (IO ())
forall a b. (a -> b) -> a -> b
$ \Display
dpy Drawable
_ GC
gc -> Display -> GC -> Drawable -> IO ()
setForeground Display
dpy GC
gc (Drawable -> IO ()) -> Drawable -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Drawable
Xft.pixel Color
c
  Drawer -> IO Drawer
forall (m :: * -> *) a. Monad m => a -> m a
return Drawer
d { drawerBgColor :: Color
drawerBgColor = Color
c }

padding :: Integral a => a
padding :: a
padding = a
2

type X11Field s = FieldDesc s SindreX11M

data Dial = Dial { Dial -> Integer
dialMax    :: Integer
                 , Dial -> Integer
dialVal    :: Integer
                 }

-- | 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@.
-- @<n>@ and @<p>@ are used to increase and decrease the value.
mkDial :: Constructor SindreX11M
mkDial :: Constructor SindreX11M
mkDial WidgetRef
r [] = do
  Integer
maxv <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"max" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
12
  Integer
val <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"value" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
  VisualOpts
visual <- WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts WidgetRef
r
  Sindre SindreX11M (NewWidget SindreX11M)
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Sindre SindreX11M (NewWidget SindreX11M)
 -> ConstructorM SindreX11M (NewWidget SindreX11M))
-> Sindre SindreX11M (NewWidget SindreX11M)
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ NewWidget SindreX11M -> Sindre SindreX11M (NewWidget SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget SindreX11M -> Sindre SindreX11M (NewWidget SindreX11M))
-> NewWidget SindreX11M -> Sindre SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ Dial
-> Map String (Method Dial SindreX11M)
-> [Field Dial SindreX11M]
-> (Event -> ObjectM Dial SindreX11M ())
-> ObjectM Dial SindreX11M SpaceNeed
-> (Rectangle -> ObjectM Dial SindreX11M [Rectangle])
-> NewWidget SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget (Integer -> Integer -> Dial
Dial Integer
maxv Integer
val)
         Map String (Method Dial SindreX11M)
forall k a. Map k a
M.empty [FieldDesc Dial SindreX11M Integer -> Field Dial SindreX11M
forall (im :: * -> *) v s.
(MonadFail im, Mold v) =>
FieldDesc s im v -> Field s im
field FieldDesc Dial SindreX11M Integer
value]
         Event -> ObjectM Dial SindreX11M ()
recvEventI ObjectM Dial SindreX11M SpaceNeed
composeI (VisualOpts -> Rectangle -> ObjectM Dial SindreX11M [Rectangle]
drawI VisualOpts
visual)
    where composeI :: ObjectM Dial SindreX11M SpaceNeed
composeI = SpaceNeed -> ObjectM Dial SindreX11M SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DimNeed
Exact Integer
50, Integer -> DimNeed
Exact Integer
50)
          value :: FieldDesc Dial SindreX11M Integer
value = String
-> ObjectM Dial SindreX11M Integer
-> (Integer -> ObjectM Dial SindreX11M ())
-> FieldDesc Dial SindreX11M Integer
forall s (im :: * -> *) v.
String
-> ObjectM s im v -> (v -> ObjectM s im ()) -> FieldDesc s im v
ReadWriteField String
"value" ((Dial -> Integer) -> ObjectM Dial SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Dial -> Integer
dialVal) ((Integer -> ObjectM Dial SindreX11M ())
 -> FieldDesc Dial SindreX11M Integer)
-> (Integer -> ObjectM Dial SindreX11M ())
-> FieldDesc Dial SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ \Integer
v ->
            (Dial -> Dial) -> ObjectM Dial SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Dial
s -> Dial
s { dialVal :: Integer
dialVal = Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 Integer
v (Dial -> Integer
dialMax Dial
s) }) ObjectM Dial SindreX11M ()
-> ObjectM Dial SindreX11M () -> ObjectM Dial SindreX11M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ObjectM Dial SindreX11M ()
forall (im :: * -> *) s. MonadBackend im => ObjectM s im ()
redraw
          recvEventI :: Event -> ObjectM Dial SindreX11M ()
recvEventI (KeyPress (Set KeyModifier
_, CharKey Char
'n')) = do
            Integer
dmax <- (Dial -> Integer) -> ObjectM Dial SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Dial -> Integer
dialMax
            FieldDesc Dial SindreX11M Integer
-> (Integer -> ObjectM Dial SindreX11M Integer)
-> ObjectM Dial SindreX11M ()
forall (im :: * -> *) s v.
MonadFail im =>
FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im ()
changeField_ FieldDesc Dial SindreX11M Integer
value ((Integer -> ObjectM Dial SindreX11M Integer)
 -> ObjectM Dial SindreX11M ())
-> (Integer -> ObjectM Dial SindreX11M Integer)
-> ObjectM Dial SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \Integer
v -> Integer -> ObjectM Dial SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ObjectM Dial SindreX11M Integer)
-> Integer -> ObjectM Dial SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 (Integer
vInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Integer
dmax
          recvEventI (KeyPress (Set KeyModifier
_, CharKey Char
'p')) = do
            Integer
dmax <- (Dial -> Integer) -> ObjectM Dial SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Dial -> Integer
dialMax
            FieldDesc Dial SindreX11M Integer
-> (Integer -> ObjectM Dial SindreX11M Integer)
-> ObjectM Dial SindreX11M ()
forall (im :: * -> *) s v.
MonadFail im =>
FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im ()
changeField_ FieldDesc Dial SindreX11M Integer
value ((Integer -> ObjectM Dial SindreX11M Integer)
 -> ObjectM Dial SindreX11M ())
-> (Integer -> ObjectM Dial SindreX11M Integer)
-> ObjectM Dial SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \Integer
v -> Integer -> ObjectM Dial SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ObjectM Dial SindreX11M Integer)
-> Integer -> ObjectM Dial SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a -> a
clamp Integer
0 (Integer
vInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Integer
dmax
          recvEventI Event
_ = () -> ObjectM Dial SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          drawI :: VisualOpts -> Rectangle -> ObjectM Dial SindreX11M [Rectangle]
drawI VisualOpts
visual = VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM Dial SindreX11M ())
-> Rectangle
-> ObjectM Dial SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle -> Drawer -> Drawer -> ObjectM Dial SindreX11M ())
 -> Rectangle -> ObjectM Dial SindreX11M [Rectangle])
-> (Rectangle -> Drawer -> Drawer -> ObjectM Dial SindreX11M ())
-> Rectangle
-> ObjectM Dial SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle{Integer
rectHeight :: Integer
rectWidth :: Integer
rectY :: Integer
rectX :: Integer
rectHeight :: Rectangle -> Integer
rectWidth :: Rectangle -> Integer
rectY :: Rectangle -> Integer
rectX :: Rectangle -> Integer
..} Drawer
d Drawer
_ -> do
            Integer
val    <- (Dial -> Integer) -> ObjectM Dial SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Dial -> Integer
dialVal
            Integer
maxval <- (Dial -> Integer) -> ObjectM Dial SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Dial -> Integer
dialMax
            IO () -> ObjectM Dial SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ObjectM Dial SindreX11M ())
-> IO () -> ObjectM Dial SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
              let unitAng :: Double
unitAng = Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fi Integer
maxval
                  angle :: Double
angle   = (-Double
unitAng) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fi Integer
val :: Double
                  dim :: Integer
dim     = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
rectWidth Integer
rectHeight Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
                  cornerX :: Integer
cornerX = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer
rectWidth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
dim) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2
                  cornerY :: Integer
cornerY = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectY Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer
rectHeight Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
dim) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2
              Drawer
-> CoreDrawer
     (Position
      -> Position -> Dimension -> Dimension -> CInt -> CInt -> IO ())
Drawer -> forall f. CoreDrawer f
fg Drawer
d Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> IO ()
drawArc (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
cornerX) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
cornerY) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
dim) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
dim) CInt
0 (CInt
360CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
64)
              Drawer
-> CoreDrawer
     (Position
      -> Position -> Dimension -> Dimension -> CInt -> CInt -> IO ())
Drawer -> forall f. CoreDrawer f
fg Drawer
d Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> IO ()
fillArc (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
cornerX) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
cornerY)
                   (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
dim) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
dim) (CInt
90CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
64) (Double -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> CInt) -> Double -> CInt
forall a b. (a -> b) -> a -> b
$ Double
angle Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
180Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
forall a. Floating a => a
pi) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
64)
              Drawer
-> CoreDrawer
     (Position -> Position -> Dimension -> Dimension -> IO ())
Drawer -> forall f. CoreDrawer f
fg Drawer
d Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
drawRectangle (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
cornerX) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
cornerY) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
dim) (Integer -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Integer
dim)
mkDial WidgetRef
_ [(Maybe Value, WidgetRef)]
_ = String -> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a. HasCallStack => String -> a
error String
"Dials do not have children"

-- | 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 :: Constructor SindreX11M
mkLabel WidgetRef
wr [] = do
  FormatString
lbl <- String -> ConstructorM SindreX11M FormatString
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"label" ConstructorM SindreX11M FormatString
-> ConstructorM SindreX11M FormatString
-> ConstructorM SindreX11M FormatString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FormatString -> ConstructorM SindreX11M FormatString
forall (m :: * -> *) a. Monad m => a -> m a
return []
  VisualOpts
visual <- WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts WidgetRef
wr
  NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget SindreX11M
 -> ConstructorM SindreX11M (NewWidget SindreX11M))
-> NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ FormatString
-> Map String (Method FormatString SindreX11M)
-> [Field FormatString SindreX11M]
-> (Event -> ObjectM FormatString SindreX11M ())
-> ObjectM FormatString SindreX11M SpaceNeed
-> (Rectangle -> ObjectM FormatString SindreX11M [Rectangle])
-> NewWidget SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget FormatString
lbl Map String (Method FormatString SindreX11M)
forall k a. Map k a
M.empty
         [FieldDesc FormatString SindreX11M FormatString
-> Field FormatString SindreX11M
forall (im :: * -> *) v s.
(MonadFail im, Mold v) =>
FieldDesc s im v -> Field s im
field FieldDesc FormatString SindreX11M FormatString
label]
         (ObjectM FormatString SindreX11M ()
-> Event -> ObjectM FormatString SindreX11M ()
forall a b. a -> b -> a
const (ObjectM FormatString SindreX11M ()
 -> Event -> ObjectM FormatString SindreX11M ())
-> ObjectM FormatString SindreX11M ()
-> Event
-> ObjectM FormatString SindreX11M ()
forall a b. (a -> b) -> a -> b
$ () -> ObjectM FormatString SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (VisualOpts -> ObjectM FormatString SindreX11M SpaceNeed
forall (m :: (* -> *) -> * -> *).
(MonadState FormatString (m SindreX11M),
 MonadSindre SindreX11M m) =>
VisualOpts -> m SindreX11M SpaceNeed
composeI VisualOpts
visual) (VisualOpts
-> Rectangle -> ObjectM FormatString SindreX11M [Rectangle]
drawI VisualOpts
visual)
    where label :: FieldDesc FormatString SindreX11M FormatString
label = String
-> ObjectM FormatString SindreX11M FormatString
-> (FormatString -> ObjectM FormatString SindreX11M ())
-> FieldDesc FormatString SindreX11M FormatString
forall s (im :: * -> *) v.
String
-> ObjectM s im v -> (v -> ObjectM s im ()) -> FieldDesc s im v
ReadWriteField String
"label" ObjectM FormatString SindreX11M FormatString
getLabel FormatString -> ObjectM FormatString SindreX11M ()
forall s (m :: (* -> *) -> * -> *) (im :: * -> *).
(MonadState s (m im), MonadSindre im m) =>
s -> m im ()
setLabel
          setLabel :: s -> m im ()
setLabel s
v = s -> m im ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
v m im () -> m im () -> m im ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m im ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw
          getLabel :: ObjectM FormatString SindreX11M FormatString
getLabel = ObjectM FormatString SindreX11M FormatString
forall s (m :: * -> *). MonadState s m => m s
get
          composeI :: VisualOpts -> m SindreX11M SpaceNeed
composeI VisualOpts
visual = do
            FormatString
text <- m SindreX11M FormatString
forall s (m :: * -> *). MonadState s m => m s
get
            case FormatString
text of
              [] -> SpaceNeed -> m SindreX11M SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DimNeed
Exact Integer
0, Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
forall a. Integral a => a
padding Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Font -> Integer
forall a. Integral a => Font -> a
Xft.height (VisualOpts -> Font
font VisualOpts
visual))
              FormatString
_  -> do Rectangle
r <- SindreX11M Rectangle -> m SindreX11M Rectangle
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M Rectangle -> m SindreX11M Rectangle)
-> SindreX11M Rectangle -> m SindreX11M Rectangle
forall a b. (a -> b) -> a -> b
$ Font -> FormatString -> SindreX11M Rectangle
fmtSize (VisualOpts -> Font
font VisualOpts
visual) FormatString
text
                       SpaceNeed -> m SindreX11M SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectWidth Rectangle
r,
                               Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectHeight Rectangle
r)
          drawI :: VisualOpts
-> Rectangle -> ObjectM FormatString SindreX11M [Rectangle]
drawI VisualOpts
visual = VisualOpts
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM FormatString SindreX11M ())
-> Rectangle
-> ObjectM FormatString SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle
  -> Drawer -> Drawer -> ObjectM FormatString SindreX11M ())
 -> Rectangle -> ObjectM FormatString SindreX11M [Rectangle])
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM FormatString SindreX11M ())
-> Rectangle
-> ObjectM FormatString SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle
r Drawer
fg Drawer
_ ->
            SindreX11M () -> ObjectM FormatString SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> ObjectM FormatString SindreX11M ())
-> (FormatString -> SindreX11M ())
-> FormatString
-> ObjectM FormatString SindreX11M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Drawer -> Rectangle -> FormatString -> SindreX11M ()
drawFmt Drawer
fg Rectangle
r (FormatString -> ObjectM FormatString SindreX11M ())
-> ObjectM FormatString SindreX11M FormatString
-> ObjectM FormatString SindreX11M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ObjectM FormatString SindreX11M FormatString
forall s (m :: * -> *). MonadState s m => m s
get
mkLabel WidgetRef
_ [(Maybe Value, WidgetRef)]
_ = String -> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a. HasCallStack => String -> a
error String
"Labels do not have children"

-- | 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 :: Constructor SindreX11M
mkBlank WidgetRef
r [] = do
  VisualOpts
visual <- WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts WidgetRef
r
  NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget SindreX11M
 -> ConstructorM SindreX11M (NewWidget SindreX11M))
-> NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ ()
-> Map String (Method () SindreX11M)
-> [Field () SindreX11M]
-> (Event -> ObjectM () SindreX11M ())
-> ObjectM () SindreX11M SpaceNeed
-> (Rectangle -> ObjectM () SindreX11M [Rectangle])
-> NewWidget SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget () Map String (Method () SindreX11M)
forall k a. Map k a
M.empty [] (ObjectM () SindreX11M () -> Event -> ObjectM () SindreX11M ()
forall a b. a -> b -> a
const (ObjectM () SindreX11M () -> Event -> ObjectM () SindreX11M ())
-> ObjectM () SindreX11M () -> Event -> ObjectM () SindreX11M ()
forall a b. (a -> b) -> a -> b
$ () -> ObjectM () SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
           (SpaceNeed -> ObjectM () SindreX11M SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (DimNeed
Unlimited, DimNeed
Unlimited))
           (VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM () SindreX11M ())
-> Rectangle
-> ObjectM () SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle -> Drawer -> Drawer -> ObjectM () SindreX11M ())
 -> Rectangle -> ObjectM () SindreX11M [Rectangle])
-> (Rectangle -> Drawer -> Drawer -> ObjectM () SindreX11M ())
-> Rectangle
-> ObjectM () SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle
_ Drawer
_ Drawer
_ -> () -> ObjectM () SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
mkBlank WidgetRef
_ [(Maybe Value, WidgetRef)]
_ = String -> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a. HasCallStack => String -> a
error String
"Blanks do not have children"

data TextField = TextField { TextField -> (String, String)
fieldText :: (String, String) }

fieldValue :: TextField -> String
fieldValue :: TextField -> String
fieldValue = (String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
forall a. [a] -> [a] -> [a]
(++) ((String, String) -> String)
-> (TextField -> (String, String)) -> TextField -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> String
forall a. [a] -> [a]
reverse ((String, String) -> (String, String))
-> (TextField -> (String, String)) -> TextField -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextField -> (String, String)
fieldText

-- | 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 :: Constructor SindreX11M
mkTextField WidgetRef
r [] = do
  String
v <- String -> ConstructorM SindreX11M String
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"value" ConstructorM SindreX11M String
-> ConstructorM SindreX11M String -> ConstructorM SindreX11M String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ConstructorM SindreX11M String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
  VisualOpts
visual <- WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts WidgetRef
r
  NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget SindreX11M
 -> ConstructorM SindreX11M (NewWidget SindreX11M))
-> NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ TextField
-> Map String (Method TextField SindreX11M)
-> [Field TextField SindreX11M]
-> (Event -> ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M SpaceNeed
-> (Rectangle -> ObjectM TextField SindreX11M [Rectangle])
-> NewWidget SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget ((String, String) -> TextField
TextField (String
"",String
v)) Map String (Method TextField SindreX11M)
forall a. Map String a
methods [FieldDesc TextField SindreX11M Text -> Field TextField SindreX11M
forall (im :: * -> *) v s.
(MonadFail im, Mold v) =>
FieldDesc s im v -> Field s im
field FieldDesc TextField SindreX11M Text
value]
                     Event -> ObjectM TextField SindreX11M ()
recvEventI (VisualOpts -> ObjectM TextField SindreX11M SpaceNeed
forall (m :: (* -> *) -> * -> *).
(MonadState TextField (m SindreX11M), MonadSindre SindreX11M m) =>
VisualOpts -> m SindreX11M SpaceNeed
composeI VisualOpts
visual) (VisualOpts -> Rectangle -> ObjectM TextField SindreX11M [Rectangle]
drawI VisualOpts
visual)
    where methods :: Map String a
methods = [(String, a)] -> Map String a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList []
          value :: FieldDesc TextField SindreX11M Text
value   = String
-> ObjectM TextField SindreX11M Text
-> (Text -> ObjectM TextField SindreX11M ())
-> FieldDesc TextField SindreX11M Text
forall s (im :: * -> *) v.
String
-> ObjectM s im v -> (v -> ObjectM s im ()) -> FieldDesc s im v
ReadWriteField String
"value" ObjectM TextField SindreX11M Text
getValue Text -> ObjectM TextField SindreX11M ()
forall (m :: * -> *). MonadState TextField m => Text -> m ()
setValue
          getValue :: ObjectM TextField SindreX11M Text
getValue = String -> Text
T.pack (String -> Text)
-> ObjectM TextField SindreX11M String
-> ObjectM TextField SindreX11M Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextField -> String) -> ObjectM TextField SindreX11M String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TextField -> String
fieldValue
          setValue :: Text -> m ()
setValue Text
v =
            (TextField -> TextField) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TextField -> TextField) -> m ())
-> (TextField -> TextField) -> m ()
forall a b. (a -> b) -> a -> b
$ \TextField
s -> TextField
s { fieldText :: (String, String)
fieldText = (String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v, String
"") }
          recvEventI :: Event -> ObjectM TextField SindreX11M ()
recvEventI (KeyPress (Set KeyModifier -> [KeyModifier]
forall a. Set a -> [a]
S.toList -> [], CharKey Char
c)) =
            FieldDesc TextField SindreX11M Text
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField FieldDesc TextField SindreX11M Text
value (ObjectM TextField SindreX11M ()
 -> ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
              (TextField -> TextField) -> ObjectM TextField SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TextField -> TextField) -> ObjectM TextField SindreX11M ())
-> (TextField -> TextField) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \(TextField (String
bef, String
aft)) -> (String, String) -> TextField
TextField (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
bef, String
aft)
              ObjectM TextField SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw
          recvEventI (KeyPress Chord
k) =
            ObjectM TextField SindreX11M ()
-> (ObjectM TextField SindreX11M ()
    -> ObjectM TextField SindreX11M ())
-> Maybe (ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ObjectM TextField SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ObjectM TextField SindreX11M ()
forall (im :: * -> *) s. MonadBackend im => ObjectM s im ()
redraw ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>) (Maybe (ObjectM TextField SindreX11M ())
 -> ObjectM TextField SindreX11M ())
-> Maybe (ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Chord
-> Map Chord (ObjectM TextField SindreX11M ())
-> Maybe (ObjectM TextField SindreX11M ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Chord
k (FieldDesc TextField SindreX11M Text
-> Map Chord (ObjectM TextField SindreX11M ())
editorCommands FieldDesc TextField SindreX11M Text
value)
          recvEventI Event
_ = () -> ObjectM TextField SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          composeI :: VisualOpts -> m SindreX11M SpaceNeed
composeI VisualOpts
visual = do
            String
text  <- (TextField -> String) -> m SindreX11M String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TextField -> String
fieldValue
            (Int
w,Int
h) <- SindreX11M (Int, Int) -> m SindreX11M (Int, Int)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Int, Int) -> m SindreX11M (Int, Int))
-> SindreX11M (Int, Int) -> m SindreX11M (Int, Int)
forall a b. (a -> b) -> a -> b
$ Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
text
            SpaceNeed -> m SindreX11M SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DimNeed
Max (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Int
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
forall a. Integral a => a
padding Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2, Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Int
h Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
forall a. Integral a => a
padding Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2)
          drawI :: VisualOpts -> Rectangle -> ObjectM TextField SindreX11M [Rectangle]
drawI VisualOpts
visual = VisualOpts
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM TextField SindreX11M ())
-> Rectangle
-> ObjectM TextField SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle -> Drawer -> Drawer -> ObjectM TextField SindreX11M ())
 -> Rectangle -> ObjectM TextField SindreX11M [Rectangle])
-> (Rectangle
    -> Drawer -> Drawer -> ObjectM TextField SindreX11M ())
-> Rectangle
-> ObjectM TextField SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle{Integer
rectHeight :: Integer
rectWidth :: Integer
rectY :: Integer
rectX :: Integer
rectHeight :: Rectangle -> Integer
rectWidth :: Rectangle -> Integer
rectY :: Rectangle -> Integer
rectX :: Rectangle -> Integer
..} Drawer
d Drawer
_ -> do
            (String
bef,String
_)   <- (TextField -> (String, String))
-> ObjectM TextField SindreX11M (String, String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TextField -> (String, String)
fieldText
            String
text      <- (TextField -> String) -> ObjectM TextField SindreX11M String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TextField -> String
fieldValue
            (Int
befw, Int
_) <- SindreX11M (Int, Int) -> ObjectM TextField SindreX11M (Int, Int)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Int, Int) -> ObjectM TextField SindreX11M (Int, Int))
-> SindreX11M (Int, Int) -> ObjectM TextField SindreX11M (Int, Int)
forall a b. (a -> b) -> a -> b
$ Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
bef
            (Int
w, Int
h)    <- SindreX11M (Int, Int) -> ObjectM TextField SindreX11M (Int, Int)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Int, Int) -> ObjectM TextField SindreX11M (Int, Int))
-> SindreX11M (Int, Int) -> ObjectM TextField SindreX11M (Int, Int)
forall a b. (a -> b) -> a -> b
$ Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
text
            let width :: String -> SindreX11M Int
width = ((Int, Int) -> Int) -> SindreX11M (Int, Int) -> SindreX11M Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int, Int) -> Int
forall a b. (a, b) -> b
snd (SindreX11M (Int, Int) -> SindreX11M Int)
-> (String -> SindreX11M (Int, Int)) -> String -> SindreX11M Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual)
            String
text' <- if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectWidth then String -> ObjectM TextField SindreX11M String
forall (m :: * -> *) a. Monad m => a -> m a
return String
text
                     else do [String]
fits <- SindreX11M [String] -> ObjectM TextField SindreX11M [String]
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M [String] -> ObjectM TextField SindreX11M [String])
-> SindreX11M [String] -> ObjectM TextField SindreX11M [String]
forall a b. (a -> b) -> a -> b
$ (String -> SindreX11M Bool) -> [String] -> SindreX11M [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Int -> Bool) -> SindreX11M Int -> SindreX11M Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectWidth) (SindreX11M Int -> SindreX11M Bool)
-> (String -> SindreX11M Int) -> String -> SindreX11M Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SindreX11M Int
width)
                                          ([String] -> SindreX11M [String])
-> [String] -> SindreX11M [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. [a] -> [[a]]
tails (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
text
                             case [String]
fits of
                               []    -> String -> ObjectM TextField SindreX11M String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                               (String
t:[String]
_) -> String -> ObjectM TextField SindreX11M String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ObjectM TextField SindreX11M String)
-> String -> ObjectM TextField SindreX11M String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
t
            SindreX11M () -> ObjectM TextField SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> ObjectM TextField SindreX11M ())
-> SindreX11M () -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Color
-> Font -> Integer -> Integer -> Integer -> String -> SindreX11M ()
forall x y z.
(Integral x, Integral y, Integral z) =>
Color -> Font -> x -> y -> z -> String -> SindreX11M ()
drawText (Drawer -> Color
drawerFgColor Drawer
d) (Drawer -> Font
drawerFont Drawer
d)
                   (Integer
rectXInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
forall a. Integral a => a
padding) (Integer
rectYInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
forall a. Integral a => a
padding)
                   (Integer
rectHeight Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
forall a. Integral a => a
paddingInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
2) String
text'
            Bool
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
forall a. Integral a => a
paddingInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
befw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectWidth) (ObjectM TextField SindreX11M ()
 -> ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$
              IO () -> ObjectM TextField SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ObjectM TextField SindreX11M ())
-> IO () -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Drawer
-> CoreDrawer
     (Position -> Position -> Position -> Position -> IO ())
Drawer -> forall f. CoreDrawer f
fg Drawer
d Display
-> Drawable
-> GC
-> Position
-> Position
-> Position
-> Position
-> IO ()
drawLine (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectXPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Position
forall a. Integral a => a
paddingPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
befw) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectYPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Position
forall a. Integral a => a
padding)
                        (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectXPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Position
forall a. Integral a => a
paddingPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
befw) (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectYPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Position
forall a. Integral a => a
paddingPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
h)
mkTextField WidgetRef
_ [(Maybe Value, WidgetRef)]
_ = String -> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a. HasCallStack => String -> a
error String
"TextFields do not have children"

editorCommands :: X11Field TextField T.Text
               -> M.Map Chord (ObjectM TextField SindreX11M ())
editorCommands :: FieldDesc TextField SindreX11M Text
-> Map Chord (ObjectM TextField SindreX11M ())
editorCommands FieldDesc TextField SindreX11M Text
value = [(Chord, ObjectM TextField SindreX11M ())]
-> Map Chord (ObjectM TextField SindreX11M ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ ([KeyModifier] -> String -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [] String
"Right", (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveForward ((String -> (String, String)) -> ObjectM TextField SindreX11M ())
-> (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1)
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'f', (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveForward ((String -> (String, String)) -> ObjectM TextField SindreX11M ())
-> (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1)
  , ([KeyModifier] -> String -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [] String
"Left", (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveBackward ((String -> (String, String)) -> ObjectM TextField SindreX11M ())
-> (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1)
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'b', (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveBackward ((String -> (String, String)) -> ObjectM TextField SindreX11M ())
-> (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1)
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Meta] Char
'f', do (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveForward ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isAlphaNum)
                          (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveForward ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum))
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Meta] Char
'b', do (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveBackward ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isAlphaNum)
                          (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveBackward ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum))
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'a', (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveBackward (,String
""))
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'e', (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveForward (,String
""))
  , ([KeyModifier] -> String -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [] String
"Home", (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveBackward (String
"",))
  , ([KeyModifier] -> String -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [] String
"End", (String -> (String, String)) -> ObjectM TextField SindreX11M ()
forall (m :: * -> *).
MonadState TextField m =>
(String -> (String, String)) -> m ()
moveForward (String
"",))
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'w', (String -> String) -> ObjectM TextField SindreX11M ()
delBackward String -> String
word)
  , ([KeyModifier] -> String -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] String
"BackSpace", (String -> String) -> ObjectM TextField SindreX11M ()
delBackward String -> String
word)
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Meta] Char
'd', (String -> String) -> ObjectM TextField SindreX11M ()
delForward String -> String
word)
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'k', (String -> String) -> ObjectM TextField SindreX11M ()
delForward ((String -> String) -> ObjectM TextField SindreX11M ())
-> (String -> String) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall a b. a -> b -> a
const String
"")
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'u', (String -> String) -> ObjectM TextField SindreX11M ()
delBackward ((String -> String) -> ObjectM TextField SindreX11M ())
-> (String -> String) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall a b. a -> b -> a
const String
"")
  , ([KeyModifier] -> String -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [] String
"BackSpace", (String -> String) -> ObjectM TextField SindreX11M ()
delBackward ((String -> String) -> ObjectM TextField SindreX11M ())
-> (String -> String) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1)
  , ([KeyModifier] -> Char -> Chord
forall a. KeyLike a => [KeyModifier] -> a -> Chord
chord [KeyModifier
Control] Char
'd', (String -> String) -> ObjectM TextField SindreX11M ()
delForward ((String -> String) -> ObjectM TextField SindreX11M ())
-> (String -> String) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1)]
    where word :: String -> String
word = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isAlphaNum (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlphaNum)
          moveForward :: (String -> (String, String)) -> m ()
moveForward String -> (String, String)
f = (TextField -> TextField) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TextField -> TextField) -> m ())
-> (TextField -> TextField) -> m ()
forall a b. (a -> b) -> a -> b
$ \TextField
s ->
            let (String
bef, (String
pre, String
post)) = (String -> (String, String))
-> (String, String) -> (String, (String, String))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second String -> (String, String)
f ((String, String) -> (String, (String, String)))
-> (String, String) -> (String, (String, String))
forall a b. (a -> b) -> a -> b
$ TextField -> (String, String)
fieldText TextField
s
            in TextField
s { fieldText :: (String, String)
fieldText = (String -> String
forall a. [a] -> [a]
reverse String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bef, String
post) }
          moveBackward :: (String -> (String, String)) -> m ()
moveBackward String -> (String, String)
f = (TextField -> TextField) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TextField -> TextField) -> m ())
-> (TextField -> TextField) -> m ()
forall a b. (a -> b) -> a -> b
$ \TextField
s ->
            let ((String
pre, String
post), String
aft) = (String -> (String, String))
-> (String, String) -> ((String, String), String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> (String, String)
f ((String, String) -> ((String, String), String))
-> (String, String) -> ((String, String), String)
forall a b. (a -> b) -> a -> b
$ TextField -> (String, String)
fieldText TextField
s
            in TextField
s { fieldText :: (String, String)
fieldText = (String
post, String -> String
forall a. [a] -> [a]
reverse String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
aft) }
          delBackward :: (String -> String) -> ObjectM TextField SindreX11M ()
delBackward String -> String
delf = FieldDesc TextField SindreX11M Text
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField FieldDesc TextField SindreX11M Text
value (ObjectM TextField SindreX11M ()
 -> ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
            ObjectM TextField SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw
            (TextField -> TextField) -> ObjectM TextField SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TextField -> TextField) -> ObjectM TextField SindreX11M ())
-> (TextField -> TextField) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \TextField
s -> TextField
s { fieldText :: (String, String)
fieldText = (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> String
delf ((String, String) -> (String, String))
-> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ TextField -> (String, String)
fieldText TextField
s }
          delForward :: (String -> String) -> ObjectM TextField SindreX11M ()
delForward String -> String
delf = FieldDesc TextField SindreX11M Text
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField FieldDesc TextField SindreX11M Text
value (ObjectM TextField SindreX11M ()
 -> ObjectM TextField SindreX11M ())
-> ObjectM TextField SindreX11M ()
-> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
            ObjectM TextField SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw
            (TextField -> TextField) -> ObjectM TextField SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TextField -> TextField) -> ObjectM TextField SindreX11M ())
-> (TextField -> TextField) -> ObjectM TextField SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \TextField
s -> TextField
s { fieldText :: (String, String)
fieldText = (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second String -> String
delf ((String, String) -> (String, String))
-> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ TextField -> (String, String)
fieldText TextField
s }

data ListElem = ListElem { ListElem -> FormatString
showAs   :: FormatString
                         , ListElem -> Text
valueOf  :: T.Text
                         , ListElem -> Text
filterBy :: T.Text }
                deriving (Int -> ListElem -> String -> String
[ListElem] -> String -> String
ListElem -> String
(Int -> ListElem -> String -> String)
-> (ListElem -> String)
-> ([ListElem] -> String -> String)
-> Show ListElem
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ListElem] -> String -> String
$cshowList :: [ListElem] -> String -> String
show :: ListElem -> String
$cshow :: ListElem -> String
showsPrec :: Int -> ListElem -> String -> String
$cshowsPrec :: Int -> ListElem -> String -> String
Show, ListElem -> ListElem -> Bool
(ListElem -> ListElem -> Bool)
-> (ListElem -> ListElem -> Bool) -> Eq ListElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListElem -> ListElem -> Bool
$c/= :: ListElem -> ListElem -> Bool
== :: ListElem -> ListElem -> Bool
$c== :: ListElem -> ListElem -> Bool
Eq, Eq ListElem
Eq ListElem
-> (ListElem -> ListElem -> Ordering)
-> (ListElem -> ListElem -> Bool)
-> (ListElem -> ListElem -> Bool)
-> (ListElem -> ListElem -> Bool)
-> (ListElem -> ListElem -> Bool)
-> (ListElem -> ListElem -> ListElem)
-> (ListElem -> ListElem -> ListElem)
-> Ord ListElem
ListElem -> ListElem -> Bool
ListElem -> ListElem -> Ordering
ListElem -> ListElem -> ListElem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ListElem -> ListElem -> ListElem
$cmin :: ListElem -> ListElem -> ListElem
max :: ListElem -> ListElem -> ListElem
$cmax :: ListElem -> ListElem -> ListElem
>= :: ListElem -> ListElem -> Bool
$c>= :: ListElem -> ListElem -> Bool
> :: ListElem -> ListElem -> Bool
$c> :: ListElem -> ListElem -> Bool
<= :: ListElem -> ListElem -> Bool
$c<= :: ListElem -> ListElem -> Bool
< :: ListElem -> ListElem -> Bool
$c< :: ListElem -> ListElem -> Bool
compare :: ListElem -> ListElem -> Ordering
$ccompare :: ListElem -> ListElem -> Ordering
$cp1Ord :: Eq ListElem
Ord)

parseListElem :: T.Text -> ListElem
parseListElem :: Text -> ListElem
parseListElem Text
s = case PermParser Parser (Text, Text)
-> Text -> Either String (Text, Text)
forall a. PermParser Parser a -> Text -> Either String a
KV.parseKV PermParser Parser (Text, Text)
p Text
s of
                    Left  String
_       -> ListElem
el
                    Right (Text
v,Text
val) ->
                      case Text -> Either String FormatString
parseFormatString Text
v of
                        Left  String
_  -> ListElem
el
                        Right FormatString
s' -> FormatString -> Text -> Text -> ListElem
ListElem (FormatString -> FormatString
pad FormatString
s') Text
val (Text -> ListElem) -> Text -> ListElem
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toCaseFold (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FormatString -> Text
textContents FormatString
s'
  where p :: PermParser Parser (Text, Text)
p  = Maybe Text -> Text -> (Text, Text)
forall b. Maybe b -> b -> (b, b)
elf (Maybe Text -> Text -> (Text, Text))
-> (Maybe Text, Parser Text (Maybe Text))
-> PermParser Parser (Text -> (Text, Text))
forall a b (p :: * -> *). (a -> b) -> (a, p a) -> PermParser p b
<$?> (Maybe Text
forall a. Maybe a
Nothing, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text
KV.value (String -> Text
T.pack String
"show"))
                 PermParser Parser (Text -> (Text, Text))
-> Parser Text Text -> PermParser Parser (Text, Text)
forall (p :: * -> *) a b.
PermParser p (a -> b) -> p a -> PermParser p b
<||> Text -> Parser Text Text
KV.value (String -> Text
T.pack String
"value")
        elf :: Maybe b -> b -> (b, b)
elf Maybe b
s' b
v' = (b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
v' Maybe b
s', b
v')
        pad :: FormatString -> FormatString
pad FormatString
s' = Maybe Format -> FormatString
forall a. Maybe a -> [a]
maybeToList (String -> Format
Bg (String -> Format) -> Maybe String -> Maybe Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatString -> Maybe String
startBg FormatString
s')
                 FormatString -> FormatString -> FormatString
forall a. [a] -> [a] -> [a]
++ [Text -> Format
Text (Text -> Format) -> Text -> Format
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
" "] FormatString -> FormatString -> FormatString
forall a. [a] -> [a] -> [a]
++ FormatString
s' FormatString -> FormatString -> FormatString
forall a. [a] -> [a] -> [a]
++ [Text -> Format
Text (Text -> Format) -> Text -> Format
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
" "]
        el :: ListElem
el = FormatString -> Text -> Text -> ListElem
ListElem [Text -> Format
Text (Text -> Format) -> Text -> Format
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [String -> Text
T.pack String
" ", Text
s, String -> Text
T.pack String
" "]] Text
s (Text -> ListElem) -> Text -> ListElem
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toCaseFold Text
s

data NavList = NavList { NavList -> [ListElem]
linePrev :: [ListElem]
                       , NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents :: Maybe ([(ListElem, Rectangle)],
                                                (ListElem, Rectangle),
                                                [(ListElem, Rectangle)])
                       , NavList -> [ListElem]
lineNext :: [ListElem] }

type Movement m = ([ListElem] -> m ([(ListElem, Rectangle)], [ListElem]))
                -> NavList -> m (Maybe NavList)

contents :: NavList -> [ListElem]
contents :: NavList -> [ListElem]
contents NavList { lineContents :: NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents = Just ([(ListElem, Rectangle)]
pre, (ListElem, Rectangle)
cur, [(ListElem, Rectangle)]
aft) } =
  [ListElem] -> [ListElem]
forall a. [a] -> [a]
reverse (((ListElem, Rectangle) -> ListElem)
-> [(ListElem, Rectangle)] -> [ListElem]
forall a b. (a -> b) -> [a] -> [b]
map (ListElem, Rectangle) -> ListElem
forall a b. (a, b) -> a
fst [(ListElem, Rectangle)]
pre)[ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++[(ListElem, Rectangle) -> ListElem
forall a b. (a, b) -> a
fst (ListElem, Rectangle)
cur][ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++((ListElem, Rectangle) -> ListElem)
-> [(ListElem, Rectangle)] -> [ListElem]
forall a b. (a -> b) -> [a] -> [b]
map (ListElem, Rectangle) -> ListElem
forall a b. (a, b) -> a
fst [(ListElem, Rectangle)]
aft
contents NavList
_ = []

selected :: NavList -> Maybe ListElem
selected :: NavList -> Maybe ListElem
selected NavList { lineContents :: NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents = Just ([(ListElem, Rectangle)]
_, (ListElem
cur, Rectangle
_), [(ListElem, Rectangle)]
_) } = ListElem -> Maybe ListElem
forall a. a -> Maybe a
Just ListElem
cur
selected NavList
_ = Maybe ListElem
forall a. Maybe a
Nothing

listPrev :: Monad m => Movement m
listPrev :: Movement m
listPrev [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
_ l :: NavList
l@NavList { lineContents :: NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents = Just ((ListElem, Rectangle)
pre:[(ListElem, Rectangle)]
pre', (ListElem, Rectangle)
cur, [(ListElem, Rectangle)]
aft) } =
  Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just NavList
l { lineContents :: Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
lineContents = ([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ([(ListElem, Rectangle)]
pre', (ListElem, Rectangle)
pre, (ListElem, Rectangle)
cur(ListElem, Rectangle)
-> [(ListElem, Rectangle)] -> [(ListElem, Rectangle)]
forall a. a -> [a] -> [a]
:[(ListElem, Rectangle)]
aft) }
listPrev [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l = do
  ([(ListElem, Rectangle)]
conts', [ListElem]
rest) <- [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more (NavList -> [ListElem]
linePrev NavList
l)
  case [(ListElem, Rectangle)]
conts' of
    []   -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NavList
forall a. Maybe a
Nothing
    (ListElem, Rectangle)
x:[(ListElem, Rectangle)]
xs -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just (NavList -> Maybe NavList) -> NavList -> Maybe NavList
forall a b. (a -> b) -> a -> b
$ [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList
              [ListElem]
rest (([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ([(ListElem, Rectangle)]
xs, (ListElem, Rectangle)
x, [])) (NavList -> [ListElem]
contents NavList
l[ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++NavList -> [ListElem]
lineNext NavList
l)

listNext :: Monad m => Movement m
listNext :: Movement m
listNext [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
_ l :: NavList
l@NavList { lineContents :: NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents = Just ([(ListElem, Rectangle)]
pre, (ListElem, Rectangle)
cur, (ListElem, Rectangle)
aft:[(ListElem, Rectangle)]
aft') } =
  Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just NavList
l { lineContents :: Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
lineContents = ([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ((ListElem, Rectangle)
cur(ListElem, Rectangle)
-> [(ListElem, Rectangle)] -> [(ListElem, Rectangle)]
forall a. a -> [a] -> [a]
:[(ListElem, Rectangle)]
pre, (ListElem, Rectangle)
aft, [(ListElem, Rectangle)]
aft') }
listNext [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l = do
  ([(ListElem, Rectangle)]
conts', [ListElem]
rest) <- [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more ([ListElem] -> m ([(ListElem, Rectangle)], [ListElem]))
-> [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
forall a b. (a -> b) -> a -> b
$ NavList -> [ListElem]
lineNext NavList
l
  case [(ListElem, Rectangle)]
conts' of
    [] -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NavList
forall a. Maybe a
Nothing
    (ListElem, Rectangle)
x:[(ListElem, Rectangle)]
xs -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just (NavList -> Maybe NavList) -> NavList -> Maybe NavList
forall a b. (a -> b) -> a -> b
$ [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList
              ([ListElem] -> [ListElem]
forall a. [a] -> [a]
reverse (NavList -> [ListElem]
contents NavList
l)[ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++NavList -> [ListElem]
linePrev NavList
l) (([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ([], (ListElem, Rectangle)
x, [(ListElem, Rectangle)]
xs)) [ListElem]
rest

listLast :: Monad m => Movement m
listLast :: Movement m
listLast [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l = do
  ([(ListElem, Rectangle)]
line, [ListElem]
rest) <- [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more ([ListElem] -> m ([(ListElem, Rectangle)], [ListElem]))
-> [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
forall a b. (a -> b) -> a -> b
$ [ListElem] -> [ListElem]
forall a. [a] -> [a]
reverse (NavList -> [ListElem]
contents NavList
l [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ NavList -> [ListElem]
lineNext NavList
l) [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ NavList -> [ListElem]
linePrev NavList
l
  case [(ListElem, Rectangle)]
line of [] -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NavList
forall a. Maybe a
Nothing
               (ListElem, Rectangle)
x:[(ListElem, Rectangle)]
xs -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just (NavList -> Maybe NavList) -> NavList -> Maybe NavList
forall a b. (a -> b) -> a -> b
$ [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList [ListElem]
rest (([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ([(ListElem, Rectangle)]
xs, (ListElem, Rectangle)
x, [])) []

listFirst :: Monad m => Movement m
listFirst :: Movement m
listFirst [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l = do
  ([(ListElem, Rectangle)]
line, [ListElem]
rest) <- [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more ([ListElem] -> m ([(ListElem, Rectangle)], [ListElem]))
-> [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
forall a b. (a -> b) -> a -> b
$ [ListElem] -> [ListElem]
forall a. [a] -> [a]
reverse (NavList -> [ListElem]
linePrev NavList
l) [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ NavList -> [ListElem]
contents NavList
l [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ NavList -> [ListElem]
lineNext NavList
l
  case [(ListElem, Rectangle)]
line of [] -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NavList
forall a. Maybe a
Nothing
               (ListElem, Rectangle)
x:[(ListElem, Rectangle)]
xs -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just (NavList -> Maybe NavList) -> NavList -> Maybe NavList
forall a b. (a -> b) -> a -> b
$ [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList [] (([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ([], (ListElem, Rectangle)
x, [(ListElem, Rectangle)]
xs)) [ListElem]
rest

moveUntil :: (MonadIO m, Monad m) => Movement m -> (NavList -> Bool) -> Movement m
moveUntil :: Movement m -> (NavList -> Bool) -> Movement m
moveUntil Movement m
mov NavList -> Bool
p [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l | NavList -> Bool
p NavList
l = Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NavList -> m (Maybe NavList))
-> Maybe NavList -> m (Maybe NavList)
forall a b. (a -> b) -> a -> b
$ NavList -> Maybe NavList
forall a. a -> Maybe a
Just NavList
l
                       | Bool
otherwise = do
  Maybe NavList
l' <- Movement m
mov [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l
  case Maybe NavList
l' of Maybe NavList
Nothing  -> Maybe NavList -> m (Maybe NavList)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NavList
forall a. Maybe a
Nothing
             Just NavList
l'' -> Movement m -> (NavList -> Bool) -> Movement m
forall (m :: * -> *).
(MonadIO m, Monad m) =>
Movement m -> (NavList -> Bool) -> Movement m
moveUntil Movement m
mov NavList -> Bool
p [ListElem] -> m ([(ListElem, Rectangle)], [ListElem])
more NavList
l''

lineElems :: (Rectangle -> Integer) -> Rectangle -> [ListElem]
          -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
lineElems :: (Rectangle -> Integer)
-> Rectangle
-> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
lineElems Rectangle -> Integer
rdf Rectangle
r [ListElem]
l = [ListElem]
-> Integer
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
elemLine [ListElem]
l (Integer
 -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem]))
-> Integer
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rdf Rectangle
r
  where elemLine :: [ListElem]
-> Integer
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
elemLine [] Integer
_ = ([(ListElem, Rectangle)], [ListElem])
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
        elemLine es :: [ListElem]
es@(ListElem
e:[ListElem]
es') Integer
room = do
          Rectangle
r' <- ObjectM List SindreX11M (ObjectM List SindreX11M Rectangle)
-> ObjectM List SindreX11M Rectangle
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ObjectM List SindreX11M (ObjectM List SindreX11M Rectangle)
 -> ObjectM List SindreX11M Rectangle)
-> ObjectM List SindreX11M (ObjectM List SindreX11M Rectangle)
-> ObjectM List SindreX11M Rectangle
forall a b. (a -> b) -> a -> b
$ (List -> ListElem -> ObjectM List SindreX11M Rectangle)
-> ObjectM
     List SindreX11M (ListElem -> ObjectM List SindreX11M Rectangle)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> ListElem -> ObjectM List SindreX11M Rectangle
listElemSize ObjectM
  List SindreX11M (ListElem -> ObjectM List SindreX11M Rectangle)
-> ObjectM List SindreX11M ListElem
-> ObjectM List SindreX11M (ObjectM List SindreX11M Rectangle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ListElem -> ObjectM List SindreX11M ListElem
forall (f :: * -> *) a. Applicative f => a -> f a
pure ListElem
e
          if Integer
room Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Rectangle -> Integer
rdf Rectangle
r' then do ([(ListElem, Rectangle)]
es'', [ListElem]
rest) <- [ListElem]
-> Integer
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
elemLine [ListElem]
es' (Integer
 -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem]))
-> Integer
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
forall a b. (a -> b) -> a -> b
$ Integer
roomInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Rectangle -> Integer
rdf Rectangle
r'
                                    ([(ListElem, Rectangle)], [ListElem])
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
forall (m :: * -> *) a. Monad m => a -> m a
return ((ListElem
e,Rectangle
r')(ListElem, Rectangle)
-> [(ListElem, Rectangle)] -> [(ListElem, Rectangle)]
forall a. a -> [a] -> [a]
:[(ListElem, Rectangle)]
es'', [ListElem]
rest)
                       else ([(ListElem, Rectangle)], [ListElem])
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [ListElem]
es)

fromElems :: ([(ListElem, Rectangle)], [ListElem]) -> NavList
fromElems :: ([(ListElem, Rectangle)], [ListElem]) -> NavList
fromElems ([], [ListElem]
rest) = [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList [] Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
forall a. Maybe a
Nothing [ListElem]
rest
fromElems ((ListElem, Rectangle)
x:[(ListElem, Rectangle)]
xs, [ListElem]
rest) = [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList [] (([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a. a -> Maybe a
Just ([], (ListElem, Rectangle)
x, [(ListElem, Rectangle)]
xs)) [ListElem]
rest

data List = List { List -> [ListElem]
listElems :: [ListElem]
                 , List -> Text
listFilter :: T.Text
                 , List -> NavList
listLine :: NavList
                 , List -> ListElem -> ObjectM List SindreX11M Rectangle
listElemSize :: ListElem -> ObjectM List SindreX11M Rectangle
                 , List -> Text -> [ListElem] -> [ListElem]
listFilterF :: T.Text -> [ListElem] -> [ListElem]
                 , List -> Rectangle
listSize :: Rectangle
                 , List -> Rectangle -> Integer
listDim :: Rectangle -> Integer
                 }

listFiltered :: List -> [ListElem]
listFiltered :: List -> [ListElem]
listFiltered List { listLine :: List -> NavList
listLine = NavList
l } =
  [ListElem] -> [ListElem]
forall a. [a] -> [a]
reverse (NavList -> [ListElem]
linePrev NavList
l) [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ NavList -> [ListElem]
contents NavList
l [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ NavList -> [ListElem]
lineNext NavList
l

selection :: List -> Maybe T.Text
selection :: List -> Maybe Text
selection List
l = (([(ListElem, Rectangle)], (ListElem, Rectangle),
  [(ListElem, Rectangle)])
 -> Text)
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> Maybe Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([(ListElem, Rectangle)], (ListElem, Rectangle),
 [(ListElem, Rectangle)])
-> Text
forall a b c. (a, (ListElem, b), c) -> Text
f (Maybe
   ([(ListElem, Rectangle)], (ListElem, Rectangle),
    [(ListElem, Rectangle)])
 -> Maybe Text)
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> Maybe Text
forall a b. (a -> b) -> a -> b
$ NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents (NavList
 -> Maybe
      ([(ListElem, Rectangle)], (ListElem, Rectangle),
       [(ListElem, Rectangle)]))
-> NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall a b. (a -> b) -> a -> b
$ List -> NavList
listLine List
l
  where f :: (a, (ListElem, b), c) -> Text
f (a
_,(ListElem
c,b
_),c
_) = ListElem -> Text
valueOf ListElem
c

refilter :: T.Text -> [ListElem] -> [ListElem]
refilter :: Text -> [ListElem] -> [ListElem]
refilter Text
f = (ListElem -> Text) -> Text -> [ListElem] -> [ListElem]
forall a. (a -> Text) -> Text -> [a] -> [a]
sortMatches ListElem -> Text
filterBy (Text -> Text
T.toCaseFold Text
f)

methInsert :: X11Field List (Maybe T.Text)
           -> T.Text -> ObjectM List SindreX11M ()
methInsert :: X11Field List (Maybe Text) -> Text -> ObjectM List SindreX11M ()
methInsert X11Field List (Maybe Text)
sel Text
vs = X11Field List (Maybe Text)
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField X11Field List (Maybe Text)
sel (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
  List
s <- ObjectM List SindreX11M List
forall s (m :: * -> *). MonadState s m => m s
get
  let v :: [ListElem]
v    = List -> Text -> [ListElem] -> [ListElem]
listFilterF List
s (List -> Text
listFilter List
s) ([ListElem] -> [ListElem]) -> [ListElem] -> [ListElem]
forall a b. (a -> b) -> a -> b
$ List -> [ListElem]
listFiltered List
s [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ [ListElem]
elems
      p :: NavList -> Bool
p NavList
l  = NavList -> Maybe ListElem
selected NavList
l Maybe ListElem -> Maybe ListElem -> Bool
forall a. Eq a => a -> a -> Bool
== NavList -> Maybe ListElem
selected (List -> NavList
listLine List
s)
      more :: [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
more = (Rectangle -> Integer)
-> Rectangle
-> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
lineElems (List -> Rectangle -> Integer
listDim List
s) (List -> Rectangle
listSize List
s)
  NavList
line  <- ([(ListElem, Rectangle)], [ListElem]) -> NavList
fromElems (([(ListElem, Rectangle)], [ListElem]) -> NavList)
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
-> ObjectM List SindreX11M NavList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
more [ListElem]
v
  Maybe NavList
line' <- Movement (ObjectM List SindreX11M)
-> (NavList -> Bool) -> Movement (ObjectM List SindreX11M)
forall (m :: * -> *).
(MonadIO m, Monad m) =>
Movement m -> (NavList -> Bool) -> Movement m
moveUntil Movement (ObjectM List SindreX11M)
forall (m :: * -> *). Monad m => Movement m
listNext NavList -> Bool
p [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
more NavList
line
  ObjectM List SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw ObjectM List SindreX11M ()
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> List -> ObjectM List SindreX11M ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put List
s { listElems :: [ListElem]
listElems = List -> [ListElem]
listElems List
s [ListElem] -> [ListElem] -> [ListElem]
forall a. [a] -> [a] -> [a]
++ [ListElem]
elems
                      , listLine :: NavList
listLine = NavList -> Maybe NavList -> NavList
forall a. a -> Maybe a -> a
fromMaybe NavList
line Maybe NavList
line' }
   where elems :: [ListElem]
elems = (Text -> ListElem) -> [Text] -> [ListElem]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ListElem
parseListElem ([Text] -> [ListElem]) -> [Text] -> [ListElem]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
vs

methClear :: X11Field List (Maybe T.Text)
          -> ObjectM List SindreX11M ()
methClear :: X11Field List (Maybe Text) -> ObjectM List SindreX11M ()
methClear X11Field List (Maybe Text)
sel = X11Field List (Maybe Text)
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField X11Field List (Maybe Text)
sel (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
  (List -> List) -> ObjectM List SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((List -> List) -> ObjectM List SindreX11M ())
-> (List -> List) -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \List
s -> List
s { listElems :: [ListElem]
listElems = [] , listLine :: NavList
listLine = [ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList [] Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
forall a. Maybe a
Nothing [] }
  ObjectM List SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw

methFilter :: X11Field List (Maybe T.Text) -> String
           -> ObjectM List SindreX11M ()
methFilter :: X11Field List (Maybe Text) -> String -> ObjectM List SindreX11M ()
methFilter X11Field List (Maybe Text)
sel String
f =
  X11Field List (Maybe Text)
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField X11Field List (Maybe Text)
sel (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
    List
s <- ObjectM List SindreX11M List
forall s (m :: * -> *). MonadState s m => m s
get
    let v :: [ListElem]
v = List -> Text -> [ListElem] -> [ListElem]
listFilterF List
s Text
f' ([ListElem] -> [ListElem]) -> [ListElem] -> [ListElem]
forall a b. (a -> b) -> a -> b
$ if List -> Text
listFilter List
s Text -> Text -> Bool
`T.isPrefixOf` Text
f'
                               then List -> [ListElem]
listFiltered List
s
                               else List -> [ListElem]
listElems List
s
    NavList
line <- ([(ListElem, Rectangle)], [ListElem]) -> NavList
fromElems (([(ListElem, Rectangle)], [ListElem]) -> NavList)
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
-> ObjectM List SindreX11M NavList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rectangle -> Integer)
-> Rectangle
-> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
lineElems (List -> Rectangle -> Integer
listDim List
s) (List -> Rectangle
listSize List
s) [ListElem]
v
    ObjectM List SindreX11M ()
forall (im :: * -> *) s. MonadBackend im => ObjectM s im ()
redraw ObjectM List SindreX11M ()
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> List -> ObjectM List SindreX11M ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put List
s { listFilter :: Text
listFilter = Text
f', listLine :: NavList
listLine = NavList
line }
  where f' :: Text
f' = String -> Text
T.pack String
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 :: X11Field List (Maybe Text)
-> Movement (ObjectM List SindreX11M)
-> ObjectM List SindreX11M Bool
methMove X11Field List (Maybe Text)
sel Movement (ObjectM List SindreX11M)
f = do
  Rectangle -> Integer
dimf <- (List -> Rectangle -> Integer)
-> ObjectM List SindreX11M (Rectangle -> Integer)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> Rectangle -> Integer
listDim
  Rectangle
rect <- (List -> Rectangle) -> ObjectM List SindreX11M Rectangle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> Rectangle
listSize
  Maybe NavList
l <- Movement (ObjectM List SindreX11M)
f ((Rectangle -> Integer)
-> Rectangle
-> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
lineElems Rectangle -> Integer
dimf Rectangle
rect) (NavList -> ObjectM List SindreX11M (Maybe NavList))
-> ObjectM List SindreX11M NavList
-> ObjectM List SindreX11M (Maybe NavList)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (List -> NavList) -> ObjectM List SindreX11M NavList
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> NavList
listLine
  case Maybe NavList
l of Maybe NavList
Nothing -> Bool -> ObjectM List SindreX11M Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Just NavList
l' -> do
              X11Field List (Maybe Text)
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) v s a.
(MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField X11Field List (Maybe Text)
sel (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
                ObjectM List SindreX11M ()
forall (im :: * -> *) s. MonadBackend im => ObjectM s im ()
redraw
                (List -> List) -> ObjectM List SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((List -> List) -> ObjectM List SindreX11M ())
-> (List -> List) -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \List
s -> List
s { listLine :: NavList
listLine = NavList
l' }
              Bool -> ObjectM List SindreX11M Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

mkList :: (VisualOpts -> ObjectM List SindreX11M SpaceNeed)
       -> (VisualOpts -> Rectangle -> ObjectM List SindreX11M SpaceUse)
       -> (Rectangle -> Integer)
       -> (VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle)
       -> Constructor SindreX11M
mkList :: (VisualOpts -> ObjectM List SindreX11M SpaceNeed)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle])
-> (Rectangle -> Integer)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle)
-> Constructor SindreX11M
mkList VisualOpts -> ObjectM List SindreX11M SpaceNeed
cf VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
df Rectangle -> Integer
dim VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle
uf WidgetRef
wr [] = do
  VisualOpts
visual <- WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts WidgetRef
wr
  NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget SindreX11M
 -> ConstructorM SindreX11M (NewWidget SindreX11M))
-> NewWidget SindreX11M
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ List
-> Map String (Method List SindreX11M)
-> [Field List SindreX11M]
-> (Event -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M SpaceNeed
-> (Rectangle -> ObjectM List SindreX11M [Rectangle])
-> NewWidget SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget ([ListElem]
-> Text
-> NavList
-> (ListElem -> ObjectM List SindreX11M Rectangle)
-> (Text -> [ListElem] -> [ListElem])
-> Rectangle
-> (Rectangle -> Integer)
-> List
List [] Text
T.empty ([ListElem]
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
-> [ListElem]
-> NavList
NavList [] Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
forall a. Maybe a
Nothing [])
                     (VisualOpts -> ListElem -> ObjectM List SindreX11M Rectangle
forall (m :: (* -> *) -> * -> *).
MonadSindre SindreX11M m =>
VisualOpts -> ListElem -> m SindreX11M Rectangle
elemSize VisualOpts
visual) Text -> [ListElem] -> [ListElem]
refilter Rectangle
forall a. Monoid a => a
mempty Rectangle -> Integer
dim)
                     Map String (Method List SindreX11M)
methods [X11Field List (Maybe Text) -> Field List SindreX11M
forall (im :: * -> *) v s.
(MonadFail im, Mold v) =>
FieldDesc s im v -> Field s im
field X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel, FieldDesc List SindreX11M Value -> Field List SindreX11M
forall (im :: * -> *) v s.
(MonadFail im, Mold v) =>
FieldDesc s im v -> Field s im
field FieldDesc List SindreX11M Value
forall (im :: * -> *). FieldDesc List im Value
elements]
                     (ObjectM List SindreX11M () -> Event -> ObjectM List SindreX11M ()
forall a b. a -> b -> a
const (ObjectM List SindreX11M () -> Event -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M ()
-> Event
-> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ () -> ObjectM List SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (VisualOpts -> ObjectM List SindreX11M SpaceNeed
composeI VisualOpts
visual) (VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
drawI VisualOpts
visual)
    where methods :: Map String (Method List SindreX11M)
methods = [(String, Method List SindreX11M)]
-> Map String (Method List SindreX11M)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (String
"insert", (Text -> ObjectM List SindreX11M ()) -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function ((Text -> ObjectM List SindreX11M ()) -> Method List SindreX11M)
-> (Text -> ObjectM List SindreX11M ()) -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text) -> Text -> ObjectM List SindreX11M ()
methInsert X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel)
                               , (String
"clear", ObjectM List SindreX11M () -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function (ObjectM List SindreX11M () -> Method List SindreX11M)
-> ObjectM List SindreX11M () -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text) -> ObjectM List SindreX11M ()
methClear X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel)
                               , (String
"filter", (String -> ObjectM List SindreX11M ()) -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function ((String -> ObjectM List SindreX11M ()) -> Method List SindreX11M)
-> (String -> ObjectM List SindreX11M ()) -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text) -> String -> ObjectM List SindreX11M ()
methFilter X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel)
                               , (String
"next", ObjectM List SindreX11M Bool -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function (ObjectM List SindreX11M Bool -> Method List SindreX11M)
-> ObjectM List SindreX11M Bool -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text)
-> Movement (ObjectM List SindreX11M)
-> ObjectM List SindreX11M Bool
methMove X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel Movement (ObjectM List SindreX11M)
forall (m :: * -> *). Monad m => Movement m
listNext)
                               , (String
"prev", ObjectM List SindreX11M Bool -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function (ObjectM List SindreX11M Bool -> Method List SindreX11M)
-> ObjectM List SindreX11M Bool -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text)
-> Movement (ObjectM List SindreX11M)
-> ObjectM List SindreX11M Bool
methMove X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel Movement (ObjectM List SindreX11M)
forall (m :: * -> *). Monad m => Movement m
listPrev)
                               , (String
"first", ObjectM List SindreX11M Bool -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function (ObjectM List SindreX11M Bool -> Method List SindreX11M)
-> ObjectM List SindreX11M Bool -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text)
-> Movement (ObjectM List SindreX11M)
-> ObjectM List SindreX11M Bool
methMove X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel Movement (ObjectM List SindreX11M)
forall (m :: * -> *). Monad m => Movement m
listFirst)
                               , (String
"last", ObjectM List SindreX11M Bool -> Method List SindreX11M
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function (ObjectM List SindreX11M Bool -> Method List SindreX11M)
-> ObjectM List SindreX11M Bool -> Method List SindreX11M
forall a b. (a -> b) -> a -> b
$ X11Field List (Maybe Text)
-> Movement (ObjectM List SindreX11M)
-> ObjectM List SindreX11M Bool
methMove X11Field List (Maybe Text)
forall (im :: * -> *). FieldDesc List im (Maybe Text)
sel Movement (ObjectM List SindreX11M)
forall (m :: * -> *). Monad m => Movement m
listLast)]
          sel :: FieldDesc List im (Maybe Text)
sel = String
-> ObjectM List im (Maybe Text) -> FieldDesc List im (Maybe Text)
forall s (im :: * -> *) v.
String -> ObjectM s im v -> FieldDesc s im v
ReadOnlyField String
"selected" (ObjectM List im (Maybe Text) -> FieldDesc List im (Maybe Text))
-> ObjectM List im (Maybe Text) -> FieldDesc List im (Maybe Text)
forall a b. (a -> b) -> a -> b
$ (List -> Maybe Text) -> ObjectM List im (Maybe Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> Maybe Text
selection
          elements :: FieldDesc List im Value
elements = String -> ObjectM List im Value -> FieldDesc List im Value
forall s (im :: * -> *) v.
String -> ObjectM s im v -> FieldDesc s im v
ReadOnlyField String
"elements" (ObjectM List im Value -> FieldDesc List im Value)
-> ObjectM List im Value -> FieldDesc List im Value
forall a b. (a -> b) -> a -> b
$ Map Value Value -> Value
Dict (Map Value Value -> Value)
-> ([(Value, Value)] -> Map Value Value)
-> [(Value, Value)]
-> Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Value, Value)] -> Map Value Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Value, Value)] -> Value)
-> ([Value] -> [(Value, Value)]) -> [Value] -> Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                     [Value] -> [Value] -> [(Value, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Double -> Value) -> [Double] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Value
Number [Double
1..]) ([Value] -> Value)
-> ([ListElem] -> [Value]) -> [ListElem] -> Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ListElem -> Value) -> [ListElem] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (FormatString -> Value
forall a. Mold a => a -> Value
unmold (FormatString -> Value)
-> (ListElem -> FormatString) -> ListElem -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListElem -> FormatString
showAs) ([ListElem] -> Value)
-> ObjectM List im [ListElem] -> ObjectM List im Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                     (List -> [ListElem]) -> ObjectM List im [ListElem]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> [ListElem]
listFiltered
          composeI :: VisualOpts -> ObjectM List SindreX11M SpaceNeed
composeI = VisualOpts -> ObjectM List SindreX11M SpaceNeed
cf
          drawI :: VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
drawI VisualOpts
visual Rectangle
r = do
            List
l <- ObjectM List SindreX11M List
forall s (m :: * -> *). MonadState s m => m s
get
            Rectangle
r' <- VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle
uf VisualOpts
visual Rectangle
r
            Bool -> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rectangle
r' Rectangle -> Rectangle -> Bool
forall a. Eq a => a -> a -> Bool
/= List -> Rectangle
listSize List
l) (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
              ([(ListElem, Rectangle)], [ListElem])
line <- (Rectangle -> Integer)
-> Rectangle
-> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
lineElems (List -> Rectangle -> Integer
listDim List
l) Rectangle
r' ([ListElem]
 -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem]))
-> [ListElem]
-> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])
forall a b. (a -> b) -> a -> b
$ List -> [ListElem]
listFiltered List
l
              (List -> List) -> ObjectM List SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((List -> List) -> ObjectM List SindreX11M ())
-> (List -> List) -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \List
s -> List
s { listSize :: Rectangle
listSize = Rectangle
r', listLine :: NavList
listLine = ([(ListElem, Rectangle)], [ListElem]) -> NavList
fromElems ([(ListElem, Rectangle)], [ListElem])
line }
            VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
df VisualOpts
visual Rectangle
r
          elemSize :: VisualOpts -> ListElem -> m SindreX11M Rectangle
elemSize VisualOpts
visual = SindreX11M Rectangle -> m SindreX11M Rectangle
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M Rectangle -> m SindreX11M Rectangle)
-> (ListElem -> SindreX11M Rectangle)
-> ListElem
-> m SindreX11M Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> FormatString -> SindreX11M Rectangle
fmtSize (VisualOpts -> Font
font VisualOpts
visual) (FormatString -> SindreX11M Rectangle)
-> (ListElem -> FormatString) -> ListElem -> SindreX11M Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListElem -> FormatString
showAs

mkList VisualOpts -> ObjectM List SindreX11M SpaceNeed
_ VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
_ Rectangle -> Integer
_ VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle
_ WidgetRef
_ [(Maybe Value, WidgetRef)]
_ = String -> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a. HasCallStack => String -> a
error String
"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 :: Constructor SindreX11M
mkHList = (VisualOpts -> ObjectM List SindreX11M SpaceNeed)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle])
-> (Rectangle -> Integer)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle)
-> Constructor SindreX11M
mkList VisualOpts -> ObjectM List SindreX11M SpaceNeed
composeHoriz VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
drawHoriz Rectangle -> Integer
rectWidth VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle
forall (m :: (* -> *) -> * -> *).
MonadSindre SindreX11M m =>
VisualOpts -> Rectangle -> m SindreX11M Rectangle
usable
  where composeHoriz :: VisualOpts -> ObjectM List SindreX11M SpaceNeed
composeHoriz = SpaceNeed -> ObjectM List SindreX11M SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (SpaceNeed -> ObjectM List SindreX11M SpaceNeed)
-> (VisualOpts -> SpaceNeed)
-> VisualOpts
-> ObjectM List SindreX11M SpaceNeed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DimNeed
Unlimited,) (DimNeed -> SpaceNeed)
-> (VisualOpts -> DimNeed) -> VisualOpts -> SpaceNeed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DimNeed
Exact (Integer -> DimNeed)
-> (VisualOpts -> Integer) -> VisualOpts -> DimNeed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> Integer
forall a. Integral a => Font -> a
Xft.height (Font -> Integer) -> (VisualOpts -> Font) -> VisualOpts -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VisualOpts -> Font
font

        prestr :: String
prestr = String
"< "
        aftstr :: String
aftstr = String
"> "

        usable :: VisualOpts -> Rectangle -> m SindreX11M Rectangle
usable VisualOpts
visual Rectangle
r = do
          (Int
w1, Int
_) <- SindreX11M (Int, Int) -> m SindreX11M (Int, Int)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Int, Int) -> m SindreX11M (Int, Int))
-> SindreX11M (Int, Int) -> m SindreX11M (Int, Int)
forall a b. (a -> b) -> a -> b
$ Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
prestr
          (Int
w2, Int
_) <- SindreX11M (Int, Int) -> m SindreX11M (Int, Int)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Int, Int) -> m SindreX11M (Int, Int))
-> SindreX11M (Int, Int) -> m SindreX11M (Int, Int)
forall a b. (a -> b) -> a -> b
$ Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
aftstr
          Rectangle -> m SindreX11M Rectangle
forall (m :: * -> *) a. Monad m => a -> m a
return Rectangle
r { rectWidth :: Integer
rectWidth = Rectangle -> Integer
rectWidth Rectangle
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Int
w1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi Int
w2 }

        drawHoriz :: VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
drawHoriz VisualOpts
visual = VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM List SindreX11M ())
-> Rectangle
-> ObjectM List SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle -> Drawer -> Drawer -> ObjectM List SindreX11M ())
 -> Rectangle -> ObjectM List SindreX11M [Rectangle])
-> (Rectangle -> Drawer -> Drawer -> ObjectM List SindreX11M ())
-> Rectangle
-> ObjectM List SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle
r Drawer
d Drawer
fd -> do
          (Int
prestrw,Int
_) <- SindreX11M (Int, Int) -> ObjectM List SindreX11M (Int, Int)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M (Int, Int) -> ObjectM List SindreX11M (Int, Int))
-> SindreX11M (Int, Int) -> ObjectM List SindreX11M (Int, Int)
forall a b. (a -> b) -> a -> b
$ Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
prestr
          let (Int
x,Integer
y,Int
w,Integer
h) = ( Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectX Rectangle
r, Rectangle -> Integer
rectY Rectangle
r
                          , Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Integer
rectWidth Rectangle
r, Rectangle -> Integer
rectHeight Rectangle
r)
              drawElem :: Drawer
-> Integer
-> (ListElem, Rectangle)
-> ObjectM List SindreX11M Integer
drawElem Drawer
d' Integer
x' (ListElem
e,Rectangle
r') = SindreX11M Integer -> ObjectM List SindreX11M Integer
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M Integer -> ObjectM List SindreX11M Integer)
-> SindreX11M Integer -> ObjectM List SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ do
                Drawer -> Rectangle -> FormatString -> SindreX11M ()
drawFmt Drawer
d' (Rectangle
r' { rectX :: Integer
rectX = Integer
x', rectY :: Integer
rectY = Rectangle -> Integer
rectY Rectangle
r }) (FormatString -> SindreX11M ()) -> FormatString -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ ListElem -> FormatString
showAs ListElem
e
                Integer -> SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> SindreX11M Integer) -> Integer -> SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ Integer
x'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Rectangle -> Integer
rectWidth Rectangle
r'
          NavList
line <- (List -> NavList) -> ObjectM List SindreX11M NavList
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets List -> NavList
listLine
          case NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents NavList
line of
            Just ([(ListElem, Rectangle)]
pre, (ListElem, Rectangle)
cur, [(ListElem, Rectangle)]
aft) -> do
              Bool -> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ListElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ListElem] -> Bool) -> [ListElem] -> Bool
forall a b. (a -> b) -> a -> b
$ NavList -> [ListElem]
linePrev NavList
line) (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$
                SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> ObjectM List SindreX11M ())
-> SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ Color
-> Font -> Int -> Integer -> Integer -> String -> SindreX11M ()
forall x y z.
(Integral x, Integral y, Integral z) =>
Color -> Font -> x -> y -> z -> String -> SindreX11M ()
drawText (Drawer -> Color
drawerFgColor Drawer
d) (Drawer -> Font
drawerFont Drawer
d) Int
x Integer
y Integer
h String
prestr
              Integer
x' <- (Integer
 -> (ListElem, Rectangle) -> ObjectM List SindreX11M Integer)
-> Integer
-> [(ListElem, Rectangle)]
-> ObjectM List SindreX11M Integer
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Drawer
-> Integer
-> (ListElem, Rectangle)
-> ObjectM List SindreX11M Integer
drawElem Drawer
d)
                          (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
prestrw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
x) ([(ListElem, Rectangle)] -> ObjectM List SindreX11M Integer)
-> [(ListElem, Rectangle)] -> ObjectM List SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ [(ListElem, Rectangle)] -> [(ListElem, Rectangle)]
forall a. [a] -> [a]
reverse [(ListElem, Rectangle)]
pre
              Integer
x'' <- Drawer
-> Integer
-> (ListElem, Rectangle)
-> ObjectM List SindreX11M Integer
drawElem Drawer
fd Integer
x' (ListElem, Rectangle)
cur
              (Integer
 -> (ListElem, Rectangle) -> ObjectM List SindreX11M Integer)
-> Integer -> [(ListElem, Rectangle)] -> ObjectM List SindreX11M ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (Drawer
-> Integer
-> (ListElem, Rectangle)
-> ObjectM List SindreX11M Integer
drawElem Drawer
d)  Integer
x'' [(ListElem, Rectangle)]
aft
              Bool -> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ListElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ListElem] -> Bool) -> [ListElem] -> Bool
forall a b. (a -> b) -> a -> b
$ NavList -> [ListElem]
lineNext NavList
line) (ObjectM List SindreX11M () -> ObjectM List SindreX11M ())
-> ObjectM List SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> ObjectM List SindreX11M ())
-> SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
                (Int
aftw,Int
_) <- Font -> String -> SindreX11M (Int, Int)
textExtents (VisualOpts -> Font
font VisualOpts
visual) String
aftstr
                Color
-> Font -> Int -> Integer -> Integer -> String -> SindreX11M ()
forall x y z.
(Integral x, Integral y, Integral z) =>
Color -> Font -> x -> y -> z -> String -> SindreX11M ()
drawText (Drawer -> Color
drawerFgColor Drawer
d) (Drawer -> Font
drawerFont Drawer
d)
                  (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
aftw) Integer
y Integer
h String
aftstr
            Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
Nothing -> () -> ObjectM List SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | As 'mkHList', except the list is vertical.  The parameter @lines@
-- (default value 10) is the number of lines shown.
mkVList :: Constructor SindreX11M
mkVList :: Constructor SindreX11M
mkVList WidgetRef
k [(Maybe Value, WidgetRef)]
cs = do
  Integer
n <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"lines" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
10
  (VisualOpts -> ObjectM List SindreX11M SpaceNeed)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle])
-> (Rectangle -> Integer)
-> (VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle)
-> Constructor SindreX11M
mkList (Integer -> VisualOpts -> ObjectM List SindreX11M SpaceNeed
forall (m :: * -> *).
Monad m =>
Integer -> VisualOpts -> m SpaceNeed
composeVert Integer
n) VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
drawVert Rectangle -> Integer
rectHeight ((Rectangle -> ObjectM List SindreX11M Rectangle)
-> VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle
forall a b. a -> b -> a
const Rectangle -> ObjectM List SindreX11M Rectangle
forall (m :: * -> *) a. Monad m => a -> m a
return) WidgetRef
k [(Maybe Value, WidgetRef)]
cs
  where composeVert :: Integer -> VisualOpts -> m SpaceNeed
composeVert Integer
n VisualOpts
visual =
          SpaceNeed -> m SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (DimNeed
Unlimited, Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ (Font -> Integer
forall a. Integral a => Font -> a
Xft.height (VisualOpts -> Font
font VisualOpts
visual) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
forall a. Integral a => a
padding) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n)

        drawVert :: VisualOpts -> Rectangle -> ObjectM List SindreX11M [Rectangle]
drawVert VisualOpts
visual = VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM List SindreX11M ())
-> Rectangle
-> ObjectM List SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle -> Drawer -> Drawer -> ObjectM List SindreX11M ())
 -> Rectangle -> ObjectM List SindreX11M [Rectangle])
-> (Rectangle -> Drawer -> Drawer -> ObjectM List SindreX11M ())
-> Rectangle
-> ObjectM List SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle
r Drawer
d Drawer
fd -> do
          let fr :: Integer -> Rectangle -> Rectangle
fr Integer
y Rectangle
r' = Rectangle
r { rectY :: Integer
rectY = Integer
y, rectHeight :: Integer
rectHeight = Rectangle -> Integer
rectHeight Rectangle
r' }
              drawElem :: Drawer -> Integer -> (ListElem, Rectangle) -> SindreX11M Integer
drawElem Drawer
d' Integer
y (ListElem
e, Rectangle
r') = do
                Drawer -> Rectangle -> FormatString -> SindreX11M ()
drawFmt Drawer
d' (Integer -> Rectangle -> Rectangle
fr Integer
y Rectangle
r') (FormatString -> SindreX11M ()) -> FormatString -> SindreX11M ()
forall a b. (a -> b) -> a -> b
$ ListElem -> FormatString
showAs ListElem
e
                Integer -> SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> SindreX11M Integer) -> Integer -> SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ Integer
y Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Rectangle -> Integer
rectHeight Rectangle
r'
          Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
line <- (List
 -> Maybe
      ([(ListElem, Rectangle)], (ListElem, Rectangle),
       [(ListElem, Rectangle)]))
-> ObjectM
     List
     SindreX11M
     (Maybe
        ([(ListElem, Rectangle)], (ListElem, Rectangle),
         [(ListElem, Rectangle)]))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (NavList
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
lineContents (NavList
 -> Maybe
      ([(ListElem, Rectangle)], (ListElem, Rectangle),
       [(ListElem, Rectangle)]))
-> (List -> NavList)
-> List
-> Maybe
     ([(ListElem, Rectangle)], (ListElem, Rectangle),
      [(ListElem, Rectangle)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List -> NavList
listLine)
          case Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
line of
            Just ([(ListElem, Rectangle)]
pre, (ListElem, Rectangle)
cur, [(ListElem, Rectangle)]
aft) -> SindreX11M () -> ObjectM List SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (SindreX11M () -> ObjectM List SindreX11M ())
-> SindreX11M () -> ObjectM List SindreX11M ()
forall a b. (a -> b) -> a -> b
$ do
              Integer
y' <- (Integer -> (ListElem, Rectangle) -> SindreX11M Integer)
-> Integer -> [(ListElem, Rectangle)] -> SindreX11M Integer
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Drawer -> Integer -> (ListElem, Rectangle) -> SindreX11M Integer
drawElem Drawer
d) (Rectangle -> Integer
rectY Rectangle
r) ([(ListElem, Rectangle)] -> SindreX11M Integer)
-> [(ListElem, Rectangle)] -> SindreX11M Integer
forall a b. (a -> b) -> a -> b
$ [(ListElem, Rectangle)] -> [(ListElem, Rectangle)]
forall a. [a] -> [a]
reverse [(ListElem, Rectangle)]
pre
              Integer
y'' <- Drawer -> Integer -> (ListElem, Rectangle) -> SindreX11M Integer
drawElem Drawer
fd Integer
y' (ListElem, Rectangle)
cur
              (Integer -> (ListElem, Rectangle) -> SindreX11M Integer)
-> Integer -> [(ListElem, Rectangle)] -> SindreX11M ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (Drawer -> Integer -> (ListElem, Rectangle) -> SindreX11M Integer
drawElem Drawer
d) Integer
y'' [(ListElem, Rectangle)]
aft
            Maybe
  ([(ListElem, Rectangle)], (ListElem, Rectangle),
   [(ListElem, Rectangle)])
Nothing -> () -> ObjectM List SindreX11M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


data Graph = Graph { Graph -> [Integer]
graphHistory    :: [Integer]
                   , Graph -> Integer
graphBot        :: Integer
                   , Graph -> Integer
graphTop        :: Integer
                   }

-- | A visual horisontal bar graph.  Each data point is represented as
-- a vertical bar.  Accepts the following parameters:
--
-- [@size@] The number of data points to remember (defaults to 10)
--
-- [@barWidth@] The width (in pixels) of a single bar (defaults to 2).
--
-- [@bot@] The lower bound of data points as an integer.  If a point
-- has this value (or below), it will be an empty bar.
--
-- [@bot@] The upper bound of data points as an integer.  If a point
-- has this value (or above), it will be a full bar.
--
-- The following methods are supported:
--
-- [@insert(string)@] Split @string@ into lines and add each line as
-- a data point.  Each line must be an integer.
mkGraph :: Constructor SindreX11M
mkGraph :: Constructor SindreX11M
mkGraph WidgetRef
r [] = do
  Integer
gsize <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"size" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
10
  Integer
bwidth <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"barWidth" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
2
  Integer
bot <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"bot" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
  Integer
top <- String -> ConstructorM SindreX11M Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
String -> ConstructorM m a
param String
"top" ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
-> ConstructorM SindreX11M Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> ConstructorM SindreX11M Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
100
  VisualOpts
visual <- WidgetRef -> ConstructorM SindreX11M VisualOpts
visualOpts WidgetRef
r
  Sindre SindreX11M (NewWidget SindreX11M)
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Sindre SindreX11M (NewWidget SindreX11M)
 -> ConstructorM SindreX11M (NewWidget SindreX11M))
-> Sindre SindreX11M (NewWidget SindreX11M)
-> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ NewWidget SindreX11M -> Sindre SindreX11M (NewWidget SindreX11M)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget SindreX11M -> Sindre SindreX11M (NewWidget SindreX11M))
-> NewWidget SindreX11M -> Sindre SindreX11M (NewWidget SindreX11M)
forall a b. (a -> b) -> a -> b
$ Graph
-> Map String (Method Graph SindreX11M)
-> [Field Graph SindreX11M]
-> (Event -> ObjectM Graph SindreX11M ())
-> ObjectM Graph SindreX11M SpaceNeed
-> (Rectangle -> ObjectM Graph SindreX11M [Rectangle])
-> NewWidget SindreX11M
forall s (im :: * -> *).
s
-> Map String (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget ([Integer] -> Integer -> Integer -> Graph
Graph [] Integer
bot Integer
top)
         (Integer -> Map String (Method Graph SindreX11M)
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
LiftFunction im m (ObjectM Graph SindreX11M ()) =>
Integer -> Map String ([Value] -> m im Value)
methods Integer
gsize) []
         Event -> ObjectM Graph SindreX11M ()
forall (m :: * -> *) p. Monad m => p -> m ()
recvEventI (Integer -> Integer -> ObjectM Graph SindreX11M SpaceNeed
forall (m :: * -> *) a.
(Monad m, Integral a) =>
a -> a -> m SpaceNeed
composeI Integer
gsize Integer
bwidth) (VisualOpts
-> Integer
-> Integer
-> Rectangle
-> ObjectM Graph SindreX11M [Rectangle]
forall a.
Integral a =>
VisualOpts
-> Integer
-> a
-> Rectangle
-> ObjectM Graph SindreX11M [Rectangle]
drawI VisualOpts
visual Integer
gsize Integer
bwidth)
    where composeI :: a -> a -> m SpaceNeed
composeI a
gsize a
bwidth = SpaceNeed -> m SpaceNeed
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (a -> Integer) -> a -> Integer
forall a b. (a -> b) -> a -> b
$ a
bwidtha -> a -> a
forall a. Num a => a -> a -> a
*a
gsizea -> a -> a
forall a. Num a => a -> a -> a
+a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Integral a => a
padding, DimNeed
Unlimited)
          methods :: Integer -> Map String ([Value] -> m im Value)
methods Integer
gsize = [(String, [Value] -> m im Value)]
-> Map String ([Value] -> m im Value)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (String
"insert", (Text -> ObjectM Graph SindreX11M ()) -> [Value] -> m im Value
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
LiftFunction im m a =>
a -> [Value] -> m im Value
function ((Text -> ObjectM Graph SindreX11M ()) -> [Value] -> m im Value)
-> (Text -> ObjectM Graph SindreX11M ()) -> [Value] -> m im Value
forall a b. (a -> b) -> a -> b
$ Integer -> Text -> ObjectM Graph SindreX11M ()
mInsert Integer
gsize) ]
          mInsert :: Integer -> T.Text -> ObjectM Graph SindreX11M ()
          mInsert :: Integer -> Text -> ObjectM Graph SindreX11M ()
mInsert Integer
gsize Text
vs = do
            let elems :: Maybe [Integer]
elems = (Text -> Maybe Integer) -> [Text] -> Maybe [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Value -> Maybe Integer
forall a. Mold a => Value -> Maybe a
mold (Value -> Maybe Integer)
-> (Text -> Value) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
StringV) ([Text] -> Maybe [Integer]) -> [Text] -> Maybe [Integer]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
vs
            case Maybe [Integer]
elems of
              Maybe [Integer]
Nothing -> String -> ObjectM Graph SindreX11M ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a number"
              Just [Integer]
elems'  -> [Integer]
-> (Integer -> ObjectM Graph SindreX11M ())
-> ObjectM Graph SindreX11M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Integer]
elems' ((Integer -> ObjectM Graph SindreX11M ())
 -> ObjectM Graph SindreX11M ())
-> (Integer -> ObjectM Graph SindreX11M ())
-> ObjectM Graph SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \Integer
x -> do
                (Graph -> Graph) -> ObjectM Graph SindreX11M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Graph -> Graph) -> ObjectM Graph SindreX11M ())
-> (Graph -> Graph) -> ObjectM Graph SindreX11M ()
forall a b. (a -> b) -> a -> b
$ \Graph
s -> Graph
s { graphHistory :: [Integer]
graphHistory =
                                     Integer -> [Integer] -> [Integer]
forall i a. Integral i => i -> [a] -> [a]
genericTake Integer
gsize ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ Integer
xInteger -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
:Graph -> [Integer]
graphHistory Graph
s }
                ObjectM Graph SindreX11M ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
m im ()
fullRedraw
          recvEventI :: p -> m ()
recvEventI p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          drawI :: VisualOpts
-> Integer
-> a
-> Rectangle
-> ObjectM Graph SindreX11M [Rectangle]
drawI VisualOpts
visual Integer
gsize a
bwidth = VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM Graph SindreX11M ())
-> Rectangle
-> ObjectM Graph SindreX11M [Rectangle]
forall a.
VisualOpts
-> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())
-> Rectangle
-> ObjectM a SindreX11M [Rectangle]
drawing' VisualOpts
visual ((Rectangle -> Drawer -> Drawer -> ObjectM Graph SindreX11M ())
 -> Rectangle -> ObjectM Graph SindreX11M [Rectangle])
-> (Rectangle -> Drawer -> Drawer -> ObjectM Graph SindreX11M ())
-> Rectangle
-> ObjectM Graph SindreX11M [Rectangle]
forall a b. (a -> b) -> a -> b
$ \Rectangle{Integer
rectHeight :: Integer
rectWidth :: Integer
rectY :: Integer
rectX :: Integer
rectHeight :: Rectangle -> Integer
rectWidth :: Rectangle -> Integer
rectY :: Rectangle -> Integer
rectX :: Rectangle -> Integer
..} Drawer
d Drawer
_ -> do
            let numpoints :: Int
numpoints = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1 (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min ((Integer
rectWidth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
forall a. Integral a => a
padding) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` a -> Integer
forall a b. (Integral a, Num b) => a -> b
fi a
bwidth) Integer
gsize)
            [Integer]
points <- Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
numpoints ([Integer] -> [Integer])
-> ObjectM Graph SindreX11M [Integer]
-> ObjectM Graph SindreX11M [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Graph -> [Integer]) -> ObjectM Graph SindreX11M [Integer]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Graph -> [Integer]
graphHistory
            Integer
bot <- (Graph -> Integer) -> ObjectM Graph SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Graph -> Integer
graphBot
            Integer
top <- (Graph -> Integer) -> ObjectM Graph SindreX11M Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Graph -> Integer
graphTop
            let dist :: Integer
dist = Integer
top Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
bot
                hspace :: Position
hspace = Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectHeight Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
2 Position -> Position -> Position
forall a. Num a => a -> a -> a
* Position
forall a. Integral a => a
padding
                point :: (Position, Integer) -> IO ()
point (Position
i, Integer
p) = do
                  let asc :: Double
                      asc :: Double
asc = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fi (Integer
pInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
bot)
                      h :: Position
h = Double -> Position
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Position) -> Double -> Position
forall a b. (a -> b) -> a -> b
$ Double
asc Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fi Integer
dist Double -> Double -> Double
forall a. Num a => a -> a -> a
* Position -> Double
forall a b. (Integral a, Num b) => a -> b
fi Position
hspace
                  Drawer
-> CoreDrawer
     (Position -> Position -> Dimension -> Dimension -> IO ())
Drawer -> forall f. CoreDrawer f
fg Drawer
d Display
-> Drawable
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle (Position
forall a. Integral a => a
padding Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectX Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
i Position -> Position -> Position
forall a. Num a => a -> a -> a
* a -> Position
forall a b. (Integral a, Num b) => a -> b
fi a
bwidth)
                       (Integer -> Position
forall a b. (Integral a, Num b) => a -> b
fi Integer
rectY Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
forall a. Integral a => a
padding Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
hspace Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
h)
                       (a -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi a
bwidth) (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
h)
            IO () -> ObjectM Graph SindreX11M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ObjectM Graph SindreX11M ())
-> IO () -> ObjectM Graph SindreX11M ()
forall a b. (a -> b) -> a -> b
$ ((Position, Integer) -> IO ()) -> [(Position, Integer)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Position, Integer) -> IO ()
point ([Position] -> [Integer] -> [(Position, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Position
0..] [Integer]
points)
mkGraph WidgetRef
_ [(Maybe Value, WidgetRef)]
_ = String -> ConstructorM SindreX11M (NewWidget SindreX11M)
forall a. HasCallStack => String -> a
error String
"Graphs do not have children"