diff --git a/Sindre/Compiler.hs b/Sindre/Compiler.hs --- a/Sindre/Compiler.hs +++ b/Sindre/Compiler.hs @@ -21,8 +21,6 @@ FuncMap, GlobMap, -- * Object Construction - NewWidget(..), - NewObject(..), Constructor, ConstructorM, Param(..), @@ -32,7 +30,7 @@ noParam, badValue, -- * Compiler Interface - + -- | These definitions can be used in builtin functions that may -- need to change global variables. Compiler, @@ -48,7 +46,6 @@ import System.Exit import Control.Applicative -import Control.Arrow import Control.Monad.Error import Control.Monad.RWS.Lazy import Control.Monad.State @@ -104,12 +101,12 @@ , currentPos = nowhere } -data CompilerState m = CompilerState { +data CompilerState = CompilerState { globalScope :: M.Map Identifier GlobalBinding , nextMutable :: IM.Key } -blankCompilerState :: CompilerState m +blankCompilerState :: CompilerState blankCompilerState = CompilerState { globalScope = M.empty , nextMutable = 0 @@ -118,7 +115,7 @@ type Initialisation m = Sindre m () -- | Monad inside which compilation takes place. -type Compiler m a = RWS (CompilerEnv m) (Initialisation m) (CompilerState m) a +type Compiler m a = RWS (CompilerEnv m) (Initialisation m) CompilerState a runCompiler :: CompilerEnv m -> Compiler m a -> (a, Initialisation m) runCompiler env m = evalRWS m env blankCompilerState @@ -259,8 +256,8 @@ let lastwr' = lastwr + length objs handler <- compileActions $ programActions prog tell $ do - ws <- map (second toWslot) <$> initGUI gui - os <- map (second toOslot) <$> initObjs objs + ws <- initGUI gui + os <- initObjs objs modify $ \s -> s { objects = array (0, lastwr') $ ws++os } funs' <- forM funs $ descend $ \(k, f) -> case (filter ((==k) . fst . unP) funs, @@ -348,7 +345,7 @@ return $ \ev -> do dispatch ev reacts' case ev of KeyPress _ -> - flip recvEvent ev =<< sindre (gets kbdFocus) + flip recvEventByRef ev =<< sindre (gets kbdFocus) _ -> return () where compileReaction (pat, act) = do (pat', args) <- compilePattern pat @@ -469,8 +466,8 @@ o <- oe' v <- e' case o of - Reference wr -> sindre $ do _ <- fieldSet wr s v - return v + Reference wr -> do _ <- setFieldByRef wr s v + return v _ -> bad "Not an object" compileExpr (_ `Assign` _) = compileError "Cannot assign to rvalue" compileExpr (e `Lookup` fe) = do @@ -489,7 +486,7 @@ return $ do o <- oe' case o of - Reference wr -> sindre $ fieldGet wr s + Reference wr -> getFieldByRef wr s _ -> bad "Not an object" compileExpr (Methcall oe meth argexps) = do argexps' <- mapM (descend compileExpr) argexps @@ -499,7 +496,7 @@ argvs <- sequence argexps' v <- o' case v of - Reference wr -> callMethod wr meth argvs + Reference wr -> callMethodByRef wr meth argvs _ -> bad "Not an object" compileExpr (Funcall f argexps) = do argexps' <- mapM (descend compileExpr) argexps @@ -556,12 +553,7 @@ (Just v1', Just v2') -> return $ Number $! v1' `op` v2' _ -> bad $ "Can only " ++ opstr ++ " numbers" --- | Container wrapping a newly created widget. -data NewWidget m = forall s . Widget m s => NewWidget s --- | Container wrapping a newly created object. -data NewObject m = forall s . Object m s => NewObject s - -type WidgetArgs m = M.Map Identifier (Execution m Value) +type WidgetArgs im = M.Map Identifier (Execution im Value) -- | Function that, given an initial value, the name of itself if any, -- and a list of children, yields a computation that constructs a new @@ -577,7 +569,7 @@ ObjectRef -> m (NewObject m))] initGUI :: MonadBackend m => InstGUI m - -> Sindre m [(ObjectNum, (NewWidget m, Constraints))] + -> Sindre m [(ObjectNum, DataSlot m)] initGUI (InstGUI r@(wn,_,_) f args cs) = do args' <- traverse execute args childrefs <- forM cs $ \(e, InstGUI r' _ _ _) -> do @@ -589,26 +581,21 @@ minh <- Just <$> param "minheight" <|> return Nothing maxw <- Just <$> param "maxwidth" <|> return Nothing maxh <- Just <$> param "maxheight" <|> return Nothing - s <- f r childrefs - return (s, ((minw, maxw), (minh, maxh))) + nw <- f r childrefs + return $ instWidget nw ((minw, maxw), (minh, maxh)) s <- runConstructor constructor args' children <- liftM concat $ mapM (initGUI . snd) cs - return $ (wn, s):children + return $ (wn,s):children lookupClass :: ClassMap m -> Identifier -> Compiler m (Constructor m) lookupClass m k = maybe unknown return $ M.lookup k m where unknown = compileError $ "Unknown class '" ++ k ++ "'" initObjs :: MonadBackend m => - InstObjs m -> Sindre m [(ObjectNum, NewObject m)] + InstObjs m -> Sindre m [(ObjectNum, DataSlot m)] initObjs = mapM $ \((_, r@(r',_,_)), con) -> do - o <- back $ con r - return (r', o) - -toWslot :: (NewWidget m, Constraints) -> DataSlot m -toWslot (NewWidget s, cs) = WidgetSlot s $ WidgetState cs $ Rectangle 0 0 0 0 -toOslot :: NewObject m -> DataSlot m -toOslot (NewObject s) = ObjectSlot s + no <- back $ con r + return (r', instObject no) -- | Class of types that a given backend can convert to from 'Value's. -- In effect, a monadic version of 'Mold'. diff --git a/Sindre/Runtime.hs b/Sindre/Runtime.hs --- a/Sindre/Runtime.hs +++ b/Sindre/Runtime.hs @@ -28,17 +28,26 @@ , fullRedraw , setRootPosition , MonadBackend(..) - , Object(..) + , NewObject + , newObject + , NewWidget + , newWidget + , DataSlot + , instWidget + , instObject + , FieldDesc(..) + , fieldName + , getField + , field + , Field + , Method , ObjectM - , fieldSet - , fieldGet - , callMethod - , Widget(..) + , setFieldByRef + , getFieldByRef + , callMethodByRef + , recvEventByRef , draw , compose - , recvEvent - , DataSlot(..) - , WidgetState(..) , SindreEnv(..) , newEnv , globalVal @@ -79,17 +88,124 @@ import Data.Monoid import Data.Sequence((|>), ViewL(..)) import qualified Data.IntMap as IM +import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Sequence as Q import qualified Data.Text as T -data WidgetState = WidgetState { constraints :: Constraints - , dimensions :: Rectangle - } +-- | A typed description of a field, which may be read-write or +-- read-only. When constructing the actual widget, you must turn +-- these into real 'Field's by using the 'field' function. A +-- description of a field consists of a name and monadic actions for +-- reading and optionally writing to the field. +data FieldDesc s im v = ReadWriteField Identifier (ObjectM s im v) (v -> ObjectM s im ()) + | ReadOnlyField Identifier (ObjectM s im v) -data DataSlot m = forall s . Widget m s => WidgetSlot s WidgetState - | forall s . Object m s => ObjectSlot s +fieldName :: FieldDesc s im v -> Identifier +fieldName (ReadWriteField n _ _) = n +fieldName (ReadOnlyField n _) = n +getField :: FieldDesc s im v -> ObjectM s im v +getField (ReadWriteField _ g _) = g +getField (ReadOnlyField _ g) = g + +-- | An opaque notion of a field. These are for internal use in the +-- Sindre runtime. +data Field s im = Field { fieldID :: Identifier + , fieldGetter :: ObjectM s im Value + , fieldSetter :: Value -> ObjectM s im () + } + +-- | Turn a Haskell-typed high-level field description into a +-- 'Value'-typed field. +field :: Mold v => FieldDesc s im v -> Field s im +field (ReadOnlyField name bgetter) = Field name (unmold <$> bgetter) problem + where problem = fail "Field is read-only" +field (ReadWriteField name bgetter bsetter) = + Field name (unmold <$> bgetter) setter + where setter v = maybe problem bsetter $ mold v + where problem = fail $ "Cannot convert " ++ show v ++ " to expected type" + +-- | A method takes as arguments a list of 'Value's and returns +-- another 'Value'. You probably do not want to call these directly +-- from Haskell code, as they are dynamically typed. See +-- 'Sindre.Lib.function' for a convenient way to turn a Haskell +-- function into a suitable method. +type Method s im = [Value] -> ObjectM s im Value + +-- | Container describing a newly created widget. +data NewWidget im = forall s . NewWidget (Object s im) + (ObjectM s im SpaceNeed) + (Rectangle -> ObjectM s im SpaceUse) +-- | Container describing a newly created object. +data NewObject im = forall s . NewObject (Object s im) + +newWidget :: s + -> M.Map Identifier (Method s im) + -> [Field s im] + -> (Event -> ObjectM s im ()) + -> ObjectM s im SpaceNeed + -> (Rectangle -> ObjectM s im SpaceUse) + -> NewWidget im +newWidget s ms fs h = + NewWidget $ Object s ms (M.fromList $ zip (map fieldID fs) fs) h + +newObject :: s + -> M.Map Identifier (Method s im) + -> [Field s im] + -> (Event -> ObjectM s im ()) + -> NewObject im +newObject s ms fs h = + NewObject $ Object s ms (M.fromList $ zip (map fieldID fs) fs) h + +data Object s im = Object { objectState :: s + , objectMethods :: M.Map Identifier (Method s im) + , objectFields :: M.Map Identifier (Field s im) + , objectHandler :: Event -> ObjectM s im () } + +data Widget s im = Widget { widgetObject :: Object s im + , widgetCompose :: ObjectM s im SpaceNeed + , widgetDraw :: Rectangle -> ObjectM s im SpaceUse + , widgetConstraints :: Constraints + , widgetDimensions :: Rectangle } + +widgetState :: Widget s im -> s +widgetState = objectState . widgetObject + +data DataSlot im = forall s . WidgetSlot (Widget s im) + | forall s . ObjectSlot (Object s im) + +instWidget :: NewWidget im -> Constraints -> DataSlot im +instWidget (NewWidget s c d) con = WidgetSlot $ Widget s c d con mempty + +instObject :: NewObject im -> DataSlot im +instObject (NewObject o) = ObjectSlot o + +callMethodI :: Identifier -> [Value] -> ObjectRef -> Object s im -> Sindre im (Value, s) +callMethodI m vs k s = case M.lookup m $ objectMethods s of + Nothing -> fail "No such method" + Just m' -> runObjectM (m' vs) k $ objectState s + +getFieldI :: Identifier -> ObjectRef -> Object s im -> Sindre im (Value, s) +getFieldI f k s = case M.lookup f $ objectFields s of + Nothing -> fail "No such field" + Just f' -> runObjectM (fieldGetter f') k $ objectState s + +setFieldI :: Identifier -> Value -> ObjectRef -> Object s im -> Sindre im (Value, s) +setFieldI f v k s = case M.lookup f $ objectFields s of + Nothing -> fail "No such field" + Just f' -> runObjectM (setget f') k $ objectState s + where setget f' = fieldSetter f' v >> fieldGetter f' + +recvEventI :: Event -> ObjectRef -> Object s im -> Sindre im ((), s) +recvEventI e k s = runObjectM (objectHandler s e) k $ objectState s + +composeI :: ObjectRef -> Widget s im -> Sindre im (SpaceNeed, s) +composeI k s = runObjectM (widgetCompose s) k $ objectState $ widgetObject s + +drawI :: Rectangle -> ObjectRef -> Widget s im -> Sindre im (SpaceUse, s) +drawI r k s = runObjectM (widgetDraw s r) k $ widgetState s + type Frame = IM.IntMap Value data Redraw = RedrawAll | RedrawSome (S.Set WidgetRef) @@ -118,7 +234,7 @@ } -- | A monad that can be used as the layer beneath 'Sindre'. -class (Monad m, Functor m, Applicative m, Mold (RootPosition m)) => MonadBackend m where +class (MonadIO m, Functor m, Applicative m, Mold (RootPosition m)) => MonadBackend m where type BackEvent m :: * type RootPosition m :: * redrawRoot :: Sindre m () @@ -178,32 +294,18 @@ instance MonadBackend im => MonadSindre im Sindre where sindre = id -newtype ObjectM o m a = ObjectM (ReaderT ObjectRef (StateT o (Sindre m)) a) - deriving (Functor, Monad, Applicative, MonadState o, MonadReader ObjectRef) +newtype ObjectM s im a = ObjectM (ReaderT ObjectRef (StateT s (Sindre im)) a) + deriving (Functor, Monad, Applicative, MonadState s, MonadReader ObjectRef) instance MonadBackend im => MonadSindre im (ObjectM o) where sindre = ObjectM . lift . lift -runObjectM :: Object m o => ObjectM o m a -> ObjectRef -> o -> Sindre m (a, o) +runObjectM :: ObjectM s im a -> ObjectRef -> s -> Sindre im (a, s) runObjectM (ObjectM m) wr = runStateT (runReaderT m wr) -class MonadBackend m => Object m s where - callMethodI :: Identifier -> [Value] -> ObjectM s m Value - callMethodI m _ = fail $ "Unknown method '" ++ m ++ "'" - fieldSetI :: Identifier -> Value -> ObjectM s m Value - fieldSetI f _ = fail $ "Unknown field '" ++ f ++ "'" - fieldGetI :: Identifier -> ObjectM s m Value - fieldGetI f = fail $ "Unknown field '" ++ f ++ "'" - recvEventI :: Event -> ObjectM s m () - recvEventI _ = return () - instance (MonadIO m, MonadBackend m) => MonadIO (ObjectM o m) where liftIO = sindre . back . io -class Object m s => Widget m s where - composeI :: ObjectM s m SpaceNeed - drawI :: Rectangle -> ObjectM s m SpaceUse - popQueue :: Sindre m (Maybe Event) popQueue = do queue <- gets evtQueue case Q.viewl queue of @@ -226,7 +328,7 @@ this <- ask broadcast $ NamedEvent "changed" [old, new] $ FieldSrc this f -redraw :: (MonadBackend im, Widget im s) => ObjectM s im () +redraw :: MonadBackend im => ObjectM s im () redraw = do r <- ask sindre $ modify $ \s -> s { needsRedraw = needsRedraw s `add` r } @@ -254,59 +356,16 @@ modify $ \s -> s { globals = IM.insert k v $ globals s } -operateW :: MonadBackend m => WidgetRef -> - (forall o . Widget m o => o -> WidgetState -> Sindre m (a, o, WidgetState)) - -> Sindre m a -operateW (r,_,_) f = do - objs <- gets objects - (v, s') <- case objs!r of - WidgetSlot o s -> do (v, o', s') <- f o s - return (v, WidgetSlot o' s') - _ -> fail "Expected widget" - modify $ \s -> s { objects = objects s // [(r, s')] } - return v - -operateO :: MonadBackend m => ObjectRef -> - (forall o . Object m o => o -> Sindre m (a, o)) -> Sindre m a -operateO (r,_,_) f = do - objs <- gets objects - (v, s') <- case objs!r of - WidgetSlot s sz -> do (v, s') <- f s - return (v, WidgetSlot s' sz) - ObjectSlot s -> do (v, s') <- f s - return (v, ObjectSlot s') - modify $ \s -> s { objects = objects s // [(r, s')] } - return v - -actionO :: MonadBackend m => ObjectRef -> - (forall o . Object m o => ObjectM o m a) -> Sindre m a -actionO r f = operateO r $ runObjectM f r - -callMethod :: MonadSindre im m => - ObjectRef -> Identifier -> [Value] -> m im Value -callMethod r m vs = sindre $ actionO r (callMethodI m vs) -fieldSet :: MonadSindre im m => - ObjectRef -> Identifier -> Value -> m im Value -fieldSet r f v = sindre $ actionO r $ do - old <- fieldGetI f - new <- fieldSetI f v - changed f old new - return new -fieldGet :: MonadSindre im m => ObjectRef -> Identifier -> m im Value -fieldGet r f = sindre $ actionO r (fieldGetI f) -recvEvent :: MonadSindre im m => WidgetRef -> Event -> m im () -recvEvent r ev = sindre $ actionO r (recvEventI ev) - compose :: MonadSindre im m => WidgetRef -> m im SpaceNeed -compose r = sindre $ operateW r $ \w s -> do - (need, w') <- runObjectM composeI r w - return (constrainNeed need $ constraints s, w', s) +compose k = sindre $ operateW k $ \w -> do + (need, w') <- onStateW (composeI k) w + return (constrainNeed need $ widgetConstraints w', w') draw :: MonadSindre im m => WidgetRef -> Maybe Rectangle -> m im SpaceUse -draw r rect = sindre $ operateW r $ \w s -> do - let rect' = fromMaybe (dimensions s) rect - (use, w') <- runObjectM (drawI rect') r w - return (use, w', s { dimensions = rect' }) +draw k rect = sindre $ operateW k $ \w -> do + let rect' = fromMaybe (widgetDimensions w) rect + (use, w') <- onStateW (drawI rect' k) w + return (use, w' { widgetDimensions = rect' }) type Jumper m a = a -> Execution m () @@ -363,7 +422,6 @@ } Execution m' = returnHere m - execute_ :: MonadBackend m => Execution m a -> Sindre m () execute_ m = execute (m *> return (Number 0)) >> return () @@ -387,6 +445,52 @@ setLexical k v = sindre $ modify $ \s -> s { execFrame = IM.insert k v $ execFrame s } +operateW :: MonadBackend im => WidgetRef -> + (forall s . Widget s im -> Sindre im (a, Widget s im)) + -> Sindre im a +operateW (r,_,_) f = do + objs <- gets objects + (v, s') <- case objs!r of + WidgetSlot s -> do (v, s') <- f s + return (v, WidgetSlot s') + _ -> fail "Expected widget" + modify $ \s -> s { objects = objects s // [(r, s')] } + return v + +operateO :: MonadBackend im => ObjectRef -> + (forall s . Object s im -> Sindre im (a, Object s im)) -> Sindre im a +operateO (r,_,_) f = do + objs <- gets objects + (v, s') <- case objs!r of + WidgetSlot s -> do (v, s') <- f $ widgetObject s + return (v, WidgetSlot s { widgetObject = s' }) + ObjectSlot s -> do (v, s') <- f s + return (v, ObjectSlot s') + modify $ \s -> s { objects = objects s // [(r, s')] } + return v + +onState :: (Object s im -> Sindre im (a, s)) -> Object s im -> Sindre im (a, Object s im) +onState f s = do (v, s') <- f s + return (v, s { objectState = s' }) + +onStateW :: (Widget s im -> Sindre im (a, s)) -> Widget s im -> Sindre im (a, Widget s im) +onStateW f s = do (v, os) <- f s + return (v, s { widgetObject = (widgetObject s) + { objectState = os }}) + +callMethodByRef :: MonadBackend im => ObjectRef -> Identifier -> [Value] -> Execution im Value +callMethodByRef k m vs = sindre $ operateO k $ onState $ callMethodI m vs k +setFieldByRef :: MonadBackend im => ObjectRef -> Identifier -> Value -> Execution im Value +setFieldByRef k f v = sindre $ operateO k $ \s -> do + (old, s') <- onState (getFieldI f k) s + (new, s'') <- onState (setFieldI f v k) s' + ((), os) <- runObjectM (changed f old new) k $ objectState s'' + return (new, s'' { objectState = os }) +getFieldByRef :: MonadBackend im => ObjectRef -> Identifier -> Execution im Value +getFieldByRef k f = sindre $ operateO k $ onState $ getFieldI f k +recvEventByRef :: MonadBackend im => WidgetRef -> Event -> Execution im () +recvEventByRef k ev = sindre $ operateO k $ onState $ recvEventI ev k + type EventHandler m = Event -> Execution m () eventLoop :: MonadBackend m => EventHandler m -> Sindre m () @@ -445,6 +549,10 @@ instance Mold () where mold _ = Just () unmold _ = Number 0 + +instance Mold a => Mold (Maybe a) where + mold = liftM Just . mold + unmold = maybe falsity unmold aligns :: [(String, (Align, Align))] aligns = [ ("top", (AlignCenter, AlignNeg)) diff --git a/Sindre/Widgets.hs b/Sindre/Widgets.hs --- a/Sindre/Widgets.hs +++ b/Sindre/Widgets.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ImpredicativeTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Sindre.Widgets @@ -16,7 +17,9 @@ ----------------------------------------------------------------------------- module Sindre.Widgets ( mkHorizontally , mkVertically - , changeFields + , changeField + , changeField_ + , changingField , Match(..) , match , filterMatches @@ -34,6 +37,7 @@ import Data.List import Data.Maybe +import qualified Data.Map as M import qualified Data.Text as T data Oriented = Oriented { @@ -42,17 +46,6 @@ , children :: [WidgetRef] } -instance MonadBackend m => Object m Oriented where - -instance MonadBackend m => Widget m Oriented where - composeI = do - chlds <- gets children - gets mergeSpace <*> mapM compose chlds - drawI r = do - chlds <- gets children - rects <- gets splitSpace <*> pure r <*> mapM compose chlds - concat <$> zipWithM draw (reverse chlds) (Just <$> reverse rects) - sumPrim :: [DimNeed] -> DimNeed sumPrim [] = Min 0 sumPrim (d:ds) = foldl f d ds @@ -81,10 +74,18 @@ f x y = f y x layouting :: MonadBackend m => (forall a. ((a, a) -> a)) -> Constructor m -layouting f _ cs = return $ NewWidget $ Oriented merge split (map snd cs) +layouting f _ cs = return $ newWidget (Oriented merge split (map snd cs)) + M.empty [] (const $ return ()) composeI drawI where merge rects = ( f (sumPrim, sumSec) $ map fst rects , f (sumSec, sumPrim) $ map snd rects ) split r = f (splitVert, splitHoriz) r . map f + composeI = do + chlds <- gets children + gets mergeSpace <*> mapM compose chlds + drawI r = do + chlds <- gets children + rects <- gets splitSpace <*> pure r <*> mapM compose chlds + concat <$> zipWithM draw (reverse chlds) (Just <$> reverse rects) -- | A widget that arranges its children in a horizontal row. mkHorizontally :: MonadBackend m => Constructor m @@ -94,16 +95,31 @@ mkVertically :: MonadBackend m => Constructor m mkVertically = layouting snd --- | @changeFields fs m@ applies @m@ to the state of the object, --- replacing the state with the return value of @m@. Value-changed --- events are sent for each pair of field-name and accessor function --- passed in @fs@. -changeFields :: MonadBackend im => [(Identifier, a -> Value)] - -> (a -> ObjectM a im a) -> ObjectM a im () -changeFields fs m = do - s <- get - s' <- m s - put s' >> mapM_ (\(k, f) -> changed k (f s) (f s')) fs +-- | @changeField field m@ applies @m@ to the current value of the +-- field @field@, updates @field@ with the value returned by @m@, and +-- returns the new value. +changeField :: FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im v +changeField (ReadWriteField _ getter setter) m = do + v' <- m =<< getter + setter v' + return v' +changeField (ReadOnlyField _ _) _ = fail "Field is read-only" + +-- | Like 'changeField', but without a return value. +changeField_ :: FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im () +changeField_ f m = changeField f m >> return () + +-- | @changingFields fields m@ evaluates @m@, then emits field change +-- events for those fields whose names are in @fields@ that changed +-- while evaluating @m@. +changingField :: (MonadBackend im, Mold v) => + FieldDesc s im v -> ObjectM s im a -> ObjectM s im a +changingField f m = do + v <- unmold <$> getField f + a <- m + v' <- unmold <$> getField f + changed (fieldName f) v v' + return a -- | The result of using 'match' to apply a user-provided pattern to a -- string. diff --git a/Sindre/X11.hs b/Sindre/X11.hs --- a/Sindre/X11.hs +++ b/Sindre/X11.hs @@ -32,6 +32,7 @@ , allocColor , drawing , drawing' + , X11Field , Drawer(..) , setFgColor , setBgColor @@ -48,7 +49,8 @@ where import Sindre.Sindre -import Sindre.Compiler +import Sindre.Compiler (badValue, moldM, Constructor, ConstructorM, Param, + param, noParam, paramM) import Sindre.Formatting import Sindre.KeyVal ((<$?>), (<||>)) import qualified Sindre.KeyVal as KV @@ -58,7 +60,7 @@ import Sindre.Widgets import Graphics.X11.Xlib hiding ( refreshKeyboardMapping - , Rectangle + , Rectangle , badValue , resourceManagerString , textWidth @@ -95,6 +97,7 @@ import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as E +import qualified Data.Text.Encoding.Error as E import Prelude hiding (catch) @@ -224,7 +227,6 @@ maybe waitForBackEvent return ev getBackEvent = do - io yield back (io . tryTakeMVar =<< asks sindreEvtVar) >>= fromMaybe (return Nothing) @@ -559,10 +561,6 @@ 0,0,rectY r1,rectY r1 + rectHeight r1,0,0,0,0] ] -data InStream = InStream Handle - -instance (MonadIO m, MonadBackend m) => Object m InStream where - -- | An input stream object wrapping the given 'Handle'. Input is -- purely event-driven and line-oriented: the event @lines@ is sent -- (roughly) for each sequence of lines that can be read without @@ -575,24 +573,39 @@ linevar <- io newEmptyMVar let putEv ev = putMVar evvar $ return $ Just $ ev $ ObjectSrc r getLines = do - line <- takeMVar linevar - case line of Just line' -> getLines' [line'] >> getLines - Nothing -> putEv $ NamedEvent "eof" [] + lns <- takeMVar linevar + case lns of Just lns' -> getLines' lns' >> getLines + Nothing -> putEv $ NamedEvent "eof" [] getLines' lns = do - line <- yield >> tryTakeMVar linevar - case line of Just Nothing -> do - putEv $ NamedEvent "lines" [asStr lns] + more <- tryTakeMVar linevar + case more of Just Nothing -> do + putEv $ NamedEvent "lines" [StringV lns] putEv $ NamedEvent "eof" [] - Just (Just line') -> getLines' $ line' : lns - Nothing -> putEv $ NamedEvent "lines" [asStr lns] - readLines = forever (putMVar linevar =<< - Just <$> E.decodeUtf8 <$> B.hGetLine h) - `catch` (\(_::IOException) -> putMVar linevar Nothing) + Just (Just more') -> getLines' $ lns `T.append` more' + Nothing -> putEv $ NamedEvent "lines" [StringV lns] + readLines buf = do + (ls, buf') <- readLinesNonBlocking h buf + unless (B.null ls) $ putMVar linevar $ Just $ decode ls + eof <- hIsEOF h + if eof then do when (buf' /= B.empty) $ + putMVar linevar $ Just $ decode buf' + putMVar linevar Nothing + else readLines buf' _ <- io $ forkIO getLines - _ <- io $ forkIO readLines - return $ NewObject $ InStream h - where asStr = StringV . T.unlines . reverse + _ <- io $ forkIO $ readLines B.empty + return $ newObject h M.empty [] (const $ return ()) + where decode = E.decodeUtf8With E.lenientDecode +readLinesNonBlocking :: Handle -> B.ByteString -> IO (B.ByteString, B.ByteString) +readLinesNonBlocking h b = do + b' <- B.hGetNonBlocking h bufferSize + if B.null b' then return $ splitLines b + else do let (ls, b'') = splitLines $ b `B.append` b' + (ls',b''') <- readLinesNonBlocking h b'' + return (ls `B.append` ls', b''') + where bufferSize = 1024*1024 + splitLines = B.breakEnd (==fromIntegral (ord '\n')) + -- | 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 @@ -675,17 +688,16 @@ -- ffg drawString 0 25 \"focus foreground\" -- fbg drawString 0 35 \"focus background\" -- @ -drawing :: (a -> VisualOpts) +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 vf m r@Rectangle{..} = do +drawing VisualOpts{..} m r@Rectangle{..} = do dpy <- back $ asks sindreDisplay canvas <- back $ gets surfaceCanvas - VisualOpts{..} <- vf <$> get let mkgc fg bg = io $ do gc <- createGC dpy canvas setForeground dpy gc $ Xft.pixel fg setBackground dpy gc $ Xft.pixel bg @@ -704,10 +716,10 @@ <* io (mapM_ (freeGC dpy) (gcsOf normal++gcsOf focus) >> sync dpy False) -- | Variant of @drawing@ that assumes the entire rectangle is used. -drawing' :: (a -> VisualOpts) +drawing' :: VisualOpts -> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ()) -> Rectangle -> ObjectM a SindreX11M SpaceUse -drawing' vf m = drawing vf $ \r normal focus -> do +drawing' vo m = drawing vo $ \r normal focus -> do m r normal focus return [r] @@ -737,46 +749,13 @@ padding :: Integral a => a padding = 2 - + +type X11Field s = FieldDesc s SindreX11M + data Dial = Dial { dialMax :: Integer , dialVal :: Integer - , dialVisual :: VisualOpts } -instance Object SindreX11M Dial where - fieldSetI "value" (mold -> Just v) = do - modify $ \s -> s { dialVal = clamp 0 v (dialMax s) } - redraw >> unmold <$> gets dialVal - fieldSetI _ _ = return $ Number 0 - fieldGetI "value" = unmold <$> gets dialVal - fieldGetI _ = return $ Number 0 - - recvEventI (KeyPress (_, CharKey 'n')) = - changeFields [("value", unmold . dialVal)] $ \s -> do - redraw - return s { dialVal = clamp 0 (dialVal s+1) (dialMax s) } - recvEventI (KeyPress (_, CharKey 'p')) = - changeFields [("value", unmold . dialVal)] $ \s -> do - redraw - return s { dialVal = clamp 0 (dialVal s-1) (dialMax s) } - recvEventI _ = return () - -instance Widget SindreX11M Dial where - composeI = return (Exact 50, Exact 50) - drawI = drawing' dialVisual $ \Rectangle{..} d _ -> do - val <- gets dialVal - maxval <- gets dialMax - io $ do - let unitAng = 2*pi / fi maxval - angle = (-unitAng) * fi val :: Double - dim = min rectWidth rectHeight - 1 - cornerX = fi rectX + (rectWidth - dim) `div` 2 - cornerY = fi rectY + (rectHeight - dim) `div` 2 - fg d drawArc (fi cornerX) (fi cornerY) (fi dim) (fi dim) 0 (360*64) - fg d fillArc (fi cornerX) (fi cornerY) - (fi dim) (fi dim) (90*64) (round $ angle * (180/pi) * 64) - fg d drawRectangle (fi cornerX) (fi cornerY) (fi dim) (fi dim) - -- | A simple dial using an arc segment to indicate the value compared -- to the max value. Accepts @max@ and @value@ parameters (both -- integers, default values 12 and 0), and a single field: @value@. @@ -786,90 +765,123 @@ maxv <- param "max" <|> return 12 val <- param "value" <|> return 0 visual <- visualOpts r - sindre $ return $ NewWidget $ Dial maxv val visual + sindre $ return $ newWidget (Dial maxv val) + M.empty [field value] + recvEventI composeI (drawI visual) + where composeI = return (Exact 50, Exact 50) + value = ReadWriteField "value" (gets dialVal) $ \v -> + modify (\s -> s { dialVal = clamp 0 v (dialMax s) }) >> redraw + recvEventI (KeyPress (_, CharKey 'n')) = do + dmax <- gets dialMax + changeField_ value $ \v -> return $ clamp 0 (v+1) dmax + recvEventI (KeyPress (_, CharKey 'p')) = do + dmax <- gets dialMax + changeField_ value $ \v -> return $ clamp 0 (v-1) dmax + recvEventI _ = return () + drawI visual = drawing' visual $ \Rectangle{..} d _ -> do + val <- gets dialVal + maxval <- gets dialMax + io $ do + let unitAng = 2*pi / fi maxval + angle = (-unitAng) * fi val :: Double + dim = min rectWidth rectHeight - 1 + cornerX = fi rectX + (rectWidth - dim) `div` 2 + cornerY = fi rectY + (rectHeight - dim) `div` 2 + fg d drawArc (fi cornerX) (fi cornerY) (fi dim) (fi dim) 0 (360*64) + fg d fillArc (fi cornerX) (fi cornerY) + (fi dim) (fi dim) (90*64) (round $ angle * (180/pi) * 64) + fg d drawRectangle (fi cornerX) (fi cornerY) (fi dim) (fi dim) mkDial _ _ = error "Dials do not have children" -data Label = Label { labelText :: FormatString - , labelVisual :: VisualOpts - } - -instance Object SindreX11M Label where - fieldSetI "label" v = do - modify $ \s -> s { labelText = fromMaybe [Text $ T.pack $ show v] $ mold v } - fullRedraw - gets (unmold . labelText) - fieldSetI _ _ = return $ Number 0 - fieldGetI "label" = gets (unmold . labelText) - fieldGetI _ = return $ Number 0 - -instance Widget SindreX11M Label where - composeI = do - font <- gets (font . labelVisual) - text <- gets labelText - case text of - [] -> return (Exact 0, Exact $ 2 * padding + Xft.height font) - _ -> do r <- back $ fmtSize font text - return (Exact $ rectWidth r, - Exact $ rectHeight r) - drawI = drawing' labelVisual $ \r fg _ -> do - label <- gets labelText - back $ drawFmt fg r label - -- | Label displaying the text contained in the field @label@, which -- is also accepted as a widget parameter (defaults to the empty -- string). mkLabel :: Constructor SindreX11M -mkLabel r [] = do - label <- param "label" <|> return [] - visual <- visualOpts r - return $ NewWidget $ Label label visual +mkLabel wr [] = do + lbl <- param "label" <|> return [] + visual <- visualOpts wr + return $ newWidget lbl M.empty + [field label] + (const $ return ()) + (composeI visual) (drawI visual) + where label = ReadWriteField "label" getLabel setLabel + setLabel v = put v >> fullRedraw + getLabel = get + composeI visual = do + text <- get + case text of + [] -> return (Exact 0, Exact $ 2 * padding + Xft.height (font visual)) + _ -> do r <- back $ fmtSize (font visual) text + return (Exact $ rectWidth r, + Exact $ rectHeight r) + drawI visual = drawing' visual $ \r fg _ -> + back . drawFmt fg r =<< get mkLabel _ _ = error "Labels do not have children" -data Blank = Blank { blankVisual :: VisualOpts } - -instance Object SindreX11M Blank where - fieldSetI _ _ = return $ Number 0 - fieldGetI _ = return $ Number 0 - -instance Widget SindreX11M Blank where - composeI = return (Unlimited, Unlimited) - drawI = drawing' blankVisual $ \_ _ _ -> return () - -- | A blank widget, showing only background color, that can use as -- much or as little room as necessary. Useful for constraining the -- layout of other widgets. mkBlank :: Constructor SindreX11M mkBlank r [] = do visual <- visualOpts r - return $ NewWidget $ Blank visual + return $ newWidget () M.empty [] (const $ return ()) + (return (Unlimited, Unlimited)) + (drawing' visual $ \_ _ _ -> return ()) mkBlank _ _ = error "Blanks do not have children" -data TextField = TextField { fieldText :: (String, String) - , fieldVisual :: VisualOpts } +data TextField = TextField { fieldText :: (String, String) } fieldValue :: TextField -> String fieldValue = uncurry (++) . first reverse . fieldText -instance Object SindreX11M TextField where - fieldSetI "value" (mold -> Just v) = do - modify $ \s -> s { fieldText = (reverse v, "") } - fullRedraw - return $ string v - fieldSetI _ _ = return $ Number 0 - fieldGetI "value" = string <$> fieldValue <$> get - fieldGetI _ = return $ Number 0 - - recvEventI (KeyPress (S.toList -> [], CharKey c)) = - changeFields [("value", unmold . fieldValue)] $ \s -> do - let (bef, aft) = fieldText s - fullRedraw - return s { fieldText = (c:bef, aft) } - recvEventI (KeyPress k) = - maybe (return ()) (redraw >>) $ M.lookup k editorCommands - recvEventI _ = return () +-- | Single-line text field, whose single field @value@ (also a +-- parameter, defaults to the empty string) is the contents of the +-- editing buffer. +mkTextField :: Constructor SindreX11M +mkTextField r [] = do + v <- param "value" <|> return "" + visual <- visualOpts r + return $ newWidget (TextField ("",v)) methods [field value] + recvEventI (composeI visual) (drawI visual) + where methods = M.fromList [] + value = ReadWriteField "value" getValue setValue + getValue = T.pack <$> gets fieldValue + setValue v = + modify $ \s -> s { fieldText = (reverse $ T.unpack v, "") } + recvEventI (KeyPress (S.toList -> [], CharKey c)) = + changingField value $ do + modify $ \(TextField (bef, aft)) -> TextField (c:bef, aft) + fullRedraw + recvEventI (KeyPress k) = + maybe (return ()) (redraw >>) $ M.lookup k (editorCommands value) + recvEventI _ = return () + composeI visual = do + text <- gets fieldValue + (w,h) <- back $ textExtents (font visual) text + return (Max $ fi w + padding * 2, Exact $ fi h + padding * 2) + drawI visual = drawing' visual $ \Rectangle{..} d _ -> do + (bef,_) <- gets fieldText + text <- gets fieldValue + (befw, _) <- back $ textExtents (font visual) bef + (w, h) <- back $ textExtents (font visual) text + let width = liftM snd . textExtents (font visual) + text' <- if w <= fi rectWidth then return text + else do fits <- back $ filterM (liftM (<= fi rectWidth) . width) + $ tails $ reverse text + case fits of + [] -> return "" + (t:_) -> return $ reverse t + back $ drawText (drawerFgColor d) (drawerFont d) + (rectX+padding) (rectY+padding) + (rectHeight - padding*2) text' + when (padding+befw <= fi rectWidth) $ + io $ fg d drawLine (fi rectX+padding+fi befw) (fi rectY+padding) + (fi rectX+padding+fi befw) (fi rectY+padding+fi h) +mkTextField _ _ = error "TextFields do not have children" -editorCommands :: M.Map Chord (ObjectM TextField SindreX11M ()) -editorCommands = M.fromList +editorCommands :: X11Field TextField T.Text + -> M.Map Chord (ObjectM TextField SindreX11M ()) +editorCommands value = M.fromList [ (chord [] "Right", moveForward $ splitAt 1) , (chord [Control] 'f', moveForward $ splitAt 1) , (chord [] "Left", moveBackward $ splitAt 1) @@ -896,50 +908,12 @@ moveBackward f = modify $ \s -> let ((pre, post), aft) = first f $ fieldText s in s { fieldText = (post, reverse pre ++ aft) } - delBackward delf = changeFields [("value", unmold . fieldValue)] - $ \s -> do + delBackward delf = changingField value $ do fullRedraw - return s { fieldText = first delf $ fieldText s } - delForward delf = changeFields [("value", unmold . fieldValue)] - $ \s -> do + modify $ \s -> s { fieldText = first delf $ fieldText s } + delForward delf = changingField value $ do fullRedraw - return s { fieldText = second delf $ fieldText s } - -instance Widget SindreX11M TextField where - composeI = do - font <- gets (font . fieldVisual) - text <- gets fieldValue - (w,h) <- back $ textExtents font text - return (Max $ fi w + padding * 2, Exact $ fi h + padding * 2) - drawI = drawing' fieldVisual $ \Rectangle{..} d _ -> do - (bef,_) <- gets fieldText - text <- gets fieldValue - font <- gets (font . fieldVisual) - (befw, _) <- back $ textExtents font bef - (w, h) <- back $ textExtents font text - let width = liftM snd . textExtents font - text' <- if w <= fi rectWidth then return text - else do fits <- back $ filterM (liftM (<= fi rectWidth) . width) - $ tails $ reverse text - case fits of - [] -> return "" - (t:_) -> return $ reverse t - back $ drawText (drawerFgColor d) (drawerFont d) - (rectX+padding) (rectY+padding) - (rectHeight - padding*2) text' - when (padding+befw <= fi rectWidth) $ - io $ fg d drawLine (fi rectX+padding+fi befw) (fi rectY+padding) - (fi rectX+padding+fi befw) (fi rectY+padding+fi h) - --- | Single-line text field, whose single field @value@ (also a --- parameter, defaults to the empty string) is the contents of the --- editing buffer. -mkTextField :: Constructor SindreX11M -mkTextField r [] = do - v <- param "value" <|> return "" - visual <- visualOpts r - return $ NewWidget $ TextField ("",v) visual -mkTextField _ _ = error "TextFields do not have children" + modify $ \s -> s { fieldText = second delf $ fieldText s } data ListElem = ListElem { showAs :: FormatString , valueOf :: T.Text @@ -1022,7 +996,7 @@ lineElems rdf r l = elemLine l $ rdf r where elemLine [] _ = return ([], []) elemLine es@(e:es') room = do - r' <- elemRect e + r' <- join $ gets listElemSize <*> pure e if room >= rdf r' then do (es'', rest) <- elemLine es' $ room-rdf r' return ((e,r'):es'', rest) else return ([], es) @@ -1031,20 +1005,11 @@ fromElems ([], rest) = NavList [] Nothing rest fromElems (x:xs, rest) = NavList [] (Just ([], x, xs)) rest -elemRect :: ListElem -> ObjectM List SindreX11M Rectangle -elemRect e = do font <- gets (font . listVisual) - back $ fmtSize font (showAs e) - data List = List { listElems :: [ListElem] , listFilter :: T.Text , listLine :: NavList - , listVisual :: VisualOpts - , listCompose :: ObjectM List SindreX11M SpaceNeed - , listDraw :: Rectangle - -> ObjectM List SindreX11M SpaceUse + , listElemSize :: ListElem -> ObjectM List SindreX11M Rectangle , listFilterF :: T.Text -> [ListElem] -> [ListElem] - , listUsableRect :: Rectangle - -> ObjectM List SindreX11M Rectangle , listSize :: Rectangle , listDim :: Rectangle -> Integer } @@ -1053,88 +1018,92 @@ listFiltered List { listLine = l } = reverse (linePrev l) ++ contents l ++ lineNext l -selection :: List -> Value -selection l = maybe falsity f $ lineContents $ listLine l - where f (_,(c,_),_) = StringV $ valueOf c +selection :: List -> Maybe T.Text +selection l = liftM f $ lineContents $ listLine l + where f (_,(c,_),_) = valueOf c refilter :: T.Text -> [ListElem] -> [ListElem] refilter f = sortMatches filterBy (T.toCaseFold f) -methInsert :: T.Text -> ObjectM List SindreX11M () -methInsert vs = changeFields [("selected", selection)] $ \s -> do +methInsert :: X11Field List (Maybe T.Text) + -> T.Text -> ObjectM List SindreX11M () +methInsert sel vs = changingField sel $ do + s <- get let v = listFilterF s (listFilter s) $ listFiltered s ++ elems p l = selected l == selected (listLine s) more = lineElems (listDim s) (listSize s) line <- fromElems <$> more v line' <- moveUntil listNext p more line - fullRedraw >> return s { listElems = listElems s ++ elems - , listLine = fromMaybe line line' } + fullRedraw >> put s { listElems = listElems s ++ elems + , listLine = fromMaybe line line' } where elems = map parseListElem $ T.lines vs -methClear :: ObjectM List SindreX11M () -methClear = do +methClear :: X11Field List (Maybe T.Text) + -> ObjectM List SindreX11M () +methClear sel = changingField sel $ do modify $ \s -> s { listElems = [] , listLine = NavList [] Nothing [] } fullRedraw -methFilter :: String -> ObjectM List SindreX11M () -methFilter f = - changeFields [("selected", selection)] $ \s -> do +methFilter :: X11Field List (Maybe T.Text) -> String + -> ObjectM List SindreX11M () +methFilter sel f = + changingField sel $ do + s <- get let v = listFilterF s f' $ if listFilter s `T.isPrefixOf` f' then listFiltered s else listElems s line <- fromElems <$> lineElems (listDim s) (listSize s) v - redraw >> return s { listFilter = f', listLine = line } + redraw >> put s { listFilter = f', listLine = line } where f' = T.pack f -methMove :: (([ListElem] -> ObjectM List SindreX11M +methMove :: X11Field List (Maybe T.Text) + -> (([ListElem] -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])) -> NavList -> ObjectM List SindreX11M (Maybe NavList)) -> ObjectM List SindreX11M Bool -methMove f = do +methMove sel f = do dimf <- gets listDim rect <- gets listSize l <- f (lineElems dimf rect) =<< gets listLine case l of Nothing -> return False Just l' -> do - changeFields [("selected", selection)] $ \s -> do + changingField sel $ do redraw - return s { listLine = l' } + modify $ \s -> s { listLine = l' } return True -instance Object SindreX11M List where - fieldSetI _ _ = return $ Number 0 - fieldGetI "selected" = selection <$> get - fieldGetI "elements" = Dict <$> M.fromList <$> - zip (map Number [1..]) <$> - map (unmold . showAs) <$> listFiltered <$> get - fieldGetI _ = return $ Number 0 - callMethodI "insert" = function methInsert - callMethodI "clear" = function methClear - callMethodI "filter" = function methFilter - callMethodI "next" = function $ methMove listNext - callMethodI "prev" = function $ methMove listPrev - callMethodI "first" = function $ methMove listFirst - callMethodI "last" = function $ methMove listLast - callMethodI m = fail $ "Unknown method '" ++ m ++ "'" - -instance Widget SindreX11M List where - composeI = join $ gets listCompose - drawI r = do l <- get - r' <- listUsableRect l r - when (r' /= listSize l) $ do - line <- lineElems (listDim l) r' $ listFiltered l - modify $ \s -> s { listSize = r', listLine = fromElems line } - listDraw l r - -mkList :: ObjectM List SindreX11M SpaceNeed - -> (Rectangle -> ObjectM List SindreX11M SpaceUse) +mkList :: (VisualOpts -> ObjectM List SindreX11M SpaceNeed) + -> (VisualOpts -> Rectangle -> ObjectM List SindreX11M SpaceUse) -> (Rectangle -> Integer) - -> (Rectangle -> ObjectM List SindreX11M Rectangle) + -> (VisualOpts -> Rectangle -> ObjectM List SindreX11M Rectangle) -> Constructor SindreX11M -mkList cf df dim uf r [] = do - visual <- visualOpts r - return $ NewWidget $ List [] T.empty (NavList [] Nothing []) - visual cf df refilter uf mempty dim +mkList cf df dim uf wr [] = do + visual <- visualOpts wr + return $ newWidget (List [] T.empty (NavList [] Nothing []) + (elemSize visual) refilter mempty dim) + methods [field sel, field elements] + (const $ return ()) (composeI visual) (drawI visual) + where methods = M.fromList [ ("insert", function $ methInsert sel) + , ("clear", function $ methClear sel) + , ("filter", function $ methFilter sel) + , ("next", function $ methMove sel listNext) + , ("prev", function $ methMove sel listPrev) + , ("first", function $ methMove sel listFirst) + , ("last", function $ methMove sel listLast)] + sel = ReadOnlyField "selected" $ gets selection + elements = ReadOnlyField "elements" $ Dict <$> M.fromList <$> + zip (map Number [1..]) <$> map (unmold . showAs) <$> + gets listFiltered + composeI = cf + drawI visual r = do + l <- get + r' <- uf visual r + when (r' /= listSize l) $ do + line <- lineElems (listDim l) r' $ listFiltered l + modify $ \s -> s { listSize = r', listLine = fromElems line } + df visual r + elemSize visual = back . fmtSize (font visual) . showAs + mkList _ _ _ _ _ _ = error "Lists do not have children" -- | Horizontal dmenu-style list containing a list of elements, one of @@ -1144,7 +1113,7 @@ -- -- [@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@. @@ -1160,20 +1129,18 @@ -- The field @selected@ is the selected element. mkHList :: Constructor SindreX11M mkHList = mkList composeHoriz drawHoriz rectWidth usable - where composeHoriz = - ((Unlimited,) . Exact . Xft.height) <$> gets (font . listVisual) + where composeHoriz = return . (Unlimited,) . Exact . Xft.height . font prestr = "< " aftstr = "> " - usable r = do font <- gets (font . listVisual) - (w1, _) <- back $ textExtents font prestr - (w2, _) <- back $ textExtents font aftstr - return r { rectWidth = rectWidth r - fi w1 - fi w2 } + usable visual r = do + (w1, _) <- back $ textExtents (font visual) prestr + (w2, _) <- back $ textExtents (font visual) aftstr + return r { rectWidth = rectWidth r - fi w1 - fi w2 } - drawHoriz = drawing' listVisual $ \r d fd -> do - font <- gets (font . listVisual) - (prestrw,_) <- back $ textExtents font prestr + drawHoriz visual = drawing' visual $ \r d fd -> do + (prestrw,_) <- back $ textExtents (font visual) prestr let (x,y,w,h) = ( fi $ rectX r, rectY r , fi $ rectWidth r, rectHeight r) drawElem d' x' (e,r') = back $ do @@ -1189,7 +1156,7 @@ x'' <- drawElem fd x' cur foldM_ (drawElem d) x'' aft unless (null $ lineNext line) $ back $ do - (aftw,_) <- textExtents font aftstr + (aftw,_) <- textExtents (font visual) aftstr drawText (drawerFgColor d) (drawerFont d) (x + w - aftw) y h aftstr Nothing -> return () @@ -1199,12 +1166,11 @@ mkVList :: Constructor SindreX11M mkVList k cs = do n <- param "lines" <|> return 10 - mkList (composeVert n) drawVert rectHeight return k cs - where composeVert n = do font <- gets (font . listVisual) - return ( Unlimited, - Exact $ (Xft.height font + 2*padding) * n) + mkList (composeVert n) drawVert rectHeight (const return) k cs + where composeVert n visual = + return (Unlimited, Exact $ (Xft.height (font visual) + 2*padding) * n) - drawVert = drawing' listVisual $ \r d fd -> do + drawVert visual = drawing' visual $ \r d fd -> do let fr y r' = r { rectY = y, rectHeight = rectHeight r' } drawElem d' y (e, r') = do drawFmt d' (fr y r') $ showAs e diff --git a/sindre.cabal b/sindre.cabal --- a/sindre.cabal +++ b/sindre.cabal @@ -1,5 +1,5 @@ name: sindre -version: 0.3 +version: 0.4 homepage: http://sigkill.dk/programs/sindre synopsis: A programming language for simple GUIs description: @@ -38,7 +38,7 @@ text, bytestring, unix, attoparsec>=0.10, permute, utf8-string>=0.3 - ghc-options: -funbox-strict-fields -Wall + ghc-options: -Wall ghc-prof-options: -prof -auto-all -rtsopts pkgconfig-depends: xft