sindre 0.3 → 0.4
raw patch · 5 files changed
+460/−383 lines, 5 files
Files
- Sindre/Compiler.hs +19/−32
- Sindre/Runtime.hs +191/−83
- Sindre/Widgets.hs +39/−23
- Sindre/X11.hs +209/−243
- sindre.cabal +2/−2
Sindre/Compiler.hs view
@@ -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'.
Sindre/Runtime.hs view
@@ -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))
Sindre/Widgets.hs view
@@ -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.
Sindre/X11.hs view
@@ -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
sindre.cabal view
@@ -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