sindre (empty) → 0.1
raw patch · 33 files changed
+5666/−0 lines, 33 filesdep +X11dep +X11-rmdep +X11-xshapebuild-type:Customsetup-changed
Dependencies added: X11, X11-rm, X11-xshape, array, attoparsec-text, base, bytestring, containers, mtl, parsec, permute, process, regex-pcre, setlocale, text, unix, utf8-string, x11-xim
Files
- .gitignore +3/−0
- Graphics/X11/Xft.hsc +596/−0
- LICENSE +22/−0
- Main.hs +22/−0
- README +25/−0
- Setup.hs +60/−0
- Sindre/ANSI.hs +151/−0
- Sindre/Compiler.hs +707/−0
- Sindre/Formatting.hs +100/−0
- Sindre/KeyVal.hs +71/−0
- Sindre/Lib.hs +152/−0
- Sindre/Main.hs +198/−0
- Sindre/Parser.hs +417/−0
- Sindre/Runtime.hs +463/−0
- Sindre/Sindre.hs +464/−0
- Sindre/Util.hs +98/−0
- Sindre/Widgets.hs +98/−0
- Sindre/X11.hs +1228/−0
- examples/askpass +15/−0
- examples/dial +14/−0
- examples/dials.sindre +26/−0
- examples/dock +16/−0
- examples/fan +21/−0
- examples/filesel +73/−0
- examples/sinmenu_patches/README +2/−0
- examples/sinmenu_patches/sinmenu_incremental +3/−0
- examples/sinmenu_patches/sinmenu_multiselect +15/−0
- examples/suggest +41/−0
- sindre.1 +212/−0
- sindre.cabal +69/−0
- sinmenu +61/−0
- sinmenu.1 +71/−0
- tests/Properties.hs +152/−0
+ .gitignore view
@@ -0,0 +1,3 @@+dist+*.hi+*.o
+ Graphics/X11/Xft.hsc view
@@ -0,0 +1,596 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.X11.Xft+--+-- Stability : provisional+-- Portability : portable+--+-- Interface to the Xft library based on the @X11-xft@ binding by+-- Clemens Fruhwirth. This library builds upon the X11 binding to+-- Xlib ("Graphics.X11") and cannot be used with any other. A tiny+-- part of Xrender is also exposed, as no Haskell interface exists as+-- of this writing.+--+-- The spirit of this binding is to hide away the fact that the+-- underlying implementation is accessed via the FFI, and create a+-- Haskell-like interface that does not expose many artifacts of the C+-- implementation. To that end, the only numeric types exposed are+-- high-level (no 'CInt's), and facilities for integrating resource+-- cleanup with the Haskell garbage collector have been defined (see+-- 'XftMgr').+--+-- Another priority has been robustness. Many naively written FFI+-- bindings to not properly check the return values of the C functions+-- they call. In particular, null pointers are often assumed to never+-- exist, and oftentimes impossible to check by the user as the+-- underlying pointer is not visible across the module boundary. In+-- this binding, any Xft function that can return null has been+-- translated into a Haskell function that returns a 'Maybe' value.+--+-- Two kinds of allocator functions are provided: some that use the+-- nomenclature @new@ and some that uses @open@ (for example+-- 'newColorName' versus 'openColorName'). The former require that+-- you explicitly call the corresponding deallocator ('freeColor' in+-- this case), while the latter takes an 'XftMgr' as an additional+-- argument, and automatically calls the deallocator when the value is+-- garbage-collected. It is an error to call a deallocator on an+-- automatically managed value.+--+-----------------------------------------------------------------------------+module Graphics.X11.Xft+ ( -- * Xft management+ XftMgr (mgrDisplay, mgrScreen)+ , newXftMgr+ , freeXftMgr+ -- * Color handling+ , Color+ , pixel+ , newColorName+ , newColorValue+ , freeColor+ , openColorName+ , openColorValue+ -- * Drawable handling+ , Draw+ , display+ , colormap+ , visual+ , drawable+ , changeDraw+ , newDraw+ , newDrawBitmap+ , newDrawAlpha+ , freeDraw+ , openDraw+ , openDrawBitmap+ , openDrawAlpha+ -- * Font handling+ , Font+ , ascent+ , descent+ , height+ , maxAdvanceWidth+ , newFontName+ , newFontXlfd+ , freeFont+ , openFontName+ , openFontXlfd+ , lockFace+ , unlockFace+ -- * Drawing+ , textExtents+ , textWidth+ , textHeight+ , drawString+ , drawGlyphs+ , drawRect+ -- * XRender bits+ , RenderColor(..)+ , GlyphInfo(..)+ )+ where++import qualified Graphics.X11 as X11++import Codec.Binary.UTF8.String as UTF8++import Control.Exception+import Control.Monad+import Data.IORef+import qualified Data.Map as M++import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Utils+import Foreign.Storable+import Data.Int+import Data.Word++import System.IO+import System.IO.Unsafe+import System.Mem.Weak++#include <X11/Xft/Xft.h>+#include <X11/extensions/Xrender.h>++-- | An 'IORef' containing a map from keys to finalizers. The idea is+-- that the finalizers remove themselves from this store, and if the+-- store (or whatever owns it) is closed before the finalizers have+-- been run, they will be run immediately. This combines the+-- ease-of-use of automatic cleanup via finalizers, with the common+-- requirement that some set of objects has been closed at a specific+-- time.+type ObjectStore k = IORef (M.Map k (IO ()))++insertObj :: Ord k => ObjectStore k -> k -> IO () -> IO ()+insertObj ref k v = atomicModifyIORef ref $ \s -> (M.insert k v s, ())++deleteObj :: Ord k => ObjectStore k -> k -> IO ()+deleteObj ref k = atomicModifyIORef ref $ \s -> (k `M.delete` s, ())++-- | A central staging point for Xft object creation. All Xft object+-- creation functions take as argument an 'XftMgr' value that keeps+-- track of lifetime information. You are required to manually free+-- the 'XftMgr' via 'freeXftMgr' when you are done with it.+data XftMgr = XftMgr+ { mgrDisplay :: X11.Display+ , mgrScreen :: X11.Screen+ , xftLock :: IO ()+ , xftUnlock :: IO ()+ , xftObjs :: ObjectStore IntPtr+ }++-- | Create an 'XftMgr' whose objects will be used on the given screen+-- and display. As Xlib is not re-entrant, a synchronisation+-- mechanism must be used, so the 'XftMgr' includes actions for+-- obtaining and releasing atomic access to the display via two 'IO'+-- actions. These will be executed before and after objects allocated+-- via the manager are released. It is recommended to use an+-- 'Control.Concurrent.MVar' to implement a mutex for synchronising+-- the access, but if you are absolutely certain that there will not+-- be any concurrent attempts to access the display, the actions can+-- merely be @return ()@.+newXftMgr :: X11.Display -> X11.Screen+ -> IO () -- ^ Executed before deallocations.+ -> IO () -- ^ Executed after deallocations.+ -> IO XftMgr+newXftMgr dpy scr lock unlock = do+ os <- newIORef M.empty+ return XftMgr { mgrDisplay = dpy+ , mgrScreen = scr+ , xftLock = lock+ , xftUnlock = unlock+ , xftObjs = os+ }++-- | Free the manager and reclaim any objects associated with it.+-- After an 'XftMgr' has been freed, it is invalid to use any objects+-- created through it. The lock must currently be held by the thread+-- calling 'freeXftMgr', and it will be repeatedly released and+-- reacquired throughout deallocating any remaining objects in the+-- manager. When the command returns, the lock will once again be+-- held.+freeXftMgr :: XftMgr -> IO ()+freeXftMgr mgr = withoutLock $ finalizeObjs xftObjs+ where getobjs s = (M.empty, M.elems s)+ withoutLock = bracket_ (xftUnlock mgr) (xftLock mgr)+ finalizeObjs f = sequence_ =<< atomicModifyIORef (f mgr) getobjs++openAny :: Ord k =>+ XftMgr -> (XftMgr -> ObjectStore k)+ -> (a -> IO ()) -> k -> a -> IO a+openAny mgr field close key obj = do+ let finalizer = bracket_ (xftLock mgr) (xftUnlock mgr) $ do+ deleteObj (field mgr) key+ close obj+ obj' <- mkWeak obj (obj, finalizer) (Just finalizer)+ insertObj (field mgr) key (finalize obj')+ return obj++openAnyWith :: Ord k => XftMgr -> (XftMgr -> ObjectStore k)+ -> (c -> IO (Maybe a)) -> (a -> IO ()) -> (a -> IO k) -> c+ -> IO (Maybe a)+openAnyWith mgr field open close keyf v = do+ obj <- open v+ case obj of Nothing -> return Nothing+ Just obj' -> do key <- keyf obj'+ key `seq` Just `fmap` openAny mgr field close key obj'++-- | An Xft colour.+newtype Color = Color (Ptr Color)++foreign import ccall "XftColorAllocName"+ xftColorAllocName :: X11.Display -> X11.Visual -> X11.Colormap+ -> CString -> Color -> IO (#type Bool)++foreign import ccall "XftColorAllocValue"+ xftColorAllocValue :: X11.Display -> X11.Visual -> X11.Colormap+ -> (Ptr RenderColor) -> Color -> IO (#type Bool)++foreign import ccall "XftColorFree"+ xftColorFree :: X11.Display -> X11.Visual -> X11.Colormap -> Color -> IO ()++-- | The core X11 colour contained in an Xft colour.+pixel :: Color -> X11.Pixel+pixel (Color ptr) = fi $ unsafePerformIO $+ peekCULong ptr #{offset XftColor, pixel}++-- | Create a new Xft colour based on a name. The name may be either+-- a human-readable colour such as "red", "white" or "darkslategray"+-- (all core X colour names are supported) or a hexidecimal name such+-- as "#A9E2AF". Names are not case-sensitive. Returns 'Nothing' if+-- the given name is not recognised as a colour.+newColorName :: X11.Display -> X11.Visual -> X11.Colormap -> String+ -> IO (Maybe Color)+newColorName dpy v cm name = do+ ptr <- mallocBytes (#size XftColor)+ withCAString name $ \name' -> do+ b <- xftColorAllocName dpy v cm name' $ Color ptr+ if b /= 0 then return $ Just $ Color ptr+ else free ptr >> return Nothing++-- | As 'newColorName', but instead of a name, an XRender color value+-- is used.+newColorValue :: X11.Display -> X11.Visual -> X11.Colormap -> RenderColor+ -> IO (Maybe Color)+newColorValue dpy v cm rc = do+ ptr <- mallocBytes (#size XftColor)+ with rc $ \rc' -> do+ b <- xftColorAllocValue dpy v cm rc' $ Color ptr+ if b /= 0 then return $ Just $ Color ptr+ else free ptr >> return Nothing++-- | Free a colour that has been allocated with 'newColorName' or 'newColorValue'.+freeColor :: X11.Display -> X11.Visual -> X11.Colormap -> Color -> IO ()+freeColor dpy v cm col@(Color ptr) = do+ xftColorFree dpy v cm col+ free ptr++-- | As 'newColorName', but automatically freed through the given Xft+-- manager when no longer accessible.+openColorName :: XftMgr -> X11.Visual -> X11.Colormap -> String+ -> IO (Maybe Color)+openColorName mgr vis cm =+ openAnyWith mgr xftObjs open close (\(Color ptr) -> return $ ptrToIntPtr ptr)+ where open = newColorName (mgrDisplay mgr) vis cm+ close = freeColor (mgrDisplay mgr) vis cm++-- | As 'newColorValue', but automatically freed through the given Xft+-- manager when no longer accessible.+openColorValue :: XftMgr -> X11.Visual -> X11.Colormap -> RenderColor+ -> IO (Maybe Color)+openColorValue mgr vis cm =+ openAnyWith mgr xftObjs open close (\(Color ptr) -> return $ ptrToIntPtr ptr)+ where open = newColorValue (mgrDisplay mgr) vis cm+ close = freeColor (mgrDisplay mgr) vis cm++-- | An Xft drawable.+newtype Draw = Draw (Ptr Draw)++foreign import ccall "XftDrawCreate"+ xftDrawCreate :: X11.Display -> X11.Drawable -> X11.Visual -> X11.Colormap -> IO Draw++foreign import ccall "XftDrawCreateBitmap"+ xftDrawCreateBitmap :: X11.Display -> X11.Pixmap -> IO Draw++foreign import ccall "XftDrawCreateAlpha"+ xftDrawCreateAlpha :: X11.Display -> X11.Pixmap -> CInt -> IO Draw++foreign import ccall "XftDrawChange"+ xftDrawChange :: Draw -> X11.Drawable -> IO ()++foreign import ccall "XftDrawDisplay"+ xftDrawDisplay :: Draw -> IO X11.Display -- FIXME correct? Is X11 giving us the underlying Display?++foreign import ccall "XftDrawDrawable"+ xftDrawDrawable :: Draw -> IO X11.Drawable++foreign import ccall "XftDrawColormap"+ xftDrawColormap :: Draw -> IO X11.Colormap++foreign import ccall "XftDrawVisual"+ xftDrawVisual :: Draw -> IO X11.Visual++foreign import ccall "XftDrawDestroy"+ xftDrawDestroy :: Draw -> IO ()++-- | The display for the Xft drawable.+display :: Draw -> X11.Display+display = unsafePerformIO . xftDrawDisplay++-- | The colormap for the Xft drawable.+colormap :: Draw -> X11.Colormap+colormap = unsafePerformIO . xftDrawColormap++-- | The visual for the Xft drawable.+visual :: Draw -> X11.Visual+visual = unsafePerformIO . xftDrawVisual++-- | The X11 drawable underlying the Xft drawable.+drawable :: Draw -> X11.Drawable+drawable = unsafePerformIO . xftDrawDrawable++-- | Create a new Xft drawable on the given display, using the+-- provided 'X11.Drawable' to draw on. Will return 'Nothing' if the+-- call to @XftDrawCreate@ fails, which it will usually only do if+-- memory cannot be allocated. The 'Draw' has to be manually freed+-- with 'freeDraw' once you are done with it.+newDraw :: X11.Display -> X11.Drawable -> X11.Visual -> X11.Colormap+ -> IO (Maybe Draw)+newDraw dpy drw vis cm = do+ Draw ptr <- xftDrawCreate dpy drw vis cm+ if ptr == nullPtr then return Nothing+ else return $ Just $ Draw ptr++-- | Behaves as 'newDraw', except that it uses a 'X11.Pixmap' of color+-- depth 1 instead of a 'X11.Drawable'.+newDrawBitmap :: X11.Display -> X11.Pixmap -> IO (Maybe Draw)+newDrawBitmap dpy pm = do+ Draw ptr <- xftDrawCreateBitmap dpy pm+ if ptr == nullPtr then return Nothing+ else return $ Just $ Draw ptr++-- | Behaves as 'newDraw', except that it uses a 'X11.Pixmap' of the given depth+-- instead of a 'X11.Drawable'.+newDrawAlpha :: Integral a => X11.Display -> X11.Pixmap -> a -> IO (Maybe Draw)+newDrawAlpha dpy pm k = do+ Draw ptr <- xftDrawCreateAlpha dpy pm $ fi k+ if ptr == nullPtr then return Nothing+ else return $ Just $ Draw ptr++-- | Free a 'Draw' created with 'newDraw'. Do not free 'Draw's+-- created with 'openDraw', these are automatically managed.+freeDraw :: Draw -> IO ()+freeDraw = xftDrawDestroy++-- | Change the X11 drawable underlying the Xft drawable.+changeDraw :: Draw -> X11.Drawable -> IO ()+changeDraw = xftDrawChange++-- | As 'newDraw', but automatically freed when no longer used.+openDraw :: XftMgr -> X11.Drawable -> X11.Visual -> X11.Colormap+ -> IO (Maybe Draw)+openDraw mgr drw vis =+ openAnyWith mgr xftObjs open close (\(Draw ptr) -> return $ ptrToIntPtr ptr)+ where open = newDraw (mgrDisplay mgr) drw vis+ close = freeDraw++-- | As 'newDrawBitmap', but automatically freed when no longer used.+openDrawBitmap :: XftMgr -> X11.Drawable -> IO (Maybe Draw)+openDrawBitmap mgr =+ openAnyWith mgr xftObjs open close (\(Draw ptr) -> return $ ptrToIntPtr ptr)+ where open = newDrawBitmap (mgrDisplay mgr)+ close = freeDraw++-- | As 'newDrawBitmap', but automatically freed when no longer used.+openDrawAlpha :: Integral a => XftMgr -> X11.Drawable -> a -> IO (Maybe Draw)+openDrawAlpha mgr drw =+ openAnyWith mgr xftObjs open close (\(Draw ptr) -> return $ ptrToIntPtr ptr)+ where open = newDrawAlpha (mgrDisplay mgr) drw+ close = freeDraw++-- | An Xft font.+newtype Font = Font (Ptr Font)++foreign import ccall "XftFontOpenName"+ xftFontOpenName :: X11.Display -> CInt -> CString -> IO Font++foreign import ccall "XftFontOpenXlfd"+ xftFontOpenXlfd :: X11.Display -> CInt -> CString -> IO Font++foreign import ccall "XftLockFace"+ xftLockFace :: Font -> IO () -- FIXME XftLockFace returns FT_face not void++foreign import ccall "XftUnlockFace"+ xftUnlockFace :: Font -> IO ()++foreign import ccall "XftFontClose"+ xftFontClose :: X11.Display -> Font -> IO ()++-- | The ascent (vertical distance upwards from the baseline) of a+-- character in the font.+ascent :: Integral a => Font -> a+ascent (Font p) = fi $ unsafePerformIO $ peekCUShort p #{offset XftFont, ascent}++-- | The descent (vertical distance downwards from the baseline) of a+-- character in the font.+descent :: Integral a => Font -> a+descent (Font p) = fi $ unsafePerformIO $ peekCUShort p #{offset XftFont, descent}++-- | The ascent plus descent of a character in the font.+height :: Integral a => Font -> a+height (Font p) = fi $ unsafePerformIO $ peekCUShort p #{offset XftFont, height}++-- | The greatest horizontal width of a character in the font.+maxAdvanceWidth :: Integral a => Font -> a+maxAdvanceWidth (Font p) = fi $ unsafePerformIO $ peekCUShort p #{offset XftFont, height}++-- | @newFontName dpy scr s@, where @s@ is a Fontconfig pattern+-- string, finds the best match for @s@ and returns a font that can be+-- used to draw on the given screen. This function very rarely+-- returns 'Nothing', and seems to return some default font even if+-- you feed it utter garbage (or an empty string).+newFontName :: X11.Display -> X11.Screen -> String -> IO (Maybe Font)+newFontName dpy screen fontname =+ withCAString fontname $ \fontname' -> do+ Font ptr <- xftFontOpenName dpy+ (fi (X11.screenNumberOfScreen screen)) fontname'+ if ptr == nullPtr then return Nothing else return $ Just $ Font ptr++-- | As 'newFontName', except that the name should be an X Logical+-- Font Description (the usual fourteen elements produced by+-- @xfontsel@).+newFontXlfd :: X11.Display -> X11.Screen -> String -> IO (Maybe Font)+newFontXlfd dpy screen xlfd =+ withCAString xlfd $ \xlfd' -> do+ Font ptr <- xftFontOpenXlfd dpy+ (fi (X11.screenNumberOfScreen screen)) xlfd'+ if ptr == nullPtr then return Nothing else return $ Just $ Font ptr++-- | Close the given Xft font.+freeFont :: X11.Display -> Font -> IO ()+freeFont = xftFontClose++-- | As 'newFontName', but automatically freed when no longer used.+openFontName :: XftMgr -> String -> IO (Maybe Font)+openFontName mgr =+ openAnyWith mgr xftObjs open close (\(Font ptr) -> return $ ptrToIntPtr ptr)+ where open = newFontName (mgrDisplay mgr) (mgrScreen mgr)+ close = freeFont (mgrDisplay mgr)++-- | As 'newFontXfld', but automatically freed when no longer used.+openFontXlfd :: XftMgr -> String -> IO (Maybe Font)+openFontXlfd mgr =+ openAnyWith mgr xftObjs open close (\(Font ptr) -> return $ ptrToIntPtr ptr)+ where open = newFontXlfd (mgrDisplay mgr) (mgrScreen mgr)+ close = freeFont (mgrDisplay mgr)++-- | Lock the file underlying the Xft font. I am not certain when you+-- would need this. The return value is supposed to be an @FT_TYPE@+-- from Freetype, but that binding has not been written yet.+lockFace :: Font -> IO ()+lockFace font = xftLockFace font >> return ()++-- | Unlock a face locked by 'lockFontFace'.+unlockFace :: Font -> IO ()+unlockFace = xftUnlockFace++foreign import ccall "XftTextExtentsUtf8"+ xftTextExtentsUtf8 :: X11.Display -> Font -> CString -> CInt -> Ptr GlyphInfo -> IO ()++-- | Note that the 'glyphWidth'/'glyphHeight' fields are the number of+-- pixels you should advance after drawing a string of this size.+textExtents :: X11.Display -> Font -> String -> IO GlyphInfo+textExtents dpy font s =+ withArrayLen (map fi (UTF8.encode s)) $ \n s' ->+ alloca $ \cglyph -> do+ xftTextExtentsUtf8 dpy font s' (fi n) cglyph+ peek cglyph++-- | Shortcut for calling 'textExtents' and picking out the+-- 'glyphWidth' field of the 'GlyphInfo'.+textWidth :: Integral a => X11.Display -> Font -> String -> IO a+textWidth dpy f = liftM (fi . glyphWidth) . textExtents dpy f++-- | Shortcut for calling 'textExtents' and picking out the+-- 'glyphHeight' field of the 'GlyphInfo'.+textHeight :: Integral a => X11.Display -> Font -> String -> IO a+textHeight dpy f = liftM (fi . glyphHeight) . textExtents dpy f++foreign import ccall "XftDrawGlyphs"+ xftDrawGlyphs :: Draw -> Color -> Font -> CInt -> CInt -> Ptr (Word32) -> CInt -> IO ()++-- | Draw a sequence of glyphs on the given drawable in the specified+-- colour and font. Drawing begins at the baseline of the string.+drawGlyphs :: (Integral x, Integral y, Integral c) => Draw -> Color -> Font ->+ x -> y -> [c] -> IO ()+drawGlyphs drw col font x y s =+ withArrayLen (map fi s) $ \len s' ->+ xftDrawGlyphs drw col font (fi x) (fi y) s' (fi len)++foreign import ccall "XftDrawStringUtf8"+ xftDrawStringUtf8 :: Draw -> Color -> Font -> CInt -> CInt -> Ptr (Word8) -> CInt -> IO ()++-- | Draw a string on the given drawable in the specified colour and+-- font. Drawing begins at the baseline of the string.+drawString :: (Integral x, Integral y) => Draw -> Color -> Font ->+ x -> y -> String -> IO ()+drawString drw col font x y s =+ withArrayLen (map fi (UTF8.encode s)) $ \len s' ->+ xftDrawStringUtf8 drw col font (fi x) (fi y) s' (fi len)++foreign import ccall "XftDrawRect"+ xftDrawRect :: Draw -> Color -> CInt -> CInt -> CUInt -> CUInt -> IO ()++-- | @drawRect d c x y w h@ draws a solid rectangle on @d@ with colour+-- @c@, with its upper left corner at @(x,y)@, width @w@ and height+-- @h@.+drawRect :: (Integral x, Integral y, Integral w, Integral h) =>+ Draw -> Color -> x -> y -> w -> h -> IO ()+drawRect d c x y w h = xftDrawRect d c (fi x) (fi y) (fi w) (fi h)++-- | Short-hand for 'fi'.+fi :: (Integral a, Num b) => a -> b+fi = fromIntegral++peekCULong :: Ptr a -> CInt -> IO Int+peekCULong ptr off = do+ v <- peekByteOff ptr (fromIntegral off)+ return (fromIntegral (v::CULong))++peekCUShort :: Ptr a -> CInt -> IO Int+peekCUShort ptr off = do+ v <- peekByteOff ptr (fromIntegral off)+ return (fromIntegral (v::CUShort))++pokeCUShort :: Ptr a -> CInt -> Int -> IO ()+pokeCUShort ptr off v =+ pokeByteOff ptr (fromIntegral off) (fromIntegral v::CUShort)++peekCShort :: Ptr a -> CInt -> IO Int+peekCShort ptr off = do+ v <- peekByteOff ptr (fromIntegral off)+ return (fromIntegral (v::CShort))++pokeCShort :: Ptr a -> CInt -> Int -> IO ()+pokeCShort ptr off v =+ pokeByteOff ptr (fromIntegral off) (fromIntegral v::CShort)++-- | The @XRenderColor@ from the XRender library. Note that the+-- colour channels are only interpreted as 16-bit numbers when+-- actually used.+data RenderColor = RenderColor {+ red :: Int+ , green :: Int+ , blue :: Int+ , alpha :: Int+}++instance Storable RenderColor where+ sizeOf _ = #{size XRenderColor}+ alignment _ = alignment (undefined::CInt)+ peek p = do+ r <- peekCUShort p #{offset XRenderColor, red}+ g <- peekCUShort p #{offset XRenderColor, green}+ b <- peekCUShort p #{offset XRenderColor, blue}+ a <- peekCUShort p #{offset XRenderColor, alpha}+ return (RenderColor r g b a)+ poke p (RenderColor r g b a) = do+ pokeCUShort p #{offset XRenderColor,red} r+ pokeCUShort p #{offset XRenderColor,green} g+ pokeCUShort p #{offset XRenderColor,blue} b+ pokeCUShort p #{offset XRenderColor,alpha} a++-- | The size of some glyph(s). Note that there's a difference+-- between the logical size, which may include some blank pixels, and+-- the actual bitmap.+data GlyphInfo = GlyphInfo {+ glyphImageWidth :: Int+ , glyphImageHeight :: Int+ , glyphImageX :: Int+ , glyphImageY :: Int+ , glyphWidth :: Int+ , glyphHeight :: Int+}++instance Storable GlyphInfo where+ sizeOf _ = #{size XGlyphInfo}+ alignment _ = alignment (undefined::CInt)+ peek p = do+ w <- peekCUShort p #{offset XGlyphInfo, width}+ h <- peekCUShort p #{offset XGlyphInfo, height}+ x <- peekCShort p #{offset XGlyphInfo, x}+ y <- peekCShort p #{offset XGlyphInfo, y}+ xOff <- peekCShort p #{offset XGlyphInfo, xOff}+ yOff <- peekCShort p #{offset XGlyphInfo, yOff}+ return (GlyphInfo w h x y xOff yOff)+ poke p (GlyphInfo w h x y xOff yOff) = do+ pokeCUShort p #{offset XGlyphInfo, width} w+ pokeCUShort p #{offset XGlyphInfo, height} h+ pokeCShort p #{offset XGlyphInfo, x} x+ pokeCShort p #{offset XGlyphInfo, y} y+ pokeCShort p #{offset XGlyphInfo, xOff} xOff+ pokeCShort p #{offset XGlyphInfo, yOff} yOff
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2010 Troels Henriksen++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Sindre, a programming language for writing simple GUIs+--+-----------------------------------------------------------------------------++module Main(main)+ where++import Sindre.Main++import System.Environment++-- | The main Sindre entry point.+main :: IO ()+main = sindreMain emptyProgram classMap objectMap funcMap globMap =<< getArgs
+ README view
@@ -0,0 +1,25 @@+Sindre - programming language for writing simple GUIs+===++Sindre is a programming language inspired by Awk that makes it easy to+write simple graphical programs in the spirit of dzen, dmenu, xmobar,+gsmenu and the like.++Requirements+---++A relatively modern (GHC >= 7.x) Haskell setup and a number of+libraries available on Hackage. See 'sindre.cabal' for specifics.+Sindre is developed with POSIX systems in mind and may not run (or be+useful) anywhere else.++Installation+---++Just run 'cabal install' and Cabal should build and install Sindre.++Documentation+---++Nothing yet, unfortunately, but check the examples/ directory for+sample code.
+ Setup.hs view
@@ -0,0 +1,60 @@+#!/usr/bin/env runhaskell++import Distribution.Simple.Setup (CopyDest(..),ConfigFlags(..),BuildFlags(..),+ CopyFlags(..),RegisterFlags(..),InstallFlags(..),+ defaultRegisterFlags,fromFlagOrDefault,Flag(..),+ defaultCopyFlags)+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+ (LocalBuildInfo(..),absoluteInstallDirs)+import Distribution.Simple.Configure (configCompilerAux)+import Distribution.PackageDescription (PackageDescription(..))+import Distribution.Simple.InstallDirs+ (InstallDirs(..))+import Distribution.Simple.Program + (Program(..),ConfiguredProgram(..),ProgramConfiguration(..),+ ProgramLocation(..),simpleProgram,lookupProgram,+ rawSystemProgramConf)+import Distribution.Simple.Utils+import Distribution.Verbosity+import Data.Char (isSpace, showLitChar)+import Data.List (isSuffixOf,isPrefixOf)+import Data.Maybe (listToMaybe,isJust)+import Data.Version+import Control.Monad (when,unless)+import Text.ParserCombinators.ReadP (readP_to_S)+import System.Exit+import System.IO (hGetContents,hClose,hPutStr,stderr)+import System.IO.Error (try)+import System.Process (runInteractiveProcess,waitForProcess)+import System.Posix+import System.Directory+import System.Info (os)+import System.FilePath++main = defaultMainWithHooks sindreHooks+sindreHooks = simpleUserHooks { postInst = sindrePostInst+ , postCopy = sindrePostCopy }++sindre = "sindre"++isWindows :: Bool+isWindows = os == "mingw" -- XXX++sindrePostInst a (InstallFlags { installPackageDB = db, installVerbosity = v }) =+ sindrePostCopy a (defaultCopyFlags { copyDest = Flag NoCopyDest, copyVerbosity = v })++sindrePostCopy a (CopyFlags { copyDest = cdf, copyVerbosity = vf }) pd lbi =+ do let v = fromFlagOrDefault normal vf+ cd = fromFlagOrDefault NoCopyDest cdf+ dirs = absoluteInstallDirs pd lbi cd+ bin = combine (bindir dirs)+ unless isWindows $ do+ copyFileVerbose v "sinmenu" (bin "sinmenu")+ fs <- getFileStatus (bin "sindre")+ setFileMode (bin "sinmenu") $ fileMode fs+ putStrLn $ "Installing manpage in " ++ mandir dirs+ createDirectoryIfMissing True $ mandir dirs `combine` "man1"+ copyFileVerbose v "sindre.1" (mandir dirs `combine` "man1" `combine` "sindre.1")+ createDirectoryIfMissing True $ mandir dirs `combine` "man1"+ copyFileVerbose v "sinmenu.1" (mandir dirs `combine` "man1" `combine` "sinmenu.1")
+ Sindre/ANSI.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.ANSI+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : unportable+--+-- ANSI backend for Sindre.+--+-----------------------------------------------------------------------------+module Sindre.ANSI( SindreANSIM+ , sindreANSI+ )+ where++import Sindre.Sindre+import Sindre.Compiler+import Sindre.Lib+import Sindre.Runtime+import Sindre.Util+import Sindre.Widgets++import System.Console.ANSI++import System.Environment+import System.Exit+import System.IO+import System.Posix.Types++import Control.Arrow(first,second)+import Control.Concurrent+import Control.Applicative+import Control.Exception+import Control.Monad.Reader+import Control.Monad.State+import Data.Bits+import Data.Char hiding (Control)+import Data.Maybe+import Data.List+import qualified Data.ByteString as B+import qualified Data.Map as M+import Data.Monoid+import Data.Ord+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as E++import Prelude hiding (catch)+++-- | The read-only configuration of the ANSI backend, created during+-- backend initialisation.+data SindreANSIConf = SindreANSIConf {+ sindreTerminal :: Handle -- ^ Where we're being displayed.+ , sindreVisualOpts :: VisualOpts+ -- ^ The default visual options used if no others are specified for+ -- a widget.+ , sindreEvtVar :: MVar Event+ -- ^ Channel through which events are sent by other threads to the+ -- Sindre command loop.+ }++-- | Sindre backend using ANSI.+newtype SindreANSIM a = SindreANSIM (ReaderT SindreANSIConf (StateT Rectangle IO) a)+ deriving ( Functor, Monad, MonadIO, MonadReader SindreANSIConf+ , MonadState Rectangle, Applicative)++runSindreANSI :: SindreANSIM a -> SindreANSIConf -> Rectangle -> IO a+runSindreANSI (SindreANSIM m) = evalStateT . runReaderT m++instance MonadBackend SindreANSIM where+ type BackEvent SindreANSIM = Char+ type RootPosition SindreANSIM = ()++ redrawRoot = do+ (orient, rootwr) <- gets rootWidget+ reqs <- compose rootwr+ winsize <- back get+ let orient' = fromMaybe () orient+ rect = fitRect winsize reqs+ draw rootwr $ Just rect+ return ()++ redrawRegion _ = return ()+ + waitForBackEvent = do+ evvar <- back $ asks sindreEvtVar+ io $ takeMVar evvar+ + getBackEvent = do+ io yield+ back (io . tryTakeMVar =<< asks sindreEvtVar)++ printVal s = io $ putStr s *> hFlush stdout++setupTerminal :: IO Handle+setupTerminal = do h <- openFile "/dev/tty" ReadWriteMode+ hSetBuffering h NoBuffering+ hSetEcho h False+ return h++getKeypress :: Handle -> IO Chord+getKeypress h = (S.empty,) <$> CharKey <$> hGetChar h++eventReader :: Handle -> MVar Event -> IO ()+eventReader h evvar = forever $ (putMVar evvar . KeyPress) =<< getKeypress h++sindreANSICfg :: IO SindreANSIConf+sindreANSICfg = do+ h <- setupTerminal+ visopts <- defVisualOpts+ evvar <- newEmptyMVar+ xlock <- newMVar ()+ _ <- forkIO $ eventReader h evvar+ return SindreANSIConf { sindreTerminal = h+ , sindreVisualOpts = visopts+ , sindreEvtVar = evvar }++-- | Options regarding visual appearance of widgets (colours and+-- fonts).+data VisualOpts = VisualOpts {+ foreground :: Color+ , background :: Color+ , focusForeground :: Color+ , focusBackground :: Color+ }++defVisualOpts :: IO VisualOpts+defVisualOpts = pure $ VisualOpts Black White White Blue++-- | Execute Sindre in the ANSI backend.+sindreANSI :: SindreANSIM ExitCode+ -- ^ The function returned by+ -- 'Sindre.Compiler.compileSindre' after command line+ -- options have been given+ -> IO ExitCode+sindreANSI start = do+ cfg <- sindreANSICfg+ rows <- read <$> getEnv "LINES"+ cols <- read <$> getEnv "COLUMNS"+ runSindreANSI start cfg $ Rectangle 0 0 rows cols
+ Sindre/Compiler.hs view
@@ -0,0 +1,707 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Compiler+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Transforming a Sindre program into a callable function.+--+-----------------------------------------------------------------------------+module Sindre.Compiler (+ -- * Main Entry Point+ compileSindre,+ ClassMap,+ ObjectMap,+ FuncMap,+ GlobMap,+ -- * Object Construction+ NewWidget(..),+ NewObject(..),+ Constructor,+ ConstructorM,+ Param(..),+ paramM,+ paramAs,+ param,+ noParam,+ badValue,+ -- * Compiler Interface+ + -- | These definitions can be used in builtin functions that may+ -- need to change global variables.+ Compiler,+ value,+ setValue,+ )+ where++import Sindre.Runtime+import Sindre.Sindre+import Sindre.Util++import System.Exit++import Control.Applicative+import Control.Arrow+import Control.Monad.Error+import Control.Monad.RWS.Lazy+import Control.Monad.State+import Data.Array+import Data.Fixed+import Data.List+import Data.Maybe+import Data.Traversable(traverse)+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Text as T++-- | Given a Sindre program and its environment, compile the program+-- and return a pair of command-line options accepted by the program,+-- and a startup function. The program can be executed by calling the+-- startup function with the command-like arguments and an initial+-- value for the root widget. If compilation fails, an IO exception+-- is raised.+compileSindre :: MonadBackend m => Program+ -> ClassMap m -> ObjectMap m -> FuncMap m -> GlobMap m+ -> ([SindreOption], Arguments -> m ExitCode)+compileSindre prog cm om fm gm = (opts, start)+ where (opts, prog', rootw) = compileProgram prog cm om fm gm+ start argv =+ let env = newEnv rootw argv+ in execSindre env prog'++data Binding = Lexical IM.Key | Global GlobalBinding+data GlobalBinding = Constant Value | Mutable IM.Key++-- | Mapping from class names to constructors.+type ClassMap m = M.Map Identifier (Constructor m)+-- | Mapping from object names to object constructor functions.+type ObjectMap m = M.Map Identifier (ObjectRef -> m (NewObject m))+-- | Mapping from function names to built-in functions. These must+-- first be executed in the 'Compiler' monad as they may have specific+-- requirements of the environment.+type FuncMap m = M.Map Identifier (Compiler m ([Value] -> Sindre m Value))+-- | Mapping from names of global variables to computations that yield+-- their initial values.+type GlobMap m = M.Map Identifier (m Value)++data CompilerEnv m = CompilerEnv {+ lexicalScope :: M.Map Identifier IM.Key+ , functionRefs :: M.Map Identifier (Execution m Value)+ , currentPos :: SourcePos+ }++blankCompilerEnv :: CompilerEnv m+blankCompilerEnv = CompilerEnv {+ lexicalScope = M.empty+ , functionRefs = M.empty+ , currentPos = nowhere+ }++data CompilerState m = CompilerState {+ globalScope :: M.Map Identifier GlobalBinding+ , nextMutable :: IM.Key+ }++blankCompilerState :: CompilerState m+blankCompilerState = CompilerState {+ globalScope = M.empty+ , nextMutable = 0+ }++type Initialisation m = Sindre m ()++-- | Monad inside which compilation takes place.+type Compiler m a = RWS (CompilerEnv m) (Initialisation m) (CompilerState m) a++runCompiler :: CompilerEnv m -> Compiler m a -> (a, Initialisation m)+runCompiler env m = evalRWS m env blankCompilerState++descend :: (a -> Compiler m b) -> P a -> Compiler m b+descend m (P p v) = local (\s -> s { currentPos = p }) $ m v++compileError :: String -> Compiler m a+compileError s = do pos <- position <$> asks currentPos+ error $ pos ++ s++runtimeError :: Compiler m (String -> Execution m a)+runtimeError = do pos <- position <$> asks currentPos+ return $ \s -> fail $ pos ++ s++function :: MonadBackend m => Identifier -> Compiler m (Execution m Value)+function k = maybe bad return =<< M.lookup k <$> asks functionRefs+ where bad = compileError $ "Unknown function '"++k++"'"++defName :: MonadBackend m =>+ Identifier -> GlobalBinding -> Compiler m ()+defName k b = do+ known <- M.lookup k <$> gets globalScope+ case known of+ Just _ -> compileError $ "Multiple definitions of '"++k++"'"+ Nothing -> modify $ \s -> s+ { globalScope = M.insert k b $ globalScope s }++defMutable :: MonadBackend m => Identifier -> Compiler m IM.Key+defMutable k = do+ i <- gets nextMutable+ modify $ \s -> s { nextMutable = i + 1 }+ defName k $ Mutable i+ return i++constant :: MonadBackend m => Identifier -> Compiler m Value+constant k = do+ global <- gets globalScope+ case M.lookup k global of+ Just (Constant v) -> return v+ _ -> compileError $ "Unknown constant '"++k++"'"++binding :: MonadBackend m => Identifier -> Compiler m Binding+binding k = do+ lexical <- asks lexicalScope+ global <- gets globalScope+ case M.lookup k lexical of+ Just b -> return $ Lexical b+ Nothing -> case M.lookup k global of+ Just b -> return $ Global b+ Nothing -> Global <$> Mutable <$> defMutable k++-- | Given a variable name, return a computation that will yield the+-- value of the variable when executed.+value :: MonadBackend m => Identifier -> Compiler m (Execution m Value)+value k = do+ bnd <- binding k+ return $ case bnd of+ Lexical k' -> lexicalVal k'+ Global (Mutable k') -> sindre $ globalVal k'+ Global (Constant v) -> return v++-- | Given a variable name, return a computation that can be used to+-- set the value of the variable when executed.+setValue :: MonadBackend m => Identifier -> Compiler m (Value -> Execution m ())+setValue k = do+ bnd <- binding k+ case bnd of+ Lexical k' -> return $ setLexical k'+ Global (Mutable k') -> return $ sindre . setGlobal k'+ Global _ -> compileError $ "Cannot reassign constant '"++k++"'"++compileBackendGlobal :: MonadBackend m => (Identifier, m Value) -> Compiler m ()+compileBackendGlobal (k, v) = do+ k' <- defMutable k+ tell $ setGlobal k' =<< back v++compileGlobal :: MonadBackend m =>+ (Identifier, P Expr) -> Compiler m ()+compileGlobal (k, e) = do+ k' <- defMutable k+ e' <- descend compileExpr e+ tell $ setGlobal k' =<< execute e'++compileOption :: MonadBackend m =>+ (Identifier, (SindreOption, Maybe Value))+ -> Compiler m SindreOption+compileOption (k, (opt, def)) = do+ let defval = fromMaybe falsity def+ k' <- defMutable k+ tell $ do+ v <- M.lookup k <$> gets arguments+ setGlobal k' $ maybe defval string v+ return opt++compileObjs :: MonadBackend m =>+ ObjectNum -> ObjectMap m ->+ Compiler m (InstObjs m)+compileObjs r = zipWithM inst [r..] . M.toList+ where inst r' (k, f) = do+ let ref = (r', k, Just k)+ defName k $ Constant $ Reference ref+ return ((k, ref), f)++compileGUI :: MonadBackend m => ClassMap m -> (Maybe (P Expr), GUI)+ -> Compiler m (ObjectNum, InstGUI m)+compileGUI m (pos, gui) = do+ case pos of+ Nothing -> return ()+ Just re -> do re' <- descend compileExpr re+ tell $ setRootPosition =<< execute re'+ inst 0 gui+ where inst r (GUI k c es cs) = do+ es' <- traverse (descend compileExpr) es+ (lastwr, children) <-+ mapAccumLM (inst . (+1)) (r+length cs) childwrs+ case k of+ Just k' -> defName k' $ Constant $ Reference (lastwr, unP c, k)+ Nothing -> return ()+ c' <- descend (lookupClass m) c+ orients' <- forM orients $ traverse $ descend compileExpr+ return ( lastwr, InstGUI (r, unP c, k) c' es'+ $ zip orients' children )+ where (orients, childwrs) = unzip cs++compileProgram :: MonadBackend m => Program ->+ ClassMap m -> ObjectMap m -> FuncMap m -> GlobMap m+ -> ([SindreOption], Sindre m () , WidgetRef)+compileProgram prog cm om fm gm =+ let env = blankCompilerEnv { functionRefs = funtable }+ ((funtable, evhandler, options, rootw), initialiser) =+ runCompiler env $ do+ mapM_ compileBackendGlobal $ M.toList gm+ opts <- mapM (descend compileOption) $ programOptions prog+ mapM_ (descend compileGlobal) $ programGlobals prog+ (lastwr, gui) <- compileGUI cm $ programGUI prog+ objs <- compileObjs (lastwr+1) om+ let lastwr' = lastwr + length objs+ handler <- compileActions $ programActions prog+ tell $ do+ ws <- map (second toWslot) <$> initGUI gui+ os <- map (second toOslot) <$> initObjs objs+ modify $ \s -> s { objects = array (0, lastwr') $ ws++os }+ funs' <- forM funs $ descend $ \(k, f) ->+ case (filter ((==k) . fst . unP) funs,+ M.lookup k fm) of+ (_:_:_, _) -> compileError $+ "Multiple definitions of function '"++k++"'"+ (_, Just _) -> compileError $+ "Redefinition of built-in function '"++k++"'"+ _ -> do f' <- compileFunction f+ return (k, f')+ fm' <- flip traverse fm $ \e -> do+ e' <- e+ return $ sindre . e' =<< IM.elems <$> sindre (gets execFrame)+ begin <- mapM (descend compileStmt) $ programBegin prog+ tell $ execute_ $ nextHere $ sequence_ begin+ return (M.fromList funs' `M.union` fm',+ handler, opts, rootwref gui)+ in (options, initialiser >> eventLoop evhandler, rootw)+ where funs = programFunctions prog+ rootwref (InstGUI r _ _ _) = r++compileFunction :: MonadBackend m => Function -> Compiler m (Execution m Value)+compileFunction (Function args body) =+ local (\s -> s { lexicalScope = argmap }) $ do+ exs <- mapM (descend compileStmt) body+ return $ do+ sequence_ exs+ return falsity+ where argmap = M.fromList $ zip args [0..]++compileAction :: MonadBackend m => [Identifier] -> Action+ -> Compiler m (Execution m ())+compileAction args (StmtAction body) =+ local (\s -> s { lexicalScope = argmap }) $ do+ exs <- mapM (descend compileStmt) body+ return $ sequence_ exs+ where argmap = M.fromList $ zip args [0..]++compilePattern :: MonadBackend m => Pattern+ -> Compiler m ( Event -> Execution m (Maybe [Value])+ , [Identifier])+compilePattern (ChordPattern kp1) = return (f, [])+ where f (KeyPress kp2) | kp1 == kp2 = return $ Just []+ | otherwise = return Nothing+ f _ = return Nothing+compilePattern (OrPattern p1 p2) = do+ (p1', ids1) <- compilePattern p1+ (p2', ids2) <- compilePattern p2+ let check ev = do+ v1 <- p1' ev+ v2 <- p2' ev+ return $ case (v1, v2) of+ (Just vs1, Just vs2) -> Just $ vs1++vs2+ (Just vs1, Nothing) -> Just vs1+ (Nothing, Just vs2) -> Just vs2+ _ -> Nothing+ return (check, ids1 ++ ids2)+compilePattern (SourcedPattern (NamedSource wn fn) evn args) = do+ cv <- constant wn+ case cv of+ Reference wr -> return (f wr, args)+ _ -> compileError $ "'" ++ wn ++ "' is not an object."+ where f wr (NamedEvent evn2 vs (FieldSrc wr2 fn2))+ | wr == wr2, evn2 == evn, fn2 `fcmp` fn = return $ Just vs+ f wr (NamedEvent evn2 vs (ObjectSrc wr2))+ | wr == wr2, evn2 == evn, fn == Nothing = return $ Just vs+ f _ _ = return Nothing+compilePattern (SourcedPattern (GenericSource cn wn fn) evn args) =+ return (f, wn:args)+ where f (NamedEvent evn2 vs (FieldSrc wr2@(_,cn2,_) fn2))+ | cn==cn2, evn2 == evn, fn2 `fcmp` fn =+ return $ Just $ Reference wr2 : vs+ f (NamedEvent evn2 vs (ObjectSrc wr2@(_,cn2,_)))+ | cn==cn2, evn2 == evn, fn == Nothing =+ return $ Just $ Reference wr2 : vs+ f _ = return Nothing++fcmp :: Identifier -> Maybe Identifier -> Bool+fcmp f = fromMaybe True . liftM (==f)++compileActions :: MonadBackend m => [P (Pattern, Action)]+ -> Compiler m (EventHandler m)+compileActions reacts = do+ reacts' <- mapM (descend compileReaction) reacts+ return $ \ev -> do dispatch ev reacts'+ case ev of+ KeyPress _ ->+ flip recvEvent ev =<< sindre (gets kbdFocus)+ _ -> return ()+ where compileReaction (pat, act) = do+ (pat', args) <- compilePattern pat+ act' <- compileAction args act+ return (pat', act')+ dispatch ev = mapM_ $ \(applies, apply) -> do+ vs <- applies ev+ case vs of+ Just vs' -> setScope vs' apply+ Nothing -> return ()++compileStmt :: MonadBackend m => Stmt -> Compiler m (Execution m ())+compileStmt (Print xs) = do+ xs' <- mapM (descend compileExpr) xs+ return $ do+ vs <- map show <$> sequence xs'+ back $ do+ printVal $ unwords vs+ printVal "\n"+compileStmt (Exit Nothing) =+ return $ sindre $ quitSindre ExitSuccess+compileStmt (Exit (Just e)) = do+ e' <- descend compileExpr e+ bad <- runtimeError+ return $ do+ v <- e'+ case mold v :: Maybe Integer of+ Just 0 -> sindre $ quitSindre ExitSuccess+ Just x -> sindre $ quitSindre $ ExitFailure $ fi x+ Nothing -> bad "Exit code must be an integer"+compileStmt (Expr e) = do+ e' <- descend compileExpr e+ return $ e' >> return ()+compileStmt (Return (Just e)) = do+ e' <- descend compileExpr e+ return $ doReturn =<< e'+compileStmt (Return Nothing) =+ return $ doReturn falsity+compileStmt Next = return doNext+compileStmt Break = return doBreak+compileStmt Continue = return doCont+compileStmt (If e trueb falseb) = do+ e' <- descend compileExpr e+ trueb' <- mapM (descend compileStmt) trueb+ falseb' <- mapM (descend compileStmt) falseb+ return $ do+ v <- e'+ sequence_ $ if true v then trueb' else falseb'+compileStmt (While c body) =+ compileStmt $ For blank c blank body+ where blank = Literal falsity `at` c+compileStmt (For e1 e2 e3 body) = do+ body' <- mapM (descend compileStmt) body+ e1' <- descend compileExpr e1+ e2' <- descend compileExpr e2+ e3' <- descend compileExpr e3+ let stmt = do+ v <- e2'+ when (true v) $ contHere (sequence_ body') >> e3' >> stmt+ return $ e1' >> breakHere stmt+compileStmt (Do body c) = do+ body' <- mapM (descend compileStmt) body+ loop' <- descend compileStmt $ While c body `at` c+ return $ breakHere $ contHere (sequence_ body') >> loop'+compileStmt (Focus e) = do+ e' <- descend compileExpr e+ bad <- runtimeError+ return $ do+ v <- e'+ case v of+ Reference r -> sindre $ modify $ \s -> s { kbdFocus = r }+ _ -> bad "Focus is not a widget reference"++compileExpr :: MonadBackend m => Expr -> Compiler m (Execution m Value)+compileExpr (Literal v) = return $ return v+compileExpr (Var v) = value v+compileExpr (P _ (Var k) `Assign` e) = do+ e' <- descend compileExpr e+ set <- setValue k+ return $ do+ v <- e'+ set v+ return v+compileExpr (Not e) = do+ e' <- descend compileExpr e+ return $ do+ v <- e'+ return $ if true v then falsity else truth+compileExpr (e1 `Equal` e2) =+ compileBinop e1 e2 $ \v1 v2 _ ->+ return $! if v1 == v2 then truth else falsity+compileExpr (e1 `LessThan` e2) =+ compileBinop e1 e2 $ \v1 v2 _ ->+ return $! if v1 < v2 then truth else falsity+compileExpr (e1 `LessEql` e2) =+ compileBinop e1 e2 $ \v1 v2 _ ->+ return $! if v1 <= v2 then truth else falsity+compileExpr (P _ (k `Lookup` e1) `Assign` e2) = do+ e1' <- descend compileExpr e1+ e2' <- descend compileExpr e2+ k' <- value k+ set <- setValue k+ bad <- runtimeError+ return $ do+ v1 <- e1'+ v2 <- e2'+ o <- k'+ case o of+ Dict m ->+ set $! Dict $! M.insert v1 v2 m+ _ -> bad "Not a dictionary"+ return v2+compileExpr (P _ (s `FieldOf` oe) `Assign` e) = do+ oe' <- descend compileExpr oe+ e' <- descend compileExpr e+ bad <- runtimeError+ return $ do+ o <- oe'+ v <- e'+ case o of+ Reference wr -> sindre $ do _ <- fieldSet wr s v+ return v+ _ -> bad "Not an object"+compileExpr (_ `Assign` _) = compileError "Cannot assign to rvalue"+compileExpr (k `Lookup` fe) = do+ fe' <- descend compileExpr fe+ k' <- value k+ bad <- runtimeError+ return $ do+ v <- fe'+ o <- k'+ case o of+ Dict m -> return $ fromMaybe falsity $! M.lookup v m+ _ -> bad "Not a dictionary"+compileExpr (s `FieldOf` oe) = do+ oe' <- descend compileExpr oe+ bad <- runtimeError+ return $ do+ o <- oe'+ case o of+ Reference wr -> sindre $ fieldGet wr s+ _ -> bad "Not an object"+compileExpr (Methcall oe meth argexps) = do+ argexps' <- mapM (descend compileExpr) argexps+ o' <- descend compileExpr oe+ bad <- runtimeError+ return $ do+ argvs <- sequence argexps'+ v <- o'+ case v of+ Reference wr -> callMethod wr meth argvs+ _ -> bad "Not an object"+compileExpr (Funcall f argexps) = do+ argexps' <- mapM (descend compileExpr) argexps+ f' <- function f+ return $ do+ argv <- sequence argexps'+ enterScope argv $ returnHere f'+compileExpr (Cond c trueb falseb) = do+ c' <- descend compileExpr c+ trueb' <- descend compileExpr trueb+ falseb' <- descend compileExpr falseb+ return $ do+ v <- c'+ if true v then trueb' else falseb'+compileExpr (Concat e1 e2) = compileBinop e1 e2 $ \v1 v2 bad ->+ case (mold v1, mold v2) of+ (Just v1', Just v2') -> return $ StringV $! v1' `T.append` v2'+ _ -> bad "Can only concatenate strings"+compileExpr (PostInc e) = do+ e' <- descend compileExpr e+ p' <- compileExpr $ e `Assign` (Plus e (Literal (Number 1) `at` e) `at` e)+ return $ e' <* p'+compileExpr (PostDec e) = do+ e' <- descend compileExpr e+ p' <- compileExpr $ e `Assign` (Minus e (Literal (Number 1) `at` e) `at` e)+ return $ e' <* p'+compileExpr (e1 `Plus` e2) = compileArithop (+) "add" e1 e2+compileExpr (e1 `Minus` e2) = compileArithop (-) "subtract" e1 e2+compileExpr (e1 `Times` e2) = compileArithop (*) "multiply" e1 e2+compileExpr (e1 `Divided` e2) = compileArithop (/) "divide" e1 e2+compileExpr (e1 `Modulo` e2) = compileArithop mod' "take modulo" e1 e2+compileExpr (e1 `RaisedTo` e2) = compileArithop (**) "exponentiate" e1 e2++compileBinop :: MonadBackend m =>+ P Expr -> P Expr ->+ (Value -> Value -> (String -> Execution m a)+ -> Execution m Value)+ -> Compiler m (Execution m Value)+compileBinop e1 e2 op = do+ e1' <- descend compileExpr e1+ e2' <- descend compileExpr e2+ bad <- runtimeError+ return $ do+ v1 <- e1'+ v2 <- e2'+ op v1 v2 bad++compileArithop :: MonadBackend m =>+ (Double -> Double -> Double)+ -> String -> P Expr -> P Expr+ -> Compiler m (Execution m Value)+compileArithop op opstr e1 e2 = compileBinop e1 e2 $ \v1 v2 bad ->+ case (mold v1, mold v2) of+ (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)++-- | Function that, given an initial value, the name of itself if any,+-- and a list of children, yields a computation that constructs a new+-- widget.+type Constructor m =+ WidgetRef -> [(Maybe Value, ObjectRef)] ->+ ConstructorM m (NewWidget m)+data InstGUI m = InstGUI WidgetRef+ (Constructor m)+ (WidgetArgs m)+ [(Maybe (Execution m Value), InstGUI m)]+type InstObjs m = [((Identifier, ObjectRef),+ ObjectRef -> m (NewObject m))]++initGUI :: MonadBackend m => InstGUI m+ -> Sindre m [(ObjectNum, (NewWidget m, Constraints))]+initGUI (InstGUI r@(wn,_,_) f args cs) = do+ args' <- traverse execute args+ childrefs <- forM cs $ \(e, InstGUI r' _ _ _) -> do+ v <- case e of Just e' -> Just <$> execute e'+ Nothing -> return Nothing+ return (v,r')+ let constructor = do+ minw <- Just <$> param "minwidth" <|> return Nothing+ 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)))+ s <- runConstructor constructor args'+ children <- liftM concat $ mapM (initGUI . snd) cs+ 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)]+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++-- | Class of types that a given backend can convert to from 'Value's.+-- In effect, a monadic version of 'Mold'.+class MonadBackend m => Param m a where+ -- | Attempt to convert the given Sindre value to the relevant+ -- Haskell value.+ moldM :: Value -> m (Maybe a)++data ParamError = NoParam Identifier | BadValue Identifier Value+ deriving (Show)++instance Error ParamError where+ strMsg = flip BadValue falsity++-- | The monad in which widget construction takes place. You can only+-- execute this by defining a 'Constructor' that is then used in a+-- Sindre program (see also 'ClassMap'). An example usage could be:+--+-- @+-- myWidget :: 'Constructor' MyBackEnd+-- myWidget w k cs : do+-- -- ConstructorM is an instance of 'Alternative', so we can provide+-- -- defaults or fallbacks for missing parameters.+-- arg <- 'param' \"myParam\" <|> return 12+-- /rest of construction/+-- @+newtype ConstructorM m a = ConstructorM (ErrorT ParamError+ (StateT (M.Map Identifier Value)+ (Sindre m))+ a)+ deriving ( MonadState (M.Map Identifier Value)+ , MonadError ParamError+ , Monad, Functor, Applicative)++-- | @noParam k@ signals that parameter @k@ is missing.+noParam :: String -> ConstructorM m a+noParam = throwError . NoParam++-- | @badValue k v@ signals that parameter @k@ is present with value+-- @v@, but that @v@ is an invalid value.+badValue :: String -> Value -> ConstructorM m a+badValue k = throwError . BadValue k++runConstructor :: MonadBackend m => ConstructorM m a+ -> M.Map Identifier Value -> Sindre m a+runConstructor (ConstructorM c) m = do+ (v, m') <- runStateT (runErrorT c) m+ case v of+ Left (NoParam k) -> fail $ "Missing argument '"++k++"'"+ Left (BadValue k v') -> fail $ "Bad value "++show v'++" for argument '"+ ++k++"'"++maybe "" ((": "++) . show) (M.lookup k m)+ + Right _ | m' /= M.empty ->+ fail $ "Surplus arguments: " ++ intercalate "," (M.keys m')+ Right v' -> return v'++instance MonadBackend m => Alternative (ConstructorM m) where+ empty = noParam "<none>"+ x <|> y = x `catchError` f+ where f (NoParam k) = y `catchError` g k+ f (BadValue k v) | not $ true v = y `catchError` g k+ f e = throwError e+ g k1 (NoParam _) = noParam k1+ g _ e = throwError e++instance MonadBackend im => MonadSindre im ConstructorM where+ sindre = ConstructorM . lift . lift++instance (MonadIO m, MonadBackend m) => MonadIO (ConstructorM m) where+ liftIO = back . io++-- | @k `paramAs` f@ yields the value of the widget parameter @k@,+-- using @f@ to convert it to the proper Haskell type. If @f@ returns+-- 'Nothing', @'badValue' k @ is called. If @k@ does not exist,+-- @'noParam' k@ is called.+paramAs :: MonadBackend m =>+ Identifier -> (Value -> Maybe a) -> ConstructorM m a+paramAs k f = paramAsM k (return . f)++-- | As 'paramAs', but the conversion function is monadic.+paramAsM :: MonadBackend m => Identifier+ -> (Value -> m (Maybe a)) -> ConstructorM m a+paramAsM k mf = do m <- get+ case M.lookup k m of+ Nothing -> noParam k+ Just v -> do put (k `M.delete` m)+ back (mf v) >>=+ maybe (badValue k v) return++-- | As 'paramM', but 'moldM' is always used for conversion.+paramM :: (Param m a, MonadBackend m) => Identifier -> ConstructorM m a+paramM k = paramAsM k moldM++-- | As 'param', but 'mold' is always used for conversion.+param :: (Mold a, MonadBackend m) => Identifier -> ConstructorM m a+param k = paramAs k mold
+ Sindre/Formatting.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Formatting+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Parser and definition of the dzen2-inspired formatting language+-- used by Sindre. A format string is a sequence of commands changing+-- drawing option parameters, and things to draw.+--+-----------------------------------------------------------------------------+module Sindre.Formatting( Format(..)+ , FormatString+ , textContents+ , startBg+ , parseFormatString+ , unparseFormatString+ )+ where++import Sindre.Sindre hiding (string)+import Sindre.Runtime (Mold(..))++import Data.Attoparsec.Text++import Control.Applicative hiding (many)+import Control.Monad+import Data.Maybe+import qualified Data.Text as T++import Prelude hiding (takeWhile)++-- | A formatting command is either a change to the drawing state, or+-- a string to be printed at the current location.+data Format = Fg String -- ^ Draw text in the given colour.+ | DefFg -- ^ Draw text in the default colour.+ | Bg String -- ^ Draw the background in the given colour.+ | DefBg -- ^ Draw the background in the default colour.+ | Text T.Text -- ^ Draw the given string.+ deriving (Show, Eq, Ord)++-- | A list of formatting commands, interpreted left-to-right.+type FormatString = [Format]++instance Mold FormatString where+ mold v = either (const Nothing) Just . parseFormatString =<< mold v+ unmold = StringV . unparseFormatString++-- | The human-readable part of a format string, with formatting+-- directives stripped.+textContents :: FormatString -> T.Text+textContents = T.concat . map txt+ where txt (Text s) = s+ txt _ = T.empty++-- | The first background colour preceding any default background+-- colour or text entry specified in the format string, if any.+startBg :: FormatString -> Maybe String+startBg = getBg <=< listToMaybe . dropWhile ign+ where ign (Text _) = False+ ign DefBg = False+ ign (Bg _) = False+ ign _ = True+ getBg (Bg bg) = Just bg+ getBg _ = Nothing++-- | Prettyprint a 'FormatString' to a string that, when parsed by+-- 'parseFormatString', results in the original 'FormatString'+unparseFormatString :: FormatString -> T.Text+unparseFormatString = T.concat . map f+ where f (Fg s) = T.pack $ "fg(" ++ s ++ ")"+ f DefFg = T.pack "fg()"+ f (Bg s) = T.pack $ "bg(" ++ s ++ ")"+ f DefBg = T.pack "bg()"+ f (Text s) = T.replace (T.pack "^") (T.pack "^^") s++-- | Parse a format string, returning either an error message or the+-- result of the parse.+parseFormatString :: T.Text -> Either String FormatString+parseFormatString s =+ eitherResult $ parse (many format <* endOfInput) s `feed` T.empty++format :: Parser Format+format = char '^' *> command <|> text++text :: Parser Format+text = Text <$> takeWhile1 (/='^')++command :: Parser Format+command = Text <$> string (T.pack "^")+ <|> string (T.pack "fg(")+ *> (Fg <$> T.unpack <$> takeWhile1 (/=')') <|> pure DefFg)+ <* string (T.pack ")")+ <|> string (T.pack "bg(")+ *> (Bg <$> T.unpack <$> takeWhile1 (/=')') <|> pure DefBg)+ <* string (T.pack ")")
+ Sindre/KeyVal.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ExistentialQuantification #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.KeyVal+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- A simple language for mapping keys to either a single string-value+-- or a list of strings. The syntax is line-oriented and extremely+-- simple. A line consists of key-value pairs, which are written as+-- the key, followed by an equals sign, followed by a double-quoted+-- string. Several double-quoted strings can follow the equal sign,+-- in which case they will be treated as a list. Space characters+-- separate elements, as so:+--+-- @foo="string" bar="another string" baz="s1" "s2" "this is a list" "s4"@+--+-- Literal double-quotes can be included in a string by doubling them.+--+-- @foo="this string contains ""quotes"""+--+-----------------------------------------------------------------------------+module Sindre.KeyVal( parseKV+ , value+ , values+ , (<$?>)+ , (<||>)+ , (<$$>)+ , (<|?>) )+ where++import Control.Applicative hiding (many, empty)+import Control.Monad.Identity++import Data.Attoparsec.Text++import qualified Data.Text as T++import Text.ParserCombinators.Perm++import Prelude hiding (takeWhile)++-- | Parse a key-value string wrapper constructed via the permutation+-- parser combinators from 'Text.Parsec.Perm' and the parsers @value@+-- and @values@.+parseKV :: PermParser Parser a -> T.Text -> Either String a+parseKV p s =+ eitherResult $ parse (permute p <* endOfInput) s `feed` T.empty++-- | @value k@ is a parser for the single-valued key @k@.+value :: T.Text -> Parser T.Text+value k = try (string k) *> realSpaces *> char '=' *> realSpaces+ *> quotedString <* realSpaces++-- | @values k@ is a parser for the list-valued key @k@. At least a+-- single value is required.+values :: T.Text -> Parser [T.Text]+values k = try (string k) *> realSpaces *> char '=' *> realSpaces+ *> many1 quotedString <* realSpaces++quotedString :: Parser T.Text+quotedString = char '"' *> inner <* realSpaces+ where inner = do+ s <- takeWhile (/='"')+ char '\"' *> (char '\"' *> (T.append (T.snoc s '"') <$> inner)+ <|> return s)++realSpaces :: Parser T.Text+realSpaces = takeWhile (==' ')
+ Sindre/Lib.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Lib+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Library routines and helper functions for the Sindre programming+-- language.+--+-----------------------------------------------------------------------------+module Sindre.Lib ( stdFunctions+ , ioFunctions+ , ioGlobals+ , LiftFunction(..)+ , KeyLike(..)+ )+ where++import Sindre.Sindre+import Sindre.Compiler+import Sindre.Runtime+import Sindre.Util++import System.Environment+import System.Exit+import System.IO+import System.Process hiding (env)+import Text.Regex.PCRE++import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.List+import qualified Data.Map as M+import qualified Data.Set as S++lengthFun :: Value -> Integer+lengthFun (Dict m) = fi $ M.size m+lengthFun v = maybe 0 genericLength (mold v :: Maybe String)++builtin :: LiftFunction im m a => a -> Compiler im ([Value] -> m im Value)+builtin f = return $ function f++-- | A set of pure functions that can work with any Sindre backend.+-- Includes the functions @length@, @abs@, @substr@, @index@, @match@,+-- @sub@, @gsub@, @tolower@, and @toupper@.+stdFunctions :: forall im. MonadBackend im => FuncMap im+stdFunctions = M.fromList+ [ ("length", builtin $ return' . lengthFun)+ , ("abs" , builtin $ return' . (abs :: Int -> Int))+ , ("substr", builtin $ \(s::String) m n ->+ return' $ take n $ drop (m-1) s)+ , ("index", builtin $ \(s::String) t ->+ return' $ maybe 0 (1+) $ findIndex (isPrefixOf t) $ tails s)+ , ("match", do+ rstart <- setValue "RSTART"+ rlength <- setValue "RLENGTH"+ return $ function $ \(s::String) (r::String) -> do+ let (stt, len) = s =~ r :: (Int, Int)+ execute_ $ do rstart $ unmold (stt+1)+ rlength $ unmold len+ return' $ unmold (stt+1))+ , ("sub", builtin sub)+ , ("gsub", builtin gsub)+ , ("tolower", builtin $ return' . map toLower)+ , ("toupper", builtin $ return' . map toUpper)+ ]+ where return' :: Mold a => a -> Sindre im a+ return' = return+ sub (r::String) t (s::String) =+ case s =~ r of+ (-1,_) -> return' s+ (i,n) -> return' $ take i s ++ t ++ drop (i+n) s+ gsub (r::String) t (s::String) =+ case s =~ r of+ (-1,_) -> return' s+ (i,n) -> do s' <- gsub r t $ drop (i+n) s+ return' $ take i s ++ t ++ s'+-- | A set of impure functions that only work in IO backends.+-- Includes the @system@ function.+ioFunctions :: forall im.(MonadIO im, MonadBackend im) => FuncMap im+ioFunctions = M.fromList+ [ ("system", builtin $ \s -> do+ c <- io $ system s+ case c of ExitSuccess -> return' 0+ ExitFailure e -> return' e)+ , ("osystem", do+ exitval <- setValue "EXITVAL"+ return $ function $ \s -> do+ (Just inh, Just outh, _, pid) <-+ io $ createProcess (shell s) { std_in = CreatePipe,+ std_out = CreatePipe,+ std_err = Inherit }+ io $ hClose inh+ output <- io $ hGetContents outh+ ex <- io $ waitForProcess pid+ execute_ $ exitval $ unmold $ case ex of+ ExitSuccess -> 0+ ExitFailure r -> r+ return' output)+ ]+ where return' :: Mold a => a -> Sindre im a+ return' = return++-- | Global variables that require an IO backend. Includes the+-- @ENVIRON@ global.+ioGlobals :: MonadIO im => M.Map Identifier (im Value)+ioGlobals = M.fromList [("ENVIRON", do+ env <- io getEnvironment+ let f (k, s) = (unmold k, unmold s)+ return $ Dict $ M.fromList $ map f env)+ ]++-- | A class making it easy to adapt Haskell functions as Sindre+-- functions that take and return 'Value's.+class (MonadBackend im, MonadSindre im m) => LiftFunction im m a where+ function :: a -> [Value] -> m im Value+ -- ^ @function f@ is a monadic function that accepts a list of+ -- 'Value's and returns a 'Value'. If the list does not contain the+ -- number, or type, of arguments expected by @f@, 'fail' will be+ -- called with an appropriate error message.++instance (Mold a, MonadSindre im m) => LiftFunction im m (m im a) where+ function x [] = liftM unmold x+ function _ _ = fail "Too many arguments"++instance (Mold a, LiftFunction im m b, MonadSindre im m)+ => LiftFunction im m (a -> b) where+ function f (x:xs) = case mold x of+ Nothing -> fail "Cannot mold argument"+ Just x' -> f x' `function` xs+ function _ [] = fail "Not enough arguments"++-- | Convenience class for writing 'Chord' values.+class KeyLike a where+ chord :: [KeyModifier] -> a -> Chord+ -- ^ Given a list of modifiers and either a 'char' or a 'String',+ -- yield a 'Chord'. If given a character, the Chord will contain a+ -- 'CharKey', if given a string, it will contain a 'CtrlKey'.++instance KeyLike Char where+ chord ms c = (S.fromList ms, CharKey c)++instance KeyLike String where+ chord ms s = (S.fromList ms, CtrlKey s)
+ Sindre/Main.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Main+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Sindre, a programming language for writing simple GUIs+--+-----------------------------------------------------------------------------++module Sindre.Main( sindreMain,+ emptyProgram,+ classMap,+ objectMap,+ funcMap,+ globMap,+ module Export )+ where++import Sindre.Compiler as Export+import Sindre.Lib+import Sindre.Parser+import Sindre.Runtime as Export+import Sindre.Sindre as Export+import Sindre.Util+import Sindre.Widgets+import Sindre.X11++import Paths_sindre (version)++import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import System.Posix.IO+import System.Posix.Types+import System.Locale.SetLocale(setLocale, Category(..))++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Char+import qualified Data.Map as M+import qualified Data.Traversable as T+import Data.Version (showVersion)++import Prelude hiding (catch)++setupLocale :: IO ()+setupLocale = do+ ret <- setLocale LC_ALL Nothing+ case ret of+ Nothing -> putStrLn "Can't set locale." >> exitFailure+ _ -> return ()++-- | The main Sindre entry point.+sindreMain :: Program -> ClassMap SindreX11M -> ObjectMap SindreX11M+ -> FuncMap SindreX11M -> GlobMap SindreX11M+ -> [String] -> IO ()+sindreMain prog cm om fm gm args = do+ setupLocale+ dstr <- getEnv "DISPLAY" `catch` \(_ :: IOException) -> (return "")+ let cfg = AppConfig { cfgDisplay = dstr + , cfgProgram = prog+ , cfgBackend = sindreX11override+ , cfgFiles = M.empty }+ case getOpt' Permute options args of+ (opts, _, _, []) -> do+ cfg' <- foldl (>>=) (return cfg) opts+ hom <- T.mapM (liftM mkInStream . fdToHandle) $ cfgFiles cfg'+ let (srcopts, start) =+ compileSindre (cfgProgram cfg') cm (om `M.union` hom) fm gm+ progopts = mergeOpts srcopts+ case getOpt' Permute progopts args of+ (opts', [], [], []) ->+ let start' = start $ foldl (flip id) M.empty opts'+ in exitWith =<< cfgBackend cfg' (cfgDisplay cfg') start'+ (_, nonopts, unrecs, errs) -> do+ usage <- usageStr progopts+ badOptions usage nonopts errs unrecs+ (_, nonopts, unrecs, errs) -> do+ usage <- usageStr options+ badOptions usage nonopts errs unrecs+ ++badOptions :: String -> [String] -> [String] -> [String] -> IO ()+badOptions usage nonopts errs unrecs = do + mapM_ (err . ("Junk argument: " ++)) nonopts+ mapM_ (err . ("Unrecognised argument: " ++)) unrecs+ hPutStr stderr $ concat errs ++ usage+ exitFailure++mergeOpts :: [SindreOption] -> [SindreOption]+mergeOpts = (++map defang options)+ where defang (Option s l arg doc) = Option s l (idarg arg) doc+ idarg (ReqArg _ desc) = ReqArg (const id) desc+ idarg (OptArg _ desc) = OptArg (const id) desc+ idarg (NoArg _) = NoArg id++data AppConfig = AppConfig {+ cfgProgram :: Program+ , cfgDisplay :: String+ , cfgBackend :: String+ -> SindreX11M ExitCode+ -> IO ExitCode+ , cfgFiles :: M.Map String Fd+ }++usageStr :: [OptDescr a] -> IO String+usageStr opts = do+ prog <- getProgName+ let header = "Help for " ++ prog ++ " (Sindre " ++ showVersion version ++ ")"+ return $ usageInfo header opts++type AppOption = OptDescr (AppConfig -> IO AppConfig)++options :: [AppOption]+options =+ [ Option "f" ["file"]+ (ReqArg (\arg cfg -> do+ result <- parseSindre (cfgProgram cfg) arg <$> readFile arg + case result of+ Left e -> error $ show e+ Right prog -> return $ cfg { cfgProgram = prog })+ "FILE")+ "Read program code from the given file."+ , Option "e" ["expression"]+ (ReqArg (\arg cfg ->+ case parseSindre (cfgProgram cfg) "expression" arg of+ Left e -> error $ show e+ Right prog -> return $ cfg { cfgProgram = prog })+ "code")+ "Add the given code to the program."+ , Option "" ["wmmode"]+ (let wmmode "normal" cfg = return cfg { cfgBackend = sindreX11 }+ wmmode "override" cfg = return cfg { cfgBackend = sindreX11override }+ wmmode "dock" cfg = return cfg { cfgBackend = sindreX11dock }+ wmmode _ _ = error "Argument to --wmmode must be normal, override or dock."+ in ReqArg wmmode "normal|override|dock")+ "How Sindre interacts with the window manager (defaults to 'override')."+ , Option "v" ["version"]+ (NoArg (\_ -> do hPutStrLn stderr $ "Sindre " ++ showVersion version ++ " (C) " ++ mail+ exitSuccess))+ "Show version information."+ , Option "h" ["help"]+ (NoArg (\_ -> do hPutStr stderr =<< usageStr options+ exitSuccess))+ "Show usage information."+ , Option "" ["fd"]+ (ReqArg (\arg cfg ->+ case span isAlpha arg of+ (name@(_:_), '=':fdnum@(_:_)) | all isDigit fdnum ->+ return cfg { cfgFiles = M.insert name (read fdnum)+ $ cfgFiles cfg }+ _ -> error "Malformed --fd option")+ "STREAMNAME=FD")+ "Create input stream from file descriptor"+ ]++mail :: String+mail = "Troels Henriksen <athas@sigkill.dk>"++mkUndef :: MonadBackend m => Constructor m+mkUndef _ _ = sindre $ fail "No GUI defined (empty program?)"++emptyProgram :: Program+emptyProgram = Program {+ programGUI = (Nothing, GUI Nothing (P nowhere "") M.empty [])+ , programActions = []+ , programGlobals = []+ , programOptions = []+ , programFunctions = []+ , programBegin = []+ }+ +classMap :: ClassMap SindreX11M+classMap = M.fromList [ ("Dial", mkDial)+ , ("Label", mkLabel)+ , ("Blank", mkBlank)+ , ("Horizontally", mkHorizontally)+ , ("Vertically", mkVertically)+ , ("Input", mkTextField)+ , ("HList", mkHList)+ , ("VList", mkVList)+ , ("", mkUndef)+ ]++objectMap :: ObjectMap SindreX11M+objectMap = M.fromList [ ("stdin", mkInStream stdin) ]++funcMap :: FuncMap SindreX11M+funcMap = stdFunctions `M.union` ioFunctions++globMap :: GlobMap SindreX11M+globMap = ioGlobals
+ Sindre/Parser.hs view
@@ -0,0 +1,417 @@+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Parser+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Parser for the Sindre programming language. The documentation for+-- this module does not include a description of the language syntax.+--+-----------------------------------------------------------------------------+module Sindre.Parser( parseSindre+ , parseInteger+ )+ where++import Sindre.Sindre hiding (SourcePos, position, string)+import qualified Sindre.Sindre as Sindre++import System.Console.GetOpt++import Text.Parsec hiding ((<|>), many, optional)+import Text.Parsec.Expr+import Text.Parsec.String+import Text.Parsec.Token (LanguageDef, GenLanguageDef(..))+import qualified Text.Parsec.Token as P++import Control.Applicative+import Control.Monad.Identity+import Data.Char hiding (Control)+import Data.Function+import Data.List hiding (insert)+import Data.Maybe+import qualified Data.Map as M+import qualified Data.Set as S++-- | @parseSindre prog filename string@ extends the 'Program' @prog@+-- with the declarations in the given Sindre source code. In case of+-- mutually-exclusive definitions (such as the @BEGIN@ block, or+-- identically named functions), the new definitions in @string@ take+-- precedence.+parseSindre :: Program -> SourceName -> String -> Either ParseError Program+parseSindre prog = parse (P.whiteSpace lexer *> sindre prog)++-- | Try to parse an integer according to the Sindre syntax, ignoring+-- trailing whitespace.+parseInteger :: String -> Maybe Double+parseInteger = either (const Nothing) Just .+ parse (decimal <* eof) ""++data Directive = GUIDirective (Maybe (P Expr), GUI)+ | ActionDirective (Pattern, Action)+ | GlobalDirective (Identifier, P Expr)+ | FuncDirective (Identifier, Function)+ | OptDirective (Identifier, (SindreOption, Maybe Value))+ | BeginDirective [P Stmt]++definedBy :: [Directive] -> S.Set Identifier+definedBy = foldr f S.empty+ where f (GlobalDirective (k, _)) = S.insert k+ f (OptDirective (k, _)) = S.insert k+ f _ = id++getGUI :: [Directive] -> Either String (Maybe (Maybe (P Expr), GUI))+getGUI ds = case foldl f [] ds of+ [gui'] -> Right $ Just gui'+ [] -> Right Nothing+ _ -> Left "Multiple GUI definitions"+ where f l (GUIDirective x) = x:l+ f l _ = l++getActions :: [P Directive] -> [P (Pattern, Action)]+getActions = foldl f []+ where f l (P p (ActionDirective x)) = P p x:l+ f l _ = l++getGlobals :: [P Directive] -> [P (Identifier, P Expr)]+getGlobals = foldl f []+ where f m (P p (GlobalDirective x)) = P p x:m+ f m _ = m++getFunctions :: [P Directive] -> [P (Identifier, Function)]+getFunctions = foldl f []+ where f m (P p (FuncDirective x)) = P p x:m+ f m _ = m++getOptions :: [P Directive] -> [P (Identifier, (SindreOption, Maybe Value))]+getOptions = foldl f []+ where f m (P p (OptDirective x)) = P p x:m+ f m _ = m++getBegin :: [Directive] -> [P Stmt]+getBegin = foldl f []+ where f m (BeginDirective x) = m++x+ f m _ = m++applyDirectives :: [P Directive] -> Program -> Either String Program+applyDirectives ds prog = do+ let prog' = prog {+ programActions = getActions ds ++ programActions prog+ , programGlobals = globals' ++ getGlobals ds+ , programFunctions =+ merge (getFunctions ds) (programFunctions prog)+ , programOptions = options' ++ getOptions ds+ , programBegin = getBegin ds' ++ programBegin prog+ }+ maybe prog' (\gui' -> prog' { programGUI = gui' }) <$> getGUI ds'+ where options' = filter (not . hasNewDef . fst . unP) (programOptions prog)+ globals' = filter (not . hasNewDef . fst . unP) (programGlobals prog)+ hasNewDef k = S.member k $ definedBy ds'+ merge = unionBy ((==) `on` fst . unP)+ ds' = map unP ds++position :: Parser (String, Int, Int)+position = do pos <- getPosition+ pure (sourceName pos, sourceLine pos, sourceColumn pos)++node :: Parser a -> Parser (P a)+node p = pure P <*> position <*> p++sindre :: Program -> Parser Program+sindre prog = do ds <- reverse <$> many directive <* eof+ either fail return $ applyDirectives ds prog++directive :: Parser (P Directive)+directive = directive' <* skipMany semi+ where directive' = node $+ BeginDirective <$> begindef+ <|> ActionDirective <$> reaction+ <|> GUIDirective <$> gui+ <|> GlobalDirective <$> constdef+ <|> FuncDirective <$> functiondef+ <|> OptDirective <$> optiondef++gui :: Parser (Maybe (P Expr), GUI)+gui = reserved "GUI" *> braces gui'+ <?> "GUI definition"+ where gui' = do+ name' <- optional name+ clss <- node className+ args' <- M.fromList <$> args <|> pure M.empty+ orient' <- optional orient+ children' <- children <|> pure []+ return (orient',+ GUI { widgetName = name'+ , widgetClass = clss+ , widgetArgs = args'+ , widgetChildren = children'+ })+ name = varName <* reservedOp "="+ args = parens $ commaSep arg+ arg = pure (,) <*> varName <* reservedOp "=" <*> expression+ children = braces $ many (gui' <* skipMany semi)+ orient = reservedOp "@" *> expression++functiondef :: Parser (Identifier, Function)+functiondef = reserved "function" *> pure (,)+ <*> try varName <*> function+ <?> "function definition"+ where function = pure Function + <*> parens (commaSep varName)+ <*> braces statements++optiondef :: Parser (Identifier, (SindreOption, Maybe Value))+optiondef = reserved "option" *> do+ var <- varName+ pure ((,) var) <*> parens (option' var)+ <?> "option definition"+ where option' var = do+ s <- optional shortopt <* optional comma+ l <- optional longopt <* optional comma+ odesc <- optional optdesc <* optional comma+ adesc <- optional argdesc <* optional comma+ defval <- optional literal+ let (s', l') = (maybeToList s, maybeToList l)+ let noargfun = NoArg $ M.insert var "true"+ let argfun = ReqArg $ \arg -> M.insert var arg+ return (Option s' l'+ (maybe noargfun argfun adesc)+ (fromMaybe "" odesc)+ , defval)+ shortopt = try $ lexeme $ char '-' *> alphaNum+ longopt = string "--" *> identifier+ optdesc = stringLiteral+ argdesc = stringLiteral++begindef :: Parser [P Stmt]+begindef = reserved "BEGIN" *> braces statements++reaction :: Parser (Pattern, Action)+reaction = pure (,) <*> try pattern <*> action <?> "action"++constdef :: Parser (Identifier, P Expr)+constdef = pure (,) <*> try varName <* reservedOp "=" <*> expression++pattern :: Parser Pattern+pattern = simplepat `chainl1` (reservedOp "||" *> pure OrPattern)+ where simplepat =+ pure ChordPattern <*>+ (reservedOp "<" *> chord <* reservedOp ">")+ <|> pure SourcedPattern+ <*> source <* string "->"+ <*> varName+ <*> parens (commaSep varName)++source :: Parser SourcePat+source = pure NamedSource <*> varName <*> field+ <|> pure GenericSource+ <*> (char '$' *> className) <*> parens varName <*> field+ where field = optional $ char '.' *> varName++action :: Parser Action+action = StmtAction <$> braces statements++key :: Parser Key+key = do s <- identifier+ case s of [c] -> return $ CharKey c+ "Space" -> return $ CharKey ' '+ _ -> return $ CtrlKey s++modifier :: Parser KeyModifier+modifier = string "C" *> return Control+ <|> string "M" *> return Meta+ <|> string "Shift" *> return Shift+ <|> string "S" *> return Super+ <|> string "H" *> return Hyper++chord :: Parser Chord+chord = pure (,) <*> (S.fromList <$> many (try modifier <* char '-')) <*> key++statements :: Parser [P Stmt]+statements = many (statement <* skipMany semi) <?> "statement"++statement :: Parser (P Stmt)+statement = node $ + printstmt+ <|> quitstmt+ <|> returnstmt+ <|> (reserved "next" *> pure Next)+ <|> (reserved "continue" *> pure Continue)+ <|> (reserved "break" *> pure Break)+ <|> ifstmt+ <|> whilestmt+ <|> forstmt+ <|> dostmt+ <|> focusstmt+ <|> Expr <$> expression+ where printstmt = reserved "print" *>+ (Print <$> commaSep expression)+ quitstmt = reserved "exit" *>+ (Exit <$> optional expression)+ returnstmt = reserved "return" *>+ (Return <$> optional expression)+ ifstmt = (reserved "if" *> pure If)+ <*> parens expression + <*> braces statements+ <*> ( reserved "else" *>+ ((:[]) <$> node ifstmt <|> braces statements)+ <|> return [])+ whilestmt = (reserved "while" *> pure While)+ <*> parens expression+ <*> braces statements+ forstmt = reserved "for" *> parens+ (pure For <*> expression <* semi+ <*> expression <* semi+ <*> expression)+ <*> braces statements+ dostmt = (reserved "do" *> pure Do)+ <*> braces statements+ <*> (reserved "while" *> parens expression)+ focusstmt = reserved "focus" *> (Focus <$> expression)++keywords :: [String]+keywords = ["if", "else", "while", "for", "do",+ "function", "return", "continue", "break",+ "exit", "print", "GUI", "option"]++sindrelang :: LanguageDef ()+sindrelang = LanguageDef {+ commentStart = "/*"+ , commentEnd = "*/"+ , commentLine = "//"+ , nestedComments = True+ , identStart = letter+ , identLetter = alphaNum <|> char '_'+ , opStart = oneOf "+-/*&|;,<>"+ , opLetter = oneOf "=+-|&"+ , reservedNames = keywords+ , reservedOpNames = [ "++", "--"+ , "^", "**"+ , "+", "-", "/", "*", "%"+ , "&&", "||", ";", ","+ , "<", ">", "<=", ">=", "!="+ , "=", "*=", "/=", "+=", "-="+ , "%=", "^="+ , "?", ":"]+ , caseSensitive = True+ }++exprOperators :: OperatorTable String () Identity (P Expr)+compOperators :: OperatorTable String () Identity (P Expr)+assignOperators :: OperatorTable String () Identity (P Expr)+(exprOperators, compOperators, assignOperators) =+ ( [ [ prefix "++" $+ preop Plus (Literal $ Number 1)+ , postfix "++" PostInc+ , prefix "--" $+ preop Plus (Literal $ Number $ -1)+ , postfix "--" PostDec ]+ , [ binary "**" RaisedTo AssocRight,+ binary "^" RaisedTo AssocRight ]+ , [ prefix "-" $ \e -> Times (Literal (Number $ -1) `at` e) e+ , prefix "+" $ \(P _ e) -> e+ , prefix "!" Not ]+ , [ binary "*" Times AssocLeft,+ binary "/" Divided AssocLeft, binary "%" Modulo AssocLeft ]+ , [ binary "+" Plus AssocLeft, binary "-" Minus AssocLeft ]]+ , [ [ binary "==" Equal AssocNone + , binary "<" LessThan AssocNone + , binary ">" (flip LessThan) AssocNone + , binary "<=" LessEql AssocNone+ , binary ">=" (flip LessEql) AssocNone+ , binary "!=" (\e1 e2 -> Not $ Equal e1 e2 `at` e1) AssocNone ]+ , [ binary "&&" (\x y -> Cond x y $ Literal falsity `at` x) AssocRight ]+ , [ binary "||" (\x y -> Cond x (Literal truth `at` x) y) AssocRight ]]+ , [ [ binary "=" Assign AssocRight+ , binary "*=" (inplace Times) AssocLeft+ , binary "/=" (inplace Divided) AssocLeft+ , binary "+=" (inplace Plus) AssocLeft+ , binary "-=" (inplace Minus) AssocLeft+ , binary "%=" (inplace Modulo) AssocLeft+ , binary "^=" (inplace RaisedTo) AssocLeft]])+ where binary name fun = Infix $ do+ p <- position+ reservedOp name+ pure (\e1 e2 -> P p $ fun e1 e2)+ unary name fun = do p <- position+ reservedOp name+ pure $ P p . fun+ prefix name fun = Prefix $ unary name fun+ postfix name fun = Postfix $ unary name fun+ inplace op e1@(P pos _) e2 = e1 `Assign` P pos (e1 `op` e2)+ preop op e1 e2@(P pos _) = e2 `Assign` P pos (e2 `op` P pos e1)++expression :: Parser (P Expr)+expression = try condexp <|> expr1 <?> "expression"+ where condexp = node $ pure Cond <*> expr2 <* reservedOp "?"+ <*> expression <* reservedOp ":"+ <*> expression+ expr1 = buildExpressionParser assignOperators $+ try condexp <|> expr2+ expr2 = buildExpressionParser compOperators $+ expr3 `chainl1` pure (\x y -> Concat x y `at` x)+ expr3 = buildExpressionParser exprOperators $+ try atomic <|> compound++atomic :: Parser (P Expr)+atomic = parens expression+ <|> node (Literal <$> literal)+ <|> dictlookup++literal :: Parser Value+literal = pure Number <*> decimal+ <|> pure Sindre.string <*> stringLiteral+ <?> "literal value"++compound :: Parser (P Expr)+compound =+ field' `chainl1` (char '.' *> pure comb)+ where comb e (P _ (Var v)) = FieldOf v e `at` e+ comb e (P _ (Funcall v es)) = Methcall e v es `at` e+ comb _ _ = undefined -- Will never happen+ field' = try fcall <|> node (Var <$> varName)++lexer :: P.TokenParser ()+lexer = P.makeTokenParser sindrelang+lexeme :: Parser a -> Parser a+lexeme = P.lexeme lexer+comma :: Parser String+comma = P.comma lexer+commaSep :: Parser a -> Parser [a]+commaSep = P.commaSep lexer+semi :: Parser String+semi = P.semi lexer+parens :: Parser a -> Parser a+parens = P.parens lexer+braces :: Parser a -> Parser a+braces = P.braces lexer+brackets :: Parser a -> Parser a+brackets = P.brackets lexer+fcall :: Parser (P Expr)+fcall = node $ pure Funcall <*> varName <*>+ parens (sepBy expression comma)+dictlookup :: Parser (P Expr)+dictlookup = node $ pure Lookup <*> varName <*>+ brackets expression+check :: (a -> Bool) -> a -> Parser a+check f x | f x = return x+check _ _ = fail "Failed check"+isClassName :: String -> Bool+isClassName "" = False+isClassName s@(c:_) = not (all isUpper s) && isUpper c+className :: Parser String+className = try (check isClassName =<< identifier) <?> "class"+varName :: Parser String+varName = try (check (not . isClassName) =<< identifier) <?> "variable"+identifier :: Parser String+identifier = P.identifier lexer+decimal :: Parser Double+decimal = either fromIntegral id <$> P.naturalOrFloat lexer+stringLiteral :: Parser String+stringLiteral = P.stringLiteral lexer+reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer+reserved :: String -> Parser ()+reserved = P.reserved lexer
+ Sindre/Runtime.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Runtime+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Definitions for the Sindre runtime environment.+--+-----------------------------------------------------------------------------+module Sindre.Runtime ( Sindre+ , execSindre+ , quitSindre+ , MonadSindre(..)+ , broadcast+ , changed+ , redraw+ , fullRedraw+ , setRootPosition+ , MonadBackend(..)+ , Object(..)+ , ObjectM+ , fieldSet+ , fieldGet+ , callMethod+ , Widget(..)+ , draw+ , compose+ , recvEvent+ , DataSlot(..)+ , WidgetState(..)+ , SindreEnv(..)+ , newEnv+ , globalVal+ , setGlobal+ , Execution+ , execute+ , execute_+ , returnHere+ , doReturn+ , nextHere+ , doNext+ , breakHere+ , doBreak+ , contHere+ , doCont+ , setScope+ , enterScope+ , lexicalVal+ , setLexical+ , eventLoop+ , EventHandler+ , Mold(..)+ )+ where++import Sindre.Parser(parseInteger)+import Sindre.Sindre+import Sindre.Util++import System.Exit++import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.State+import Data.Array+import Data.Maybe+import Data.Monoid+import Data.Sequence((|>), ViewL(..))+import qualified Data.IntMap as IM+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+ }++data DataSlot m = forall s . Widget m s => WidgetSlot s WidgetState+ | forall s . Object m s => ObjectSlot s++type Frame = IM.IntMap Value++data Redraw = RedrawAll | RedrawSome (S.Set WidgetRef)++data SindreEnv m = SindreEnv {+ objects :: Array ObjectNum (DataSlot m)+ , evtQueue :: Q.Seq Event+ , globals :: IM.IntMap Value+ , execFrame :: Frame+ , kbdFocus :: WidgetRef+ , rootWidget :: (Maybe (RootPosition m), WidgetRef)+ , arguments :: Arguments+ , needsRedraw :: Redraw+ }++newEnv :: WidgetRef -> Arguments -> SindreEnv m+newEnv rootwr argv =+ SindreEnv { objects = array (0, -1) []+ , evtQueue = Q.empty+ , globals = IM.empty+ , execFrame = IM.empty+ , kbdFocus = rootwr+ , rootWidget = (Nothing, rootwr)+ , arguments = argv+ , needsRedraw = RedrawAll+ }++-- | A monad that can be used as the layer beneath 'Sindre'.+class (Monad m, Functor m, Applicative m, Mold (RootPosition m)) => MonadBackend m where+ type BackEvent m :: *+ type RootPosition m :: *+ redrawRoot :: Sindre m ()+ redrawRegion :: [Rectangle] -> Sindre m ()+ getBackEvent :: Sindre m (Maybe Event)+ waitForBackEvent :: Sindre m Event+ printVal :: String -> m ()++type QuitFun m = ExitCode -> Sindre m ()++-- | The main monad in which a Sindre program executes. More+-- specialised monads, such as 'Execution' are used for specific+-- purposes, but they all run on top of the Sindre monad.+newtype Sindre m a = Sindre (ReaderT (QuitFun m)+ (StateT (SindreEnv m)+ (ContT ExitCode m))+ a)+ deriving (Functor, Monad, Applicative, MonadCont,+ MonadState (SindreEnv m), MonadReader (QuitFun m))++instance MonadTrans Sindre where+ lift = Sindre . lift . lift . lift++instance MonadIO m => MonadIO (Sindre m) where+ liftIO = Sindre . liftIO++instance Monoid (Sindre m ()) where+ mempty = return ()+ mappend = (>>)+ mconcat = sequence_++-- | @execSindre e m@ executes the action @m@ in environment @e@,+-- returning the exit code of @m@.+execSindre :: MonadBackend m => SindreEnv m -> Sindre m a -> m ExitCode+execSindre s (Sindre m) = runContT m' return+ where m' = callCC $ \c -> do+ let quitc code =+ Sindre $ lift $ lift $ c code+ _ <- execStateT (runReaderT m quitc) s+ return ExitSuccess++-- | Immediately return from 'execSindre', returning the given exit+-- code.+quitSindre :: MonadBackend m => ExitCode -> Sindre m ()+quitSindre code = ($ code) =<< ask++-- | @MonadSindre im m@ is the class of monads @m@ that run on top of+-- 'Sindre' with backend @im@, and can thus access Sindre+-- functionality.+class (MonadBackend im, Monad (m im)) => MonadSindre im m where+ -- | Lift a 'Sindre' operation into this monad.+ sindre :: Sindre im a -> m im a+ -- | Lift a backend operation into this monad.+ back :: im a -> m im a+ back = sindre . lift++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)++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 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+ e :< queue' -> do modify $ \s -> s { evtQueue = queue' }+ return $ Just e+ EmptyL -> return Nothing++getEvent :: MonadBackend m => Sindre m (Maybe Event)+getEvent = maybe popQueue (return . Just) =<< getBackEvent++waitForEvent :: MonadBackend m => Sindre m Event+waitForEvent = liftM2 fromMaybe waitForBackEvent popQueue++broadcast :: MonadBackend im => Event -> ObjectM o im ()+broadcast e = sindre $ modify $ \s -> s { evtQueue = evtQueue s |> e }++changed :: MonadBackend im =>+ Identifier -> Value -> Value -> ObjectM o im ()+changed f old new = do+ this <- ask+ broadcast $ NamedEvent "changed" [old, new] $ FieldSrc this f++redraw :: (MonadBackend im, Widget im s) => ObjectM s im ()+redraw = do r <- ask+ sindre $ modify $ \s ->+ s { needsRedraw = needsRedraw s `add` r }+ fullRedraw+ where add RedrawAll _ = RedrawAll+ add (RedrawSome s) w = RedrawSome $ w `S.insert` s++fullRedraw :: MonadSindre im m => m im ()+fullRedraw = sindre $ modify $ \s ->+ case needsRedraw s of+ RedrawAll -> s+ _ -> s { needsRedraw = RedrawAll }++setRootPosition :: MonadBackend m => Value -> Sindre m ()+setRootPosition v =+ case mold v of+ Nothing -> fail $ "Value " ++ show v ++ " not a valid root widget position."+ Just v' -> modify $ \s -> s { rootWidget = (Just v', snd $ rootWidget s) }++globalVal :: MonadBackend m => IM.Key -> Sindre m Value+globalVal k = IM.findWithDefault falsity k <$> gets globals++setGlobal :: MonadBackend m => IM.Key -> Value -> Sindre m ()+setGlobal k v =+ 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)+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' })++type Jumper m a = a -> Execution m ()++data ExecutionEnv m = ExecutionEnv {+ execReturn :: Jumper m Value+ , execNext :: Jumper m ()+ , execBreak :: Jumper m ()+ , execCont :: Jumper m ()+ }++setJump :: MonadBackend m =>+ (Jumper m a -> ExecutionEnv m -> ExecutionEnv m) + -> Execution m a -> Execution m a+setJump f m = callCC $ flip local m . f++doJump :: MonadBackend m =>+ (ExecutionEnv m -> Jumper m a) -> a -> Execution m ()+doJump b x = join $ asks b <*> pure x++returnHere :: MonadBackend m => Execution m Value -> Execution m Value+returnHere = setJump (\breaker env -> env { execReturn = breaker })++doReturn :: MonadBackend m => Value -> Execution m ()+doReturn = doJump execReturn++nextHere :: MonadBackend m => Execution m () -> Execution m ()+nextHere = setJump (\breaker env -> env { execNext = breaker })++doNext :: MonadBackend m => Execution m ()+doNext = doJump execNext ()++breakHere :: MonadBackend m => Execution m () -> Execution m ()+breakHere = setJump (\breaker env -> env { execBreak = breaker })++doBreak :: MonadBackend m => Execution m ()+doBreak = doJump execBreak ()++contHere :: MonadBackend m => Execution m () -> Execution m ()+contHere = setJump (\breaker env -> env { execCont = breaker })++doCont :: MonadBackend m => Execution m ()+doCont = doJump execCont ()++newtype Execution m a = Execution (ReaderT (ExecutionEnv m) (Sindre m) a)+ deriving (Functor, Monad, Applicative, MonadReader (ExecutionEnv m), MonadCont)++execute :: MonadBackend m => Execution m Value -> Sindre m Value+execute m = runReaderT m' env+ where env = ExecutionEnv {+ execReturn = fail "Nowhere to return to"+ , execNext = fail "Nowhere to go next"+ , execBreak = fail "Not in a loop"+ , execCont = fail "Not in a loop"+ }+ Execution m' = returnHere m+++execute_ :: MonadBackend m => Execution m a -> Sindre m ()+execute_ m = execute (m *> return (Number 0)) >> return ()++instance MonadBackend im => MonadSindre im Execution where+ sindre = Execution . lift++setScope :: MonadBackend m => [Value] -> Execution m a -> Execution m a+setScope vs ex =+ sindre (modify $ \s -> s { execFrame = m }) >> ex+ where m = IM.fromList $ zip [0..] vs++enterScope :: MonadBackend m => [Value] -> Execution m a -> Execution m a+enterScope vs se = do+ oldframe <- sindre $ gets execFrame+ setScope vs se <* sindre (modify $ \s -> s { execFrame = oldframe })++lexicalVal :: MonadBackend m => IM.Key -> Execution m Value+lexicalVal k = IM.findWithDefault falsity k <$> sindre (gets execFrame)++setLexical :: MonadBackend m => IM.Key -> Value -> Execution m ()+setLexical k v = sindre $ modify $ \s ->+ s { execFrame = IM.insert k v $ execFrame s }++type EventHandler m = Event -> Execution m ()++eventLoop :: MonadBackend m => EventHandler m -> Sindre m ()+eventLoop handler = do+ let redraw_ RedrawAll = redrawRoot+ redraw_ (RedrawSome s) = concat <$> mapM (`draw` Nothing) (S.toList s)+ >>= redrawRegion+ forever $ do+ process+ redraw_ =<< gets needsRedraw+ modify $ \s -> s { needsRedraw = RedrawSome S.empty }+ handle =<< waitForEvent+ where handle ev = execute $ nextHere (handler ev) >> return falsity+ process = do ev <- getEvent+ case ev of+ Just ev' -> handle ev' >> process+ Nothing -> return ()++class Mold a where+ mold :: Value -> Maybe a+ unmold :: a -> Value++instance Mold Value where+ mold = Just+ unmold = id++instance Mold String where+ mold = Just . show+ unmold = string++instance Mold T.Text where+ mold = Just . T.pack . show+ unmold = StringV++instance Mold Double where+ mold (Reference (v', _, _)) = Just $ fi v'+ mold (Number x) = Just x+ mold s = parseInteger (show s)+ unmold = Number++instance Mold Integer where+ mold (Reference (v', _, _)) = Just $ fi v'+ mold (Number x) = Just $ round x+ mold s = round <$> parseInteger (show s)+ unmold = Number . fromInteger++instance Mold Int where+ mold = liftM (fi :: Integer -> Int) . mold+ unmold = Number . fromIntegral++instance Mold Bool where+ mold = Just . true+ unmold False = falsity+ unmold True = truth++instance Mold () where+ mold _ = Just ()+ unmold _ = Number 0++aligns :: [(String, (Align, Align))]+aligns = [ ("top", (AlignCenter, AlignNeg))+ , ("topleft", (AlignNeg, AlignNeg))+ , ("topright", (AlignPos, AlignNeg))+ , ("bot", (AlignCenter, AlignPos))+ , ("botleft", (AlignNeg, AlignPos))+ , ("botright", (AlignPos, AlignPos))+ , ("mid", (AlignCenter, AlignCenter))+ , ("midleft", (AlignNeg, AlignCenter))+ , ("midright", (AlignPos, AlignCenter))]++instance Mold (Align, Align) where+ mold s = mold s >>= flip lookup aligns+ unmold a = maybe (Number 0) string $+ lookup a (map (uncurry $ flip (,)) aligns)
+ Sindre/Sindre.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Sindre+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- General definitions for the Sindre programming language. The+-- documentation for this module does not include a description of the+-- language semantics.+--+-----------------------------------------------------------------------------+module Sindre.Sindre ( + -- * Screen layout+ Rectangle(..),+ DimNeed(..),+ SpaceNeed,+ SpaceUse,+ Constraints,+ Align(..),+ -- ** Layouting functions+ constrainNeed,+ fitRect,+ splitHoriz,+ splitVert,+ rectTranspose,+ align,+ adjustRect,+ -- * Keyboard Input+ KeyModifier(..),+ Key(..),+ Chord,+ -- * Input positions+ P(..),+ at,+ SourcePos,+ nowhere,+ position,+ -- * Abstract syntax tree+ Identifier,+ Stmt(..),+ Expr(..),+ ObjectNum,+ ObjectRef,+ WidgetRef,+ -- ** Value representation+ Value(..),+ string,+ true,+ truth,+ falsity,+ -- ** Program structure+ Event(..),+ EventSource(..),+ SourcePat(..),+ Pattern(..),+ Action(..),+ Function(..),+ GUI(..),+ Program(..),+ SindreOption,+ Arguments+ )+ where++import System.Console.GetOpt++import Control.Applicative+import Data.List+import qualified Data.Map as M+import Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T++-- | A rectangle represented as its upper-left corner, width and+-- height. You should never create rectangles with negative+-- dimensions, and the functions in this module make no guarantee to+-- their behaviour if you do.+data Rectangle = Rectangle {+ rectX :: Integer+ , rectY :: Integer+ , rectWidth :: Integer+ , rectHeight :: Integer+ } deriving (Show, Eq)++instance Monoid Rectangle where+ mempty = Rectangle 0 0 (-1) (-1)+ mappend r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2)+ | r1 == mempty = r2+ | r2 == mempty = r1+ | otherwise = Rectangle x' y' (max (x1+w1-x') (x2+w2-x'))+ (max (y1+h1-y') (y2+h2-y'))+ where (x', y') = (min x1 x2, min y1 y2)++-- | Flip the x and y coordinates and width and height of a rectangle,+-- in a sense rotating it ninety degrees. Note that @rectTranspose+-- . rectTranspose = id@.+rectTranspose :: Rectangle -> Rectangle+rectTranspose (Rectangle x y w h) = Rectangle y x h w++zipper :: (([a], a, [a]) -> ([a], a, [a])) -> [a] -> [a]+zipper f = zipper' []+ where zipper' a (x:xs) = let (a', x', xs') = f (a, x, xs)+ in zipper' (x':a') xs'+ zipper' a [] = reverse a++divide :: Integral a => a -> a -> [a]+divide total n = map (const c) [0..n-2] ++ [c+r]+ where (c,r) = total `quotRem` n++-- | @splitHoriz rect dims@ splits @rect@ horizontally into a number+-- of non-overlapping equal-width rectangles stacked on top of each+-- other. @dims@ is a list of height requirements that the function+-- will attempt to fulfill as best it is able. The union of the list+-- of returned rectangles will always be equal to @rect@. No+-- rectangle will ever have negative dimensions.+splitHoriz :: Rectangle -> [DimNeed] -> [Rectangle]+splitHoriz (Rectangle x1 y1 w h) parts =+ snd $ mapAccumL mkRect y1 $ map fst $+ zipper adjust $ zip (divide h nparts) parts+ where nparts = genericLength parts+ mkRect y h' = (y+h', Rectangle x1 y w h')+ grab d (v, Min mv) | d > 0 = let d' = max 0 $ min d (v-mv)+ in ((v-d', Min mv), d-d')+ | otherwise = ((v-d, Min mv), 0)+ grab d (v, Max mv) | d > 0 = let d' = min v d+ in ((v-d', Max mv), d-d')+ | otherwise = let d' = max (v-mv) d+ in ((v-d', Max mv), d-d')+ grab d (v, Unlimited) = let v' = max 0 $ v - d+ in ((v', Unlimited), v'-v+d)+ grab d (v, Exact ev) | v > ev = let d' = min v $ min d $ v-ev+ in ((v-d', Exact ev), d-d')+ | v < ev = let d' = min v $ min d $ ev-v+ in ((v-d', Exact ev), d-d')+ | otherwise = ((v, Exact ev), d)+ maybeGrab (d:ds) ((x, True):xs) =+ (case grab d x of (x',0) -> ((x',True),0)+ (x',d') -> ((x',False),d')) : maybeGrab ds xs+ maybeGrab ds ((x, False):xs) = ((x,False),0) : maybeGrab ds xs+ maybeGrab _ _ = []+ obtain v bef aft =+ case (filter snd bef, filter snd aft) of+ ([],[]) -> (bef,aft,v)+ (bef',aft') ->+ let q = divide v $ genericLength $ bef'++aft'+ n = length bef'+ (bef'',x) = unzip $ maybeGrab q bef+ (aft'',y) = unzip $ maybeGrab (drop n q) aft+ r = sum x + sum y+ in if r /= 0 then obtain r bef'' aft'' else (bef'',aft'', r)+ adjust (bef, (v, Min mv), aft)+ | v < mv = adjust' Min bef v mv aft+ adjust (bef, (v, Max mv), aft)+ | v > mv = adjust' Max bef v mv aft+ adjust (bef, (v, Exact ev), aft)+ | v /= ev = adjust' Exact bef v ev aft+ adjust x = x+ adjust' f bef v mv aft =+ let (bef', aft', d) =+ obtain (mv-v) (map (,True) bef) (map (,True) aft)+ in (map fst bef', (v+(mv-v)-d, f mv), map fst aft')++-- | As @splitHoriz@, but splits vertically instead of horizontally,+-- so the rectangles will be next to each other.+splitVert :: Rectangle -> [DimNeed] -> [Rectangle]+splitVert r = map rectTranspose . splitHoriz (rectTranspose r)++-- | A size constraint in one dimension.+data DimNeed = Min Integer -- ^ At minimum this many pixels.+ | Max Integer -- ^ At most this many pixels.+ | Unlimited -- ^ As many or as few pixels as necessary.+ | Exact Integer -- ^ Exactly this many pixels.+ deriving (Eq, Show, Ord)++-- | Size constraints in both dimensions.+type SpaceNeed = (DimNeed, DimNeed)++-- | The amount of space actually used by a widget.+type SpaceUse = [Rectangle]++-- | Externally-imposed optional minimum and maximum values for width+-- and height.+type Constraints = ( (Maybe Integer, Maybe Integer)+ , (Maybe Integer, Maybe Integer))++-- | @constrainNeed need constraints@ reduces the space requirement+-- given by @need@ in order to fulfill @constraints@.+constrainNeed :: SpaceNeed -> Constraints -> SpaceNeed+constrainNeed (wreq, hreq) ((minw, maxw), (minh, maxh)) =+ (f wreq minw maxw, f hreq minh maxh)+ where f x Nothing Nothing = x+ f (Max x) (Just y) _ | x > y = Min x+ f (Max _) (Just y) _ = Max y+ f (Min x) (Just y) _ = Min $ max x y+ f _ (Just y) _ = Min y+ f _ _ (Just y) = Max y++-- | @fitRect rect need@ yields a rectangle as large as possible, but+-- no larger than @rect@, that tries to fulfill the constraints+-- @need@.+fitRect :: Rectangle -> SpaceNeed -> Rectangle+fitRect (Rectangle x y w h) (wn, hn) =+ Rectangle x y (fit w wn) (fit h hn)+ where fit d dn = case dn of+ Max dn' -> min d dn'+ Min _ -> d+ Exact ev -> min d ev+ Unlimited -> d++-- | Instruction on how to align a smaller interval within a larger+-- interval.+data Align = AlignNeg -- ^ Align towards negative infinity.+ | AlignPos -- ^ Align towards positive infinity.+ | AlignCenter -- ^ Align towards the center of the interval.+ deriving (Show, Eq)++-- | @align a lower x upper@, where @lower<=upper@, aligns a+-- subinterval of length @x@ in the interval @lower@ to @upper@,+-- returning the coordinate at which the aligned subinterval starts.+-- For example,+--+-- >>> align AlignCenter 2 4 10+-- 4+-- >>> align AlignNeg 2 4 10+-- 2+-- >>> align AlignPos 2 4 10+-- 6+align :: Integral a => Align -> a -> a -> a -> a+align AlignCenter minp d maxp = minp + (maxp - minp - d) `div` 2+align AlignNeg minp _ _ = minp+align AlignPos _ d maxp = maxp - d++-- | @adjustRect (walign, halign) bigrect smallrect@ returns a+-- rectangle with the same dimensions as @smallrect@ aligned within+-- @bigrect@ in both dimensions.+adjustRect :: (Align, Align) -> Rectangle -> Rectangle -> Rectangle+adjustRect (walign, halign) (Rectangle sx sy sw sh) (Rectangle _ _ w h) =+ Rectangle cx' cy' w h+ where cx' = frob walign sx w sw+ cy' = frob halign sy h sh+ frob AlignCenter c d maxv = c + (maxv - d) `div` 2+ frob AlignNeg c _ _ = c+ frob AlignPos c d maxv = c + maxv - d++-- | A keyboard modifier key. The precise meaning (and location) of+-- these is somewhat platform-dependent. Note that the @Shift@+-- modifier should not be passed along if the associated key is a+-- @CharKey@, as @Shift@ will already have been handled.+data KeyModifier = Control | Meta | Super | Hyper | Shift+ deriving (Eq, Ord, Show)++-- | Either a key corresponding to a visible character, or a control+-- key not associated with any character.+data Key = CharKey Char -- ^ Unicode character associated with the key.+ | CtrlKey String -- ^ Name of the control key, using X11+ -- key names (for example @BackSpace@ or+ -- @Return@).+ deriving (Show, Eq, Ord)++-- | A combination of a set of modifier keys and a primary key,+-- representing a complete piece of keyboard input.+type Chord = (S.Set KeyModifier, Key)++-- | Low-level reference to an object.+type ObjectNum = Int+-- | High-level reference to an object, containing its class and name+-- (if any) as well. For non-widgets, the object name is the same as+-- the object class.+type ObjectRef = (ObjectNum, Identifier, Maybe Identifier)+-- | High-level reference to a widget.+type WidgetRef = ObjectRef++-- | The type of names (such as variables and classes) in the syntax+-- tree.+type Identifier = String++-- | Dynamically typed run-time value in the Sindre language.+data Value = StringV T.Text+ | Number Double+ | Reference ObjectRef+ | Dict (M.Map Value Value)+ deriving (Eq, Ord)++instance Show Value where+ show (Number v) = if fromInteger v' == v then show v'+ else show v+ where v' = round v+ show (Reference (_,_,Just k)) = k+ show (Reference (r,c,Nothing)) = "#<" ++ c ++ " at " ++ show r ++ ">"+ show (Dict m) = "#<dictionary with "++show (M.size m)++" entries>"+ show (StringV v) = T.unpack v++-- | @string s@ returns a Sindre string.+string :: String -> Value+string = StringV . T.pack++-- | @true v@ returns 'True' if @v@ is interpreted as a true value in+-- Sindre, 'False' otherwise.+true :: Value -> Bool+true (Number 0) = False+true (StringV s) = s /= T.empty+true (Dict m) = m /= M.empty+true _ = True++-- | Canonical false value, see 'true'.+truth, falsity :: Value+-- ^ Canonical true value, see 'true'.+truth = Number 1+falsity = Number 0++-- | A position in a source file, consisting of a file name,+-- one-indexed line number, and one-indexed column number.+type SourcePos = (String, Int, Int)++-- | A default position when no other is available.+nowhere :: SourcePos+nowhere = ("<nowhere>", 0, 0)++-- | Prettyprint a source position in a human-readable form.+--+-- >>> position ("foobar.sindre", 5, 15)+-- "foobar.sindre:5:15: "+position :: SourcePos -> String+position (file, line, col) =+ file ++ ":" ++ show line ++ ":" ++ show col ++ ": "++-- | Wrap a value with source position information.+data P a = P { sourcePos :: SourcePos, unP :: a }+ deriving (Show, Eq, Ord, Functor)++-- | @x `at` y@ gives a value containing @x@, but with the same source+-- position as @y@.+at :: a -> P b -> P a+at e1 e2 = const e1 <$> e2++-- | The syntax of Sindre statements.+data Stmt = Print [P Expr]+ | Exit (Maybe (P Expr))+ | Return (Maybe (P Expr))+ | Next+ | If (P Expr) [P Stmt] [P Stmt]+ | While (P Expr) [P Stmt]+ | For (P Expr) (P Expr) (P Expr) [P Stmt]+ | Do [P Stmt] (P Expr)+ | Break+ | Continue+ | Expr (P Expr)+ | Focus (P Expr)+ deriving (Show, Eq)++-- | The syntax of Sindre expressions.+data Expr = Literal Value+ | Var Identifier+ | FieldOf Identifier (P Expr)+ | Lookup Identifier (P Expr)+ | Not (P Expr)+ | LessThan (P Expr) (P Expr)+ | LessEql (P Expr) (P Expr)+ | Equal (P Expr) (P Expr)+ | Assign (P Expr) (P Expr)+ | PostInc (P Expr)+ | PostDec (P Expr)+ | Concat (P Expr) (P Expr)+ | Plus (P Expr) (P Expr)+ | Minus (P Expr) (P Expr)+ | Times (P Expr) (P Expr)+ | Divided (P Expr) (P Expr)+ | Modulo (P Expr) (P Expr)+ | RaisedTo (P Expr) (P Expr)+ | Funcall Identifier [P Expr]+ | Methcall (P Expr) Identifier [P Expr]+ | Cond (P Expr) (P Expr) (P Expr)+ deriving (Show, Eq, Ord)++-- | Something that happened in the world.+data Event = KeyPress Chord+ | NamedEvent { eventName :: Identifier -- ^ The name of the event.+ , eventValue :: [Value] -- ^ The payload of the event.+ , eventSource :: EventSource -- ^ Where it's from.+ }+ deriving (Show)++-- | The origin of an event. This is used when determining where to+-- handle it.+data EventSource = FieldSrc ObjectRef Identifier+ -- ^ @FieldSrc obj f@ designates that the source of+ -- the event is the property @f@ of @obj@+ | ObjectSrc ObjectRef -- ^ The source is the given object.+ | BackendSrc -- ^ The source is something within the+ -- bowels of the active backend,+ -- probably from the external world.+ deriving (Show)++-- | Description of sets of sources, values of this type can be used+-- to pattern-match @EventSource@s.+data SourcePat = NamedSource Identifier (Maybe Identifier)+ -- ^ For @NamedSource k fk@, the source must be the+ -- object named @k@. If @fk@ is @Just fk'@, the source+ -- must also be the field named @fk'@.+ | GenericSource Identifier Identifier (Maybe Identifier)+ -- ^ For @GenericSource cn k fk@, the source must be+ -- of class @cn@. If @fk@ is @Just fk'@, the source+ -- must also be the field named @fk'@. The variable+ -- named @k@ should be bound to the actual object if+ -- this pattern matches.+ deriving (Eq, Ord, Show)++-- | A description of an event used to indicate how to handle+-- different events.+data Pattern = ChordPattern Chord -- ^ Match if the event is a chord.+ | OrPattern Pattern Pattern -- ^ Match if either pattern+ -- matches.+ | SourcedPattern { patternSource :: SourcePat+ , patternEvent :: Identifier+ , patternVars :: [Identifier]+ }+ -- ^ @SourcedPattern src ev vars@ matches if @src@+ -- matches the event source (see 'SourcePat') an @ev@+ -- matches the event name. @vars@ should be bound to+ -- the values in the payload of the event.+ deriving (Eq, Ord, Show)++-- | A function consists of lexically bound parameters and a body.+data Function = Function [Identifier] [P Stmt]+ deriving (Show, Eq)++-- | Reaction to an event.+data Action = StmtAction [P Stmt] -- ^ Execute these statements.+ deriving (Show)++-- | Widget arguments are key-value pairs, with a unique value for+-- each key.+type WidgetArgs = M.Map Identifier (P Expr)++-- | A Sindre GUI is a recursive tree, with each node representing a+-- single widget and consisting of the following fields.+data GUI = GUI {+ widgetName :: Maybe Identifier -- ^ Name of the widget, if any.+ , widgetClass :: P Identifier -- ^ Class of the widget.+ , widgetArgs :: WidgetArgs -- ^ The arguments passed to the widget.+ , widgetChildren :: [(Maybe (P Expr), GUI)] -- ^ Children of the widget, if any.+ } deriving (Show)++-- | A command line argument.+type SindreOption = OptDescr (Arguments -> Arguments)+-- | The arguments passed to the Sindre program from the command line.+type Arguments = M.Map String String++-- | A complete Sindre program. Note that this is intentionally+-- defined such that some invalid programs, like those with duplicate+-- definitions can be represented - the compiler (see+-- "Sindre.Compiler") should detect and handle such errors.+data Program = Program {+ programGUI :: (Maybe (P Expr), GUI)+ , programActions :: [P (Pattern, Action)]+ , programGlobals :: [P (Identifier, P Expr)]+ , programOptions :: [P (Identifier, (SindreOption, Maybe Value))]+ , programFunctions :: [P (Identifier, Function)]+ , programBegin :: [P Stmt] -- ^ The contents of the @BEGIN@ block.+ }
+ Sindre/Util.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Util+-- License : MIT-style (see LICENSE)+--+-- Stability : stable+-- Portability : portable+--+-- Various utility bits and pieces.+--+-----------------------------------------------------------------------------+module Sindre.Util+ ( io+ , fi+ , err+ , upcase+ , downcase+ , hsv2rgb+ , wrap+ , quote+ , clamp+ , mapAccumLM+ , ifM+ ) where++import Control.Monad.Trans++import Data.Char++import System.IO++-- | Short-hand for 'liftIO'+io :: MonadIO m => IO a -> m a+io = liftIO++-- | Short-hand for 'fromIntegral'+fi :: (Integral a, Num b) => a -> b+fi = fromIntegral++-- | Short-hand for 'liftIO . hPutStrLn stderr'+err :: MonadIO m => String -> m ()+err = io . hPutStrLn stderr++-- | Short-hand for 'map toUpper'+upcase :: String -> String+upcase = map toUpper++-- | Short-hand for 'map toLower'+downcase :: String -> String+downcase = map toLower++-- | Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space+hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a)+hsv2rgb (h,s,v) =+ let hi = div h 60 `mod` 6 :: Integer+ f = fi h/60 - fi hi :: Fractional a => a+ q = v * (1-f)+ p = v * (1-s)+ t = v * (1-(1-f)*s)+ in case hi of+ 0 -> (v,t,p)+ 1 -> (q,v,p)+ 2 -> (p,v,t)+ 3 -> (p,q,v)+ 4 -> (t,p,v)+ 5 -> (v,p,q)+ _ -> error "The world is ending. x mod a >= a."++-- | Prepend and append first argument to second argument.+wrap :: String -> String -> String+wrap x y = x ++ y ++ x++-- | Put double quotes around the given string.+quote :: String -> String+quote = wrap "\""++-- | Bound a value by minimum and maximum values.+clamp :: Ord a => a -> a -> a -> a+clamp lower x upper = min upper $ max lower x++-- | The 'mapAccumLM' function behaves like a combination of 'mapM' and+-- 'foldlM'; it applies a monadic function to each element of a list,+-- passing an accumulating parameter from left to right, and returning+-- a final value of this accumulator together with the new list.+mapAccumLM :: Monad m => (acc -> x -> m (acc, y))+ -> acc+ -> [x]+ -> m (acc, [y])+mapAccumLM _ s [] = return (s, [])+mapAccumLM f s (x:xs) = do+ (s', y ) <- f s x+ (s'',ys) <- mapAccumLM f s' xs+ return (s'',y:ys)++-- | Like 'when', but with two branches. A lifted @if@.+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM p t e = do b <- p+ if b then t else e
+ Sindre/Widgets.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.Widgets+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : portable+--+-- Portable Sindre gadgets and helper functions that can be used by+-- any backend.+--+-----------------------------------------------------------------------------+module Sindre.Widgets ( mkHorizontally+ , mkVertically+ , changeFields+ )+ where+ +import Sindre.Sindre+import Sindre.Compiler+import Sindre.Runtime++import Control.Monad.Error+import Control.Monad.State+import Control.Applicative++data Oriented = Oriented {+ mergeSpace :: [SpaceNeed] -> SpaceNeed+ , splitSpace :: Rectangle -> [SpaceNeed] -> [Rectangle]+ , 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+ where f (Min x) (Min y) = Min (x+y)+ f (Min x) (Max y) = Max (x+y)+ f (Min x) (Exact y) = Min (x+y)+ f (Max x) (Max y) = Max (x+y)+ f (Max x) (Exact y) = Max (x+y)+ f (Exact x) (Exact y) = Exact (x+y)+ f _ Unlimited = Unlimited+ f x y = f y x++sumSec :: [DimNeed] -> DimNeed+sumSec [] = Min 0+sumSec (d:ds) = foldl f d ds+ where f (Min x) (Min y) = Min $ max x y+ f (Min x) (Max y) | x < y = Max y+ f (Min x) (Max _) = Max x+ f (Min _) (Exact y) = Exact y+ f (Max x) (Max y) = Max $ max x y+ f (Max _) (Exact y) = Exact y+ f (Max x) Unlimited = Max x+ f (Exact x) (Exact y) = Exact $ max x y+ f (Exact x) Unlimited = Exact x+ f _ Unlimited = Unlimited+ 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)+ where merge rects = ( f (sumPrim, sumSec) $ map fst rects+ , f (sumSec, sumPrim) $ map snd rects )+ split r = f (splitVert, splitHoriz) r . map f++-- | A widget that arranges its children in a horizontal row.+mkHorizontally :: MonadBackend m => Constructor m+mkHorizontally = layouting fst++-- | A widget that arranges its children in a vertical column.+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
+ Sindre/X11.hs view
@@ -0,0 +1,1228 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Sindre.X11+-- License : MIT-style (see LICENSE)+--+-- Stability : provisional+-- Portability : unportable+--+-- X11 backend for Sindre. For internationalised keyboard input to+-- work, make sure the locale is correctly set.+--+-----------------------------------------------------------------------------+module Sindre.X11( SindreX11M+ , SindreX11Conf(sindreDisplay, sindreXftMgr)+ , sindreX11override+ , sindreX11dock+ , sindreX11+ , xopt+ , VisualOpts(..)+ , visualOpts+ , allocColor+ , drawing+ , drawing'+ , Drawer(..)+ , setFgColor+ , setBgColor+ , textExtents+ , drawText+ , mkDial+ , mkLabel+ , mkBlank+ , mkTextField+ , mkInStream+ , mkHList+ , mkVList+ )+ where++import Sindre.Sindre+import Sindre.Compiler+import Sindre.Formatting+import Sindre.KeyVal ((<$?>), (<||>))+import qualified Sindre.KeyVal as KV+import Sindre.Lib+import Sindre.Runtime+import Sindre.Util+import Sindre.Widgets++import Graphics.X11.Xlib hiding ( refreshKeyboardMapping+ , Rectangle + , badValue+ , resourceManagerString+ , textWidth+ , allocColor+ , textExtents )+import Graphics.X11.XRM+import qualified Graphics.X11.Xft as Xft+import Graphics.X11.Xim+import Graphics.X11.Xinerama+import Graphics.X11.Xlib.Extras hiding (Event, getEvent)+import Graphics.X11.Xshape+import qualified Graphics.X11.Xlib as X+import qualified Graphics.X11.Xlib.Extras as X++import System.Environment+import System.Exit+import System.IO+import System.Posix.Types++import Control.Arrow(first,second)+import Control.Concurrent+import Control.Applicative+import Control.Exception+import Control.Monad.Reader+import Control.Monad.State+import Data.Bits+import Data.Char hiding (Control)+import Data.Maybe+import Data.List+import qualified Data.ByteString as B+import qualified Data.Map as M+import Data.Monoid+import Data.Ord+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as E++import Prelude hiding (catch)++fromXRect :: X.Rectangle -> Rectangle+fromXRect r =+ Rectangle { rectX = fi $ rect_x r+ , rectY = fi $ rect_y r+ , rectWidth = fi $ rect_width r+ , rectHeight = fi $ rect_height r }++type EventThunk = Sindre SindreX11M (Maybe Event)++data Surface = Surface {+ surfaceBounds :: Rectangle+ , surfaceShape :: Drawable+ , surfaceMaskGC :: GC+ , surfaceUnmaskGC :: GC+ , surfaceCanvas :: Drawable+ , surfaceWindow :: Window+ , surfaceWindowGC :: GC+ , surfaceScreen :: Screen+ , surfaceXftDraw :: Xft.Draw+ }++newSurfaceWithGC :: Display -> Xft.XftMgr -> Screen -> Window -> GC -> Rectangle -> IO Surface+newSurfaceWithGC dpy mgr scr win wingc r = do+ pm <- createPixmap dpy win (fi $ rectWidth r) (fi $ rectHeight r) 1+ maskgc <- createGC dpy pm+ setForeground dpy maskgc 0+ unmaskgc <- createGC dpy pm+ setForeground dpy unmaskgc 1+ canvas <- createPixmap dpy win (fi $ rectWidth r) (fi $ rectHeight r) $+ defaultDepthOfScreen scr+ drw <- Xft.openDraw mgr canvas (defaultVisualOfScreen scr)+ (defaultColormap dpy $ defaultScreen dpy)+ drw' <- maybe (fail "Could not allocate Xft drawable") return drw+ return $ Surface r { rectX = 0, rectY = 0 } pm maskgc+ unmaskgc canvas win wingc scr drw'++newSurface :: Display -> Xft.XftMgr -> Screen -> Window -> Rectangle -> IO Surface+newSurface dpy mgr scr win r = do wingc <- createGC dpy win+ setGraphicsExposures dpy wingc False+ newSurfaceWithGC dpy mgr scr win wingc r++resizeSurface :: Display -> Xft.XftMgr -> Surface -> Rectangle -> IO Surface+resizeSurface dpy mgr s r = do+ mapM_ (freeGC dpy) [surfaceMaskGC s, surfaceUnmaskGC s]+ mapM_ (freePixmap dpy) [surfaceShape s, surfaceCanvas s]+ newSurfaceWithGC dpy mgr (surfaceScreen s) (surfaceWindow s) (surfaceWindowGC s) r++setShape :: Display -> Surface -> [Rectangle] -> IO ()+setShape dpy s rects = do+ fillRectangle dpy (surfaceShape s) (surfaceMaskGC s) 0 0+ (fi $ rectWidth $ surfaceBounds s) (fi $ rectHeight $ surfaceBounds s)+ forM_ rects $ \rect ->+ fillRectangle dpy (surfaceShape s) (surfaceUnmaskGC s)+ (fi $ rectX rect)+ (fi $ rectY rect)+ (fi $ rectWidth rect)+ (fi $ rectHeight rect)+ xshapeCombineMask dpy (surfaceWindow s) shapeBounding+ 0 0 (surfaceShape s) shapeSet++copySurface :: Display -> Surface -> [Rectangle] -> IO ()+copySurface dpy s rects = do+ let Rectangle{..} = mconcat rects+ copyArea dpy (surfaceCanvas s) (surfaceWindow s) (surfaceWindowGC s)+ (fi rectX) (fi rectY) (fi rectWidth) (fi rectHeight) (fi rectX) (fi rectY)++-- | The read-only configuration of the X11 backend, created during+-- backend initialisation.+data SindreX11Conf = SindreX11Conf {+ sindreDisplay :: Display+ -- ^ The display that we are connected to.+ , sindreVisualOpts :: VisualOpts+ -- ^ The default visual options (color, font, etc) used if no+ -- others are specified for a widget.+ , sindreRMDB :: Maybe RMDatabase+ -- ^ The X11 resource database (Xdefaults/Xresources).+ , sindreXlock :: Xlock+ -- ^ Synchronisation lock for Xlib access.+ , sindreEvtVar :: MVar EventThunk+ -- ^ Channel through which events are sent by other threads to the+ -- Sindre command loop.+ , sindreReshape :: [Rectangle] -> SindreX11M ()+ -- ^ Function to set the shape of the X11 window to the union of the+ -- given rectangles.+ , sindreXftMgr :: Xft.XftMgr+ -- ^ Bookkeeping primitive for Xft font handling.+ }++-- | Sindre backend using Xlib.+newtype SindreX11M a = SindreX11M (ReaderT SindreX11Conf (StateT Surface IO) a)+ deriving ( Functor, Monad, MonadIO+ , MonadReader SindreX11Conf, MonadState Surface, Applicative)++runSindreX11 :: SindreX11M a -> SindreX11Conf -> Surface -> IO a+runSindreX11 (SindreX11M m) = evalStateT . runReaderT m++instance MonadBackend SindreX11M where+ type BackEvent SindreX11M = (KeySym, String, X.Event)+ type RootPosition SindreX11M = (Align, Align)++ redrawRoot = do+ SindreX11Conf{ sindreReshape=reshape } <- back ask+ sur <- back get+ (orient, rootwr) <- gets rootWidget+ reqs <- compose rootwr+ let winsize = surfaceBounds sur+ orient' = fromMaybe (AlignCenter, AlignCenter) orient+ rect = adjustRect orient' winsize $ fitRect winsize reqs+ usage <- draw rootwr $ Just rect+ back $ reshape usage+ redrawRegion usage++ redrawRegion rects = back $ do+ SindreX11Conf{ sindreDisplay=dpy } <- ask+ sur <- get+ io $ copySurface dpy sur rects >> sync dpy False+ + waitForBackEvent = do+ back unlockX+ evvar <- back $ asks sindreEvtVar+ evm <- io $ takeMVar evvar+ ev <- evm+ back lockX+ maybe waitForBackEvent return ev+ + getBackEvent = do+ io yield+ back (io . tryTakeMVar =<< asks sindreEvtVar) >>=+ fromMaybe (return Nothing)++ printVal s = io $ putStr s *> hFlush stdout++textExtents :: Xft.Font -> String -> SindreX11M (Int, Int)+textExtents font s = do dpy <- asks sindreDisplay+ w <- io $ Xft.textWidth dpy font s+ return (w, Xft.height font)++drawText :: (Integral x, Integral y, Integral z) => Xft.Color -> Xft.Font+ -> x -> y -> z -> String -> SindreX11M ()+drawText col font x y h str = do+ drw <- gets surfaceXftDraw+ (_,h') <- textExtents font str+ let y' = Xft.ascent font + align AlignCenter (fi y) h' (fi y+fi h)+ io $ Xft.drawString drw col font x y' str++drawFmt :: Drawer -> Rectangle -> FormatString -> SindreX11M ()+drawFmt d Rectangle{..} fs = do+ mgr <- asks sindreXftMgr+ drw <- gets surfaceXftDraw+ d'' <- case startBg fs of Nothing -> return d+ Just col -> io . setBgColor d =<< allocColor mgr col+ io $ Xft.drawRect drw (drawerBgColor d'') rectX rectY (padding::Int) rectHeight+ let proc (x,d') (Fg fg) = do col <- allocColor mgr fg+ return (x, d' { drawerFgColor = col })+ proc (x,d') (DefFg) = return (x, d' { drawerFgColor = drawerFgColor d })+ proc (x,d') (Bg bg) = do col <- allocColor mgr bg+ return (x, d' { drawerBgColor = col })+ proc (x,d') (DefBg) = return (x, d' { drawerBgColor = drawerBgColor d })+ proc (x,d') (Text t) = do+ let s = T.unpack t+ (w,_) <- textExtents (drawerFont d') s+ io $ Xft.drawRect drw (drawerBgColor d') x rectY w rectHeight+ drawText (drawerFgColor d') (drawerFont d')+ x (rectY + padding) (rectHeight - padding) s+ return (x+w, d')+ (endx, d') <- foldM proc (fi rectX + padding, d'') fs+ io $ Xft.drawRect drw (drawerBgColor d') endx rectY+ (max 0 $ fi rectX + fi rectWidth - endx) rectHeight++fmtSize :: Xft.Font -> FormatString -> SindreX11M Rectangle+fmtSize font s = do+ (w,h) <- textExtents font s'+ return $ Rectangle 0 0 (fi w + 2 * padding) (fi h + 2 * padding)+ where s' = T.unpack $ textContents s++getModifiers :: KeyMask -> S.Set KeyModifier+getModifiers m = foldl add S.empty modifiers+ where add s (x, mods) | x .&. m /= 0 = S.insert mods s+ | otherwise = s+ modifiers = [ (controlMask, Control)+ , (mod1Mask, Meta)+ , (shiftMask, Shift) ]++setupDisplay :: String -> IO Display+setupDisplay dstr =+ openDisplay dstr `catch` \e ->+ error $ "Cannot open display \"" ++ dstr ++ "\": "+ ++ show (e :: IOException)++grabInput :: Display -> Window -> IO GrabStatus+grabInput dpy win = do+ grabButton dpy button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none+ grab (1000 :: Int)+ where grab 0 = return alreadyGrabbed+ grab n = do status <- grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime+ if status /= grabSuccess+ then threadDelay 1000 >> grab (n-1)+ else return status++findRectangle :: Display -> Window -> IO X.Rectangle+findRectangle dpy rootw = do+ (win, _) <- getInputFocus dpy+ (x,y) <- if rootw == win then windowWithPointer+ else windowWithFocus =<< getWindowAttributes dpy win+ let contains rect = fi x >= rect_x rect &&+ fi (rect_width rect) + rect_x rect > fi x &&+ fi y >= rect_y rect &&+ fi (rect_height rect) + rect_y rect > fi y+ fromJust <$> find contains <$> getScreenInfo dpy+ where windowWithPointer = do+ (_, _, _, x, y, _, _, _) <- queryPointer dpy rootw+ return (x,y)+ windowWithFocus attr = do+ (_, x, y, _) <- translateCoordinates dpy rootw rootw+ (fi $ wa_x attr) (fi $ wa_y attr)+ return (fi x,fi y)++mkWindow :: Display -> Screen -> Window -> Bool -> Position+ -> Position -> Dimension -> Dimension -> IO Window+mkWindow dpy s rw o x y w h = do+ let visual = defaultVisualOfScreen s+ attrmask = cWOverrideRedirect+ black = blackPixelOfScreen s+ white = whitePixelOfScreen s+ io $ allocaSetWindowAttributes $ \attrs -> do+ set_override_redirect attrs o+ set_background_pixel attrs white+ set_border_pixel attrs black+ createWindow dpy rw x y w h 0 copyFromParent+ inputOutput visual attrmask attrs++type Xlock = MVar ()++lockXlock :: MonadIO m => Xlock -> m ()+lockXlock xlock = io $ takeMVar xlock+lockX :: SindreX11M ()+lockX = do xlock <- asks sindreXlock+ io $ takeMVar xlock++unlockXlock :: MonadIO m => Xlock -> m ()+unlockXlock xlock = io $ putMVar xlock ()+unlockX :: SindreX11M ()+unlockX = do xlock <- asks sindreXlock+ io $ putMVar xlock ()++getX11Event :: Display -> Window -> XIC -> IO (KeySym, String, X.Event)+getX11Event dpy win ic = do+ (str,keysym,event) <-+ allocaXEvent $ \e -> do+ nextEvent dpy e+ ev <- X.getEvent e+ (ks,s) <- ifM ((ev_event_type ev /= keyPress ||) <$>+ filterEvent e win)+ (return (Nothing, Nothing))+ (utf8LookupString ic e)+ return (ks,s,ev)+ return ( fromMaybe xK_VoidSymbol keysym+ , fromMaybe "" str+ , event)++processX11Event :: (KeySym, String, X.Event) -> EventThunk+processX11Event (ks, s, KeyEvent {ev_event_type = t, ev_state = m })+ | t == keyPress =+ return $ (KeyPress . mods) <$>+ case s of+ _ | s `elem` ["\127", "\8", "\13", "", "\27"] ->+ Just $ CtrlKey $ keysymToString ks+ [c] | not (isPrint c) ->+ case keysymToString ks of+ [ks'] -> Just $ CharKey ks'+ ks' -> Just $ CtrlKey ks'+ [c] -> Just $ CharKey c+ _ -> Nothing+ where mods (CharKey c) = (Shift `S.delete` getModifiers m, CharKey c)+ mods (CtrlKey c) = (getModifiers m, CtrlKey c)+processX11Event (_, _, ExposeEvent { ev_x = x, ev_y = y+ , ev_width = w, ev_height = h }) =+ redrawRegion [Rectangle (fi x) (fi y) (fi w) (fi h)] >> return Nothing+processX11Event (_, _, ConfigureEvent { ev_window = win+ , ev_width = w, ev_height = h }) = do+ back $ do onsurface <- (==win) <$> gets surfaceWindow+ when onsurface $ do+ sur <- (pure resizeSurface+ <*> asks sindreDisplay+ <*> asks sindreXftMgr <*> get+ <*> pure (Rectangle 0 0 (fi w) (fi h)))+ put =<< io sur+ redrawRoot >> return Nothing+processX11Event (_, _, AnyEvent { ev_event_type = t })+ | t == visibilityNotify = do back $ do+ dpy <- asks sindreDisplay+ win <- gets surfaceWindow+ io $ raiseWindow dpy win+ redrawRoot+ return Nothing+processX11Event _ = return Nothing++eventReader :: Display -> Window -> XIC -> MVar EventThunk ->+ Xlock -> IO ()+eventReader dpy win ic evvar xlock = forever $ do+ lockXlock xlock+ waitUntilEvent+ xev <- getX11Event dpy win ic+ unlockXlock xlock+ putMVar evvar $ processX11Event xev+ where waitUntilEvent = do+ cnt <- eventsQueued dpy queuedAfterFlush+ when (cnt == 0) $ do+ -- The following two lines have a race condition.+ unlockXlock xlock+ threadWaitRead $ Fd $ connectionNumber dpy+ lockXlock xlock+ waitUntilEvent++-- | Get the value for a named color if it exists+maybeAllocColor :: Xft.XftMgr -> String -> IO (Maybe Xft.Color)+maybeAllocColor mgr c = Xft.openColorName mgr vis colormap c+ where colormap = defaultColormap dpy $ defaultScreen dpy+ dpy = Xft.mgrDisplay mgr+ vis = defaultVisualOfScreen $ defaultScreenOfDisplay dpy++allocColor :: MonadIO m => Xft.XftMgr -> String -> m Xft.Color+allocColor dpy c = io (maybeAllocColor dpy c) >>=+ maybe (fail $ "Unknown color '"++c++"'") return++sindreEventMask :: EventMask+sindreEventMask = exposureMask .|. structureNotifyMask++sindreX11Cfg :: String -> Bool -> IO (SindreX11Conf, Surface)+sindreX11Cfg dstr o = do+ sl <- supportsLocale+ unless sl $ putStrLn "Current locale is not supported" >> exitFailure+ _ <- setLocaleModifiers ""+ dpy <- setupDisplay dstr+ let scr = defaultScreenOfDisplay dpy+ xlock <- newMVar ()+ mgr <- Xft.newXftMgr dpy scr (lockXlock xlock) (unlockXlock xlock)+ rmInitialize+ s <- resourceManagerString dpy+ db <- case s of Nothing -> return Nothing+ Just s' -> rmGetStringDatabase s'+ rect <- findRectangle dpy (rootWindowOfScreen scr)+ win <- mkWindow dpy scr (rootWindowOfScreen scr) o+ (rect_x rect) (rect_y rect) (rect_width rect) (rect_height rect)+ surface <- newSurface dpy mgr scr win (fromXRect rect)+ setShape dpy surface []+ im <- openIM dpy Nothing Nothing Nothing+ ic <- createIC im [XIMPreeditNothing, XIMStatusNothing] win+ evvar <- newEmptyMVar+ _ <- forkIO $ eventReader dpy win ic evvar xlock+ visopts <- defVisualOpts mgr+ return (SindreX11Conf+ { sindreDisplay = dpy+ , sindreVisualOpts = visopts+ , sindreRMDB = db+ , sindreEvtVar = evvar+ , sindreXlock = xlock+ , sindreReshape = reshape+ , sindreXftMgr = mgr }, surface)+ where reshape rs = do sur <- get+ dpy <- asks sindreDisplay+ io $ setShape dpy sur rs++-- | Options regarding visual appearance of widgets (colors and+-- fonts).+data VisualOpts = VisualOpts {+ foreground :: Xft.Color+ , background :: Xft.Color+ , focusForeground :: Xft.Color+ , focusBackground :: Xft.Color+ , font :: Xft.Font+ }++defVisualOpts :: Xft.XftMgr -> IO VisualOpts+defVisualOpts mgr = do+ font <- Xft.openFontName mgr "Monospace"+ case font of Just font' ->+ pure VisualOpts <*> f fg <*> f bg <*> f ffg <*> f fbg+ <*> pure font'+ Nothing -> fail "Cannot open Monospace font"+ where (fg, bg, ffg, fbg) = ("black", "grey", "white", "blue")+ f = allocColor mgr++-- | Execute Sindre in the X11 backend, grabbing control of the entire+-- display and staying on top.+sindreX11override :: String -- ^ The display string (usually the value of the+ -- environment variable @$DISPLAY@ or @:0@)+ -> SindreX11M ExitCode+ -- ^ The function returned by+ -- 'Sindre.Compiler.compileSindre' after command line+ -- options have been given+ -> IO ExitCode+sindreX11override dstr start = do+ (cfg, sur) <- sindreX11Cfg dstr True+ _ <- io $ mapRaised (sindreDisplay cfg) (surfaceWindow sur)+ status <- grabInput (sindreDisplay cfg) (surfaceWindow sur)+ io $ selectInput (sindreDisplay cfg) (surfaceWindow sur) $+ sindreEventMask .|. visibilityChangeMask+ unless (status == grabSuccess) $+ error "Could not establish keyboard grab"+ runSindreX11 (lockX >> start) cfg sur <* Xft.freeXftMgr (sindreXftMgr cfg)++-- | Execute Sindre in the X11 backend as an ordinary client visible+-- to the window manager.+sindreX11 :: String -- ^ The display string (usually the value of the+ -- environment variable @$DISPLAY@ or @:0@)+ -> SindreX11M ExitCode+ -- ^ The function returned by+ -- 'Sindre.Compiler.compileSindre' after command line+ -- options have been given+ -> IO ExitCode+sindreX11 dstr start = do+ (cfg, sur) <- sindreX11Cfg dstr False+ _ <- io $ mapRaised (sindreDisplay cfg) (surfaceWindow sur)+ selectInput (sindreDisplay cfg) (surfaceWindow sur) $+ keyPressMask .|. keyReleaseMask .|. sindreEventMask+ runSindreX11 (lockX >> start) cfg sur++-- | Execute Sindre in the X11 backend as a dock/statusbar.+sindreX11dock :: String -- ^ The display string (usually the value of the+ -- environment variable @$DISPLAY@ or @:0@)+ -> SindreX11M ExitCode+ -- ^ The function returned by+ -- 'Sindre.Compiler.compileSindre' after command line+ -- options have been given+ -> IO ExitCode+sindreX11dock dstr start = do+ (cfg, sur) <- sindreX11Cfg dstr False+ let d = sindreDisplay cfg+ w = surfaceWindow sur+ a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False+ c1 <- internAtom d "CARDINAL" False+ a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False+ c2 <- internAtom d "ATOM" False+ v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False+ let reshape rs = do+ io $ changeProperty32 d w a1 c1 propModeReplace $ map fi $+ getStrutValues (mconcat rs) (surfaceBounds sur)+ sindreReshape cfg rs+ changeProperty32 d w a2 c2 propModeReplace [fi v]+ selectInput (sindreDisplay cfg) (surfaceWindow sur) sindreEventMask+ lowerWindow (sindreDisplay cfg) (surfaceWindow sur)+ _ <- mapWindow (sindreDisplay cfg) (surfaceWindow sur)+ runSindreX11 (lockX >> start) cfg { sindreReshape = reshape } sur+ where strutArea [left, right, top, bot,+ left_y1, left_y2, right_y1, right_y2,+ top_x1, top_x2, bot_x1, bot_x2] =+ left*(left_y2-left_y1)+right*(right_y2-right_y1)++ top*(top_x2-top_x1)+bot*(bot_x2-bot_x1)+ strutArea _ = 0+ getStrutValues r1 r2 = minimumBy (comparing strutArea)+ [[0,0,rectY r1+rectHeight r1,0,+ 0,0,0,0,rectX r1,rectX r1 + rectWidth r1,0,0],+ [0,0,0,rectHeight r2 - rectY r1,+ 0,0,0,0,0,0,rectX r1,rectX r1 + rectWidth r1],+ [rectX r1+rectWidth r1,0,0,0,+ rectY r1,rectY r1 + rectHeight r1,0,0,0,0,0,0],+ [0,rectWidth r2 - rectX r1,0,0,+ 0,0,rectY r1,rectY r1 + rectHeight r1,0,0,0,0]+ ]++data InStream = InStream Handle++instance (MonadIO m, MonadBackend m) => Object m InStream where++-- | An input stream object wrapping the given 'Handle'. Input is+-- purely event-driven and line-oriented: the event @lines@ is sent+-- (roughly) for each sequence of lines that can be read without+-- blocking, with the payload being a single string value containing+-- the lines read since the last time the event was sent. When end of+-- file is reached, the @eof@ event (no payload) is sent.+mkInStream :: Handle -> ObjectRef -> SindreX11M (NewObject SindreX11M)+mkInStream h r = do+ evvar <- asks sindreEvtVar+ linevar <- io newEmptyMVar+ let putEv ev = putMVar evvar $ return $ Just $ ev $ ObjectSrc r+ getLines = do+ line <- takeMVar linevar+ case line of Just line' -> getLines' [line'] >> getLines+ Nothing -> putEv $ NamedEvent "eof" []+ getLines' lns = do+ line <- yield >> tryTakeMVar linevar+ case line of Just Nothing -> do+ putEv $ NamedEvent "lines" [asStr lns]+ putEv $ NamedEvent "eof" []+ Just (Just line') -> getLines' $ line' : lns+ Nothing -> putEv $ NamedEvent "lines" [asStr lns]+ readLines = forever (putMVar linevar =<<+ Just <$> E.decodeUtf8 <$> B.hGetLine h)+ `catch` (\(_::IOException) -> putMVar linevar Nothing)+ _ <- io $ forkIO getLines+ _ <- io $ forkIO readLines+ return $ NewObject $ InStream h+ where asStr = StringV . T.unlines . reverse++-- | Performs a lookup in the X resources database for a given+-- property. The class used is @/Sindre/./class/./property/@ and the+-- name is @/progname/./name/./property/@, where /progname/ is the+-- value of 'getProgName'.+xopt :: Param SindreX11M a => Maybe String+ -- ^ Name of widget, using @_@ if 'Nothing' is passed+ -> String -- ^ Widget class+ -> String -- ^ Property name+ -> ConstructorM SindreX11M a+xopt name clss attr = do+ progname <- io getProgName+ let clss' = "Sindre" ++ "." ++ clss ++ "." ++ attr+ name' = progname ++ "." ++ fromMaybe "_" name ++ "." ++ attr+ mdb <- back $ asks sindreRMDB+ case mdb of+ Nothing -> noParam name'+ Just db -> do+ res <- io $ rmGetResource db name' clss'+ case res of+ Nothing -> noParam name'+ Just ("String", v) -> do+ v' <- io $ rmValue v+ maybe (badValue name' $ string v') return =<< back (moldM $ string v')+ Just _ -> badValue name' $ string "<Not a string property>"++instance Param SindreX11M Xft.Color where+ moldM (mold -> Just c) =+ io . flip maybeAllocColor c =<< asks sindreXftMgr+ moldM _ = return Nothing++instance Param SindreX11M Xft.Font where+ moldM (true -> False) = return Nothing+ moldM (mold -> Just s) = do+ mgr <- asks sindreXftMgr+ io $ Xft.openFontName mgr s+ moldM _ = return Nothing++-- | Read visual options from either widget parameters or the X+-- resources database using 'xopt', or a combination. The following+-- graphical components are read:+--+-- [@Foreground color@] From @fg@ parameter or @foreground@ X+-- property.+--+-- [@Background color@] From @bg@ parameter or @background@ X+-- property.+--+-- [@Focus foreground color@] From @ffg@ parameter or+-- @focusForeground@ X property.+--+-- [@Focus background color@] From @fbg@ parameter or+-- @focusBackground@ X property.+visualOpts :: WidgetRef -> ConstructorM SindreX11M VisualOpts+visualOpts (_, clss, name) = do+ VisualOpts {..} <- back $ asks sindreVisualOpts+ flipcol <- param "highlight" <|> return False+ let pert = if flipcol then flip (,) else (,)+ (fgs, ffgs) = pert ("foreground", foreground)+ ("focusForeground", focusForeground)+ (bgs, fbgs) = pert ("background", background)+ ("focusBackground", focusBackground)+ font' <- paramM "font" <|> xopt name clss "font" <|> return font+ fg <- paramM "fg" <|> xopt name clss (fst fgs) <|> pure (snd fgs)+ bg <- paramM "bg" <|> xopt name clss (fst bgs) <|> pure (snd bgs)+ ffg <- paramM "ffg" <|> xopt name clss (fst ffgs) <|> pure (snd ffgs)+ fbg <- paramM "fbg" <|> xopt name clss (fst fbgs) <|> pure (snd fbgs)+ return VisualOpts { foreground = fg, background = bg,+ focusForeground = ffg, focusBackground = fbg,+ font = font' }++-- | Helper function that makes it easier it write consistent widgets+-- in the X11 backend. The widget is automatically filled with its+-- (nonfocus) background color. You are supposed to use this in the+-- 'drawI' method of a 'Widget' instance definition. An example:+--+-- @+-- drawI = drawing myWidgetWin myWidgetVisual $ \r fg bg ffg fbg -> do+-- fg drawString 0 5 \"foreground\"+-- bg drawString 0 15 \"background\"+-- ffg drawString 0 25 \"focus foreground\"+-- fbg drawString 0 35 \"focus background\"+-- @+drawing :: (a -> VisualOpts)+ -> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M [Rectangle])+ -- ^ The body of the @drawing@ call - this function is called+ -- with a rectangle representing the area of the widget, and+ -- 'Drawer's for "foreground," "background", "focus+ -- foreground", and "focus background" respectively.+ -> Rectangle -> ObjectM a SindreX11M SpaceUse+drawing vf m r@Rectangle{..} = do+ dpy <- back $ asks sindreDisplay+ canvas <- back $ gets surfaceCanvas+ VisualOpts{..} <- vf <$> get+ let mkgc fg bg = io $ do gc <- createGC dpy canvas+ setForeground dpy gc $ Xft.pixel fg+ setBackground dpy gc $ Xft.pixel bg+ return gc+ let pass fgc bgc = do fggc <- mkgc fgc bgc+ bggc <- mkgc bgc fgc+ return $ Drawer (\f -> f dpy canvas fggc)+ (\f -> f dpy canvas bggc)+ font fgc bgc+ gcsOf d = [fg d $ \_ _ gc -> gc, bg d $ \_ _ gc -> gc]+ normal <- pass foreground background+ focus <- pass focusForeground focusBackground+ io $ bg normal fillRectangle (fi rectX) (fi rectY)+ (fi rectWidth) (fi rectHeight)+ m r normal focus+ <* io (mapM_ (freeGC dpy) (gcsOf normal++gcsOf focus) >> sync dpy False)++-- | Variant of @drawing@ that assumes the entire rectangle is used.+drawing' :: (a -> VisualOpts)+ -> (Rectangle -> Drawer -> Drawer -> ObjectM a SindreX11M ())+ -> Rectangle -> ObjectM a SindreX11M SpaceUse+drawing' vf m = drawing vf $ \r normal focus -> do+ m r normal focus+ return [r]++-- | A small function that automatically passes appropriate 'Display',+-- 'Window' and 'GC' values to an Xlib drawing function (that,+-- conveniently, always accepts these arguments in the same order).+type CoreDrawer f = (Display -> Drawable -> GC -> f) -> f++data Drawer = Drawer { fg :: forall f. CoreDrawer f+ , bg :: forall f. CoreDrawer f+ , drawerFont :: Xft.Font+ , drawerFgColor :: Xft.Color+ , drawerBgColor :: Xft.Color+ }++setFgColor :: Drawer -> Xft.Color -> IO Drawer+setFgColor d c = do+ fg d $ \dpy _ gc -> setForeground dpy gc $ Xft.pixel c+ bg d $ \dpy _ gc -> setBackground dpy gc $ Xft.pixel c+ return d { drawerFgColor = c }++setBgColor :: Drawer -> Xft.Color -> IO Drawer+setBgColor d c = do+ fg d $ \dpy _ gc -> setBackground dpy gc $ Xft.pixel c+ bg d $ \dpy _ gc -> setForeground dpy gc $ Xft.pixel c+ return d { drawerBgColor = c }++padding :: Integral a => a+padding = 2+ +data Dial = Dial { dialMax :: Integer+ , dialVal :: Integer+ , dialVisual :: VisualOpts+ }++instance Object SindreX11M Dial where+ fieldSetI "value" (mold -> Just v) = do+ modify $ \s -> s { dialVal = clamp 0 v (dialMax s) }+ redraw >> unmold <$> gets dialVal+ fieldSetI _ _ = return $ Number 0+ fieldGetI "value" = unmold <$> gets dialVal+ fieldGetI _ = return $ Number 0++ recvEventI (KeyPress (_, CharKey 'n')) =+ changeFields [("value", unmold . dialVal)] $ \s -> do+ redraw+ return s { dialVal = clamp 0 (dialVal s+1) (dialMax s) }+ recvEventI (KeyPress (_, CharKey 'p')) =+ changeFields [("value", unmold . dialVal)] $ \s -> do+ redraw+ return s { dialVal = clamp 0 (dialVal s-1) (dialMax s) }+ recvEventI _ = return ()++instance Widget SindreX11M Dial where+ composeI = return (Exact 50, Exact 50)+ drawI = drawing' dialVisual $ \Rectangle{..} d _ -> do+ val <- gets dialVal+ maxval <- gets dialMax+ io $ do+ let unitAng = 2*pi / fi maxval+ angle = (-unitAng) * fi val :: Double+ dim = min rectWidth rectHeight - 1+ cornerX = fi rectX + (rectWidth - dim) `div` 2+ cornerY = fi rectY + (rectHeight - dim) `div` 2+ fg d drawArc (fi cornerX) (fi cornerY) (fi dim) (fi dim) 0 (360*64)+ fg d fillArc (fi cornerX) (fi cornerY)+ (fi dim) (fi dim) (90*64) (round $ angle * (180/pi) * 64)+ fg d drawRectangle (fi cornerX) (fi cornerY) (fi dim) (fi dim)++-- | A simple dial using an arc segment to indicate the value compared+-- to the max value. Accepts @max@ and @value@ parameters (both+-- integers, default values 12 and 0), and a single field: @value@.+-- @<n>@ and @<p>@ are used to increase and decrease the value.+mkDial :: Constructor SindreX11M+mkDial r [] = do+ maxv <- param "max" <|> return 12+ val <- param "value" <|> return 0+ visual <- visualOpts r+ sindre $ return $ NewWidget $ Dial maxv val visual+mkDial _ _ = error "Dials do not have children"++data Label = Label { labelText :: FormatString+ , labelVisual :: VisualOpts+ }++instance Object SindreX11M Label where+ fieldSetI "label" v = do+ modify $ \s -> s { labelText = fromMaybe [Text $ T.pack $ show v] $ mold v }+ fullRedraw+ gets (unmold . labelText)+ fieldSetI _ _ = return $ Number 0+ fieldGetI "label" = gets (unmold . labelText)+ fieldGetI _ = return $ Number 0++instance Widget SindreX11M Label where+ composeI = do+ font <- gets (font . labelVisual)+ text <- gets labelText+ case text of+ [] -> return (Exact 0, Exact $ 2 * padding + Xft.height font)+ _ -> do r <- back $ fmtSize font text+ return (Exact $ rectWidth r,+ Exact $ rectHeight r)+ drawI = drawing' labelVisual $ \r fg _ -> do+ label <- gets labelText+ back $ drawFmt fg r label++-- | Label displaying the text contained in the field @label@, which+-- is also accepted as a widget parameter (defaults to the empty+-- string).+mkLabel :: Constructor SindreX11M+mkLabel r [] = do+ label <- param "label" <|> return []+ visual <- visualOpts r+ return $ NewWidget $ Label label visual+mkLabel _ _ = error "Labels do not have children"++data Blank = Blank { blankVisual :: VisualOpts }+ +instance Object SindreX11M Blank where+ fieldSetI _ _ = return $ Number 0+ fieldGetI _ = return $ Number 0++instance Widget SindreX11M Blank where+ composeI = return (Unlimited, Unlimited)+ drawI = drawing' blankVisual $ \_ _ _ -> return ()++-- | A blank widget, showing only background color, that can use as+-- much or as little room as necessary. Useful for constraining the+-- layout of other widgets.+mkBlank :: Constructor SindreX11M+mkBlank r [] = do+ visual <- visualOpts r+ return $ NewWidget $ Blank visual+mkBlank _ _ = error "Blanks do not have children"++data TextField = TextField { fieldText :: (String, String)+ , fieldVisual :: VisualOpts }++fieldValue :: TextField -> String+fieldValue = uncurry (++) . first reverse . fieldText++instance Object SindreX11M TextField where+ fieldSetI "value" (mold -> Just v) = do+ modify $ \s -> s { fieldText = (reverse v, "") }+ fullRedraw+ return $ string v+ fieldSetI _ _ = return $ Number 0+ fieldGetI "value" = string <$> fieldValue <$> get+ fieldGetI _ = return $ Number 0+ + recvEventI (KeyPress (S.toList -> [], CharKey c)) =+ changeFields [("value", unmold . fieldValue)] $ \s -> do+ let (bef, aft) = fieldText s+ fullRedraw+ return s { fieldText = (c:bef, aft) }+ recvEventI (KeyPress k) =+ maybe (return ()) (redraw >>) $ M.lookup k editorCommands+ recvEventI _ = return ()++editorCommands :: M.Map Chord (ObjectM TextField SindreX11M ())+editorCommands = M.fromList+ [ (chord [] "Right", moveForward $ splitAt 1)+ , (chord [Control] 'f', moveForward $ splitAt 1)+ , (chord [] "Left", moveBackward $ splitAt 1)+ , (chord [Control] 'b', moveBackward $ splitAt 1)+ , (chord [Meta] 'f', do moveForward (break isAlphaNum)+ moveForward (span isAlphaNum))+ , (chord [Meta] 'b', do moveBackward (break isAlphaNum)+ moveBackward (span isAlphaNum))+ , (chord [Control] 'a', moveBackward (,""))+ , (chord [Control] 'e', moveForward (,""))+ , (chord [] "Home", moveBackward ("",))+ , (chord [] "End", moveForward ("",))+ , (chord [Control] 'w', delBackward word)+ , (chord [Control] "BackSpace", delBackward word)+ , (chord [Meta] 'd', delForward word)+ , (chord [Control] 'k', delForward $ const "")+ , (chord [Control] 'u', delBackward $ const "")+ , (chord [] "BackSpace", delBackward $ drop 1)+ , (chord [Control] 'd', delForward $ drop 1)]+ where word = dropWhile isAlphaNum . dropWhile (not . isAlphaNum)+ moveForward f = modify $ \s ->+ let (bef, (pre, post)) = second f $ fieldText s+ in s { fieldText = (reverse pre ++ bef, post) }+ moveBackward f = modify $ \s ->+ let ((pre, post), aft) = first f $ fieldText s+ in s { fieldText = (post, reverse pre ++ aft) }+ delBackward delf = changeFields [("value", unmold . fieldValue)]+ $ \s -> do+ fullRedraw+ return s { fieldText = first delf $ fieldText s }+ delForward delf = changeFields [("value", unmold . fieldValue)]+ $ \s -> do+ fullRedraw+ return s { fieldText = second delf $ fieldText s }++instance Widget SindreX11M TextField where+ composeI = do+ font <- gets (font . fieldVisual)+ text <- gets fieldValue+ (w,h) <- back $ textExtents font text+ return (Max $ fi w + padding * 2, Exact $ fi h + padding * 2)+ drawI = drawing' fieldVisual $ \Rectangle{..} d _ -> do+ (bef,_) <- gets fieldText+ text <- gets fieldValue+ font <- gets (font . fieldVisual)+ (befw, _) <- back $ textExtents font bef+ (w, h) <- back $ textExtents font text+ let width = liftM snd . textExtents font+ text' <- if w <= fi rectWidth then return text+ else do fits <- back $ filterM (liftM (<= fi rectWidth) . width)+ $ tails $ reverse text+ case fits of+ [] -> return ""+ (t:_) -> return $ reverse t+ back $ drawText (drawerFgColor d) (drawerFont d)+ (rectX+padding) (rectY+padding)+ (rectHeight - padding*2) text'+ when (padding+befw <= fi rectWidth) $+ io $ fg d drawLine (fi rectX+padding+fi befw) (fi rectY+padding)+ (fi rectX+padding+fi befw) (fi rectY+padding+fi h)++-- | Single-line text field, whose single field @value@ (also a+-- parameter, defaults to the empty string) is the contents of the+-- editing buffer.+mkTextField :: Constructor SindreX11M+mkTextField r [] = do+ v <- param "value" <|> return ""+ visual <- visualOpts r+ return $ NewWidget $ TextField ("",v) visual+mkTextField _ _ = error "TextFields do not have children"++data ListElem = ListElem { showAs :: FormatString+ , valueOf :: T.Text+ , filterBy :: T.Text }+ deriving (Show, Eq, Ord)++parseListElem :: T.Text -> ListElem+parseListElem s = case KV.parseKV p s of+ Left _ -> el+ Right (v,val) ->+ case parseFormatString v of+ Left _ -> el+ Right s' -> ListElem (pad s') val (textContents s')+ where p = elf <$?> (Nothing, Just <$> KV.value (T.pack "show"))+ <||> KV.value (T.pack "value")+ elf s' v' = (fromMaybe v' s', v')+ pad s' = maybeToList (Bg <$> startBg s')+ ++ [Text $ T.pack " "] ++ s' ++ [Text $ T.pack " "]+ el = ListElem [Text $ T.concat [T.pack " ", s, T.pack " "]] s s++data NavList = NavList { linePrev :: [ListElem]+ , lineContents :: Maybe ([(ListElem, Rectangle)],+ (ListElem, Rectangle),+ [(ListElem, Rectangle)])+ , lineNext :: [ListElem] }++type Movement m = ([ListElem] -> m ([(ListElem, Rectangle)], [ListElem]))+ -> NavList -> m (Maybe NavList)++contents :: NavList -> [ListElem]+contents NavList { lineContents = Just (pre, cur, aft) } =+ reverse (map fst pre)++[fst cur]++map fst aft+contents _ = []++selected :: NavList -> Maybe ListElem+selected NavList { lineContents = Just (_, (cur, _), _) } = Just cur+selected _ = Nothing++listPrev :: Monad m => Movement m+listPrev _ l@NavList { lineContents = Just (pre:pre', cur, aft) } =+ return $ Just l { lineContents = Just (pre', pre, cur:aft) }+listPrev more l = do+ (conts', rest) <- more (linePrev l)+ case conts' of+ [] -> return Nothing+ x:xs -> return $ Just $ NavList+ rest (Just (xs, x, [])) (contents l++lineNext l)++listNext :: Monad m => Movement m+listNext _ l@NavList { lineContents = Just (pre, cur, aft:aft') } =+ return $ Just l { lineContents = Just (cur:pre, aft, aft') }+listNext more l = do+ (conts', rest) <- more $ lineNext l+ case conts' of+ [] -> return Nothing+ x:xs -> return $ Just $ NavList+ (reverse (contents l)++linePrev l) (Just ([], x, xs)) rest++listLast :: Monad m => Movement m+listLast more l = do+ (line, rest) <- more $ reverse (contents l ++ lineNext l) ++ linePrev l+ case line of [] -> return Nothing+ x:xs -> return $ Just $ NavList rest (Just (xs, x, [])) []++listFirst :: Monad m => Movement m+listFirst more l = do+ (line, rest) <- more $ reverse (linePrev l) ++ contents l ++ lineNext l+ case line of [] -> return Nothing+ x:xs -> return $ Just $ NavList [] (Just ([], x, xs)) rest++moveUntil :: (MonadIO m, Monad m) => Movement m -> (NavList -> Bool) -> Movement m+moveUntil mov p more l | p l = return $ Just l+ | otherwise = do+ l' <- mov more l+ case l' of Nothing -> return Nothing+ Just l'' -> moveUntil mov p more l''++lineElems :: (Rectangle -> Integer) -> Rectangle -> [ListElem]+ -> ObjectM List SindreX11M ([(ListElem, Rectangle)], [ListElem])+lineElems rdf r l = elemLine l $ rdf r+ where elemLine [] _ = return ([], [])+ elemLine es@(e:es') room = do+ r' <- elemRect e+ if room >= rdf r' then do (es'', rest) <- elemLine es' $ room-rdf r'+ return ((e,r'):es'', rest)+ else return ([], es)++fromElems :: ([(ListElem, Rectangle)], [ListElem]) -> NavList+fromElems ([], rest) = NavList [] Nothing rest+fromElems (x:xs, rest) = NavList [] (Just ([], x, xs)) rest++elemRect :: ListElem -> ObjectM List SindreX11M Rectangle+elemRect e = do font <- gets (font . listVisual)+ back $ fmtSize font (showAs e)++data List = List { listElems :: [ListElem]+ , listFilter :: T.Text+ , listLine :: NavList+ , listVisual :: VisualOpts+ , listCompose :: ObjectM List SindreX11M SpaceNeed+ , listDraw :: Rectangle+ -> ObjectM List SindreX11M SpaceUse+ , listFilterF :: T.Text -> [ListElem] -> [ListElem]+ , listUsableRect :: Rectangle+ -> ObjectM List SindreX11M Rectangle+ , listSize :: Rectangle+ , listDim :: Rectangle -> Integer+ }++listFiltered :: List -> [ListElem]+listFiltered List { listLine = l } =+ reverse (linePrev l) ++ contents l ++ lineNext l++selection :: List -> Value+selection l = maybe falsity f $ lineContents $ listLine l+ where f (_,(c,_),_) = StringV $ valueOf c++refilter :: (T.Text -> T.Text) -> T.Text -> [ListElem] -> [ListElem]+refilter tr f ts =+ case T.words $ tr f of+ [] -> ts+ f'@(x:_) -> exacts++prefixes++infixes+ where matches = filter (\t -> all (flip T.isInfixOf $ cmpBy t) f') ts+ (exacts, nonexacts) = partition ((==f) . cmpBy) matches+ (prefixes, infixes) =+ partition (T.isPrefixOf x . cmpBy) nonexacts+ cmpBy = filterBy++methInsert :: T.Text -> ObjectM List SindreX11M ()+methInsert vs = changeFields [("selected", selection)] $ \s -> do+ let v = listFilterF s (listFilter s) $ listFiltered s ++ elems+ p l = selected l == selected (listLine s)+ more = lineElems (listDim s) (listSize s)+ line <- fromElems <$> more v+ line' <- moveUntil listNext p more line+ fullRedraw >> return s { listElems = listElems s ++ elems+ , listLine = fromMaybe line line' }+ where elems = map parseListElem $ T.lines vs++methClear :: ObjectM List SindreX11M ()+methClear = do+ modify $ \s -> s { listElems = [] , listLine = NavList [] Nothing [] }+ fullRedraw++methFilter :: String -> ObjectM List SindreX11M ()+methFilter f =+ changeFields [("selected", selection)] $ \s -> do+ let v = listFilterF s f' $ if listFilter s `T.isPrefixOf` f'+ then listFiltered s+ else listElems s+ line <- fromElems <$> lineElems (listDim s) (listSize s) v+ redraw >> return s { listFilter = f', listLine = line }+ where f' = T.pack f++methMove :: (([ListElem] -> ObjectM List SindreX11M+ ([(ListElem, Rectangle)], [ListElem]))+ -> NavList -> ObjectM List SindreX11M (Maybe NavList))+ -> ObjectM List SindreX11M Bool+methMove f = do+ dimf <- gets listDim+ rect <- gets listSize+ l <- f (lineElems dimf rect) =<< gets listLine+ case l of Nothing -> return False+ Just l' -> do+ changeFields [("selected", selection)] $ \s -> do+ redraw+ return s { listLine = l' }+ return True++instance Object SindreX11M List where+ fieldSetI _ _ = return $ Number 0+ fieldGetI "selected" = selection <$> get+ fieldGetI "elements" = Dict <$> M.fromList <$>+ zip (map Number [1..]) <$>+ map (unmold . showAs) <$> listFiltered <$> get+ fieldGetI _ = return $ Number 0+ callMethodI "insert" = function methInsert+ callMethodI "clear" = function methClear+ callMethodI "filter" = function methFilter+ callMethodI "next" = function $ methMove listNext+ callMethodI "prev" = function $ methMove listPrev+ callMethodI "first" = function $ methMove listFirst+ callMethodI "last" = function $ methMove listLast+ callMethodI m = fail $ "Unknown method '" ++ m ++ "'"++instance Widget SindreX11M List where+ composeI = join $ gets listCompose+ drawI r = do l <- get+ r' <- listUsableRect l r+ when (r' /= listSize l) $ do+ line <- lineElems (listDim l) r' $ listFiltered l+ modify $ \s -> s { listSize = r', listLine = fromElems line }+ listDraw l r++mkList :: ObjectM List SindreX11M SpaceNeed+ -> (Rectangle -> ObjectM List SindreX11M SpaceUse)+ -> (Rectangle -> Integer)+ -> (Rectangle -> ObjectM List SindreX11M Rectangle)+ -> Constructor SindreX11M+mkList cf df dim uf r [] = do+ visual <- visualOpts r+ insensitive <- param "i" <|> return False+ let trf = if insensitive then T.toCaseFold else id+ return $ NewWidget $ List [] T.empty (NavList [] Nothing [])+ visual cf df (refilter trf) uf mempty dim+mkList _ _ _ _ _ _ = error "Lists do not have children"++-- | Horizontal dmenu-style list containing a list of elements, one of+-- which is the \"selected\" element. If the parameter @i@ is given a+-- true value, element matching will be case-insensitive. The+-- following methods are supported:+--+-- [@insert(string)@] Split @string@ into lines and add each line as+-- an element.+-- +-- [@clear()@] Delete all elements.+--+-- [@filter(string)@] Only display those elements that contain @string@.+--+-- [@next()@] Move selection right.+--+-- [@prev()@] Move selection left.+--+-- [@first()@] Move to leftmost element.+--+-- [@last()@] Move to rightmost element.+--+-- The field @selected@ is the selected element.+mkHList :: Constructor SindreX11M+mkHList = mkList composeHoriz drawHoriz rectWidth usable+ where composeHoriz =+ ((Unlimited,) . Exact . Xft.height) <$> gets (font . listVisual)++ prestr = "< "+ aftstr = "> "++ usable r = do font <- gets (font . listVisual)+ (w1, _) <- back $ textExtents font prestr+ (w2, _) <- back $ textExtents font aftstr+ return r { rectWidth = rectWidth r - fi w1 - fi w2 }++ drawHoriz = drawing' listVisual $ \r d fd -> do+ font <- gets (font . listVisual)+ (prestrw,_) <- back $ textExtents font prestr+ let (x,y,w,h) = ( fi $ rectX r, rectY r+ , fi $ rectWidth r, rectHeight r)+ drawElem d' x' (e,r') = back $ do+ drawFmt d' (r' { rectX = x', rectY = rectY r }) $ showAs e+ return $ x'+rectWidth r'+ line <- gets listLine+ case lineContents line of+ Just (pre, cur, aft) -> do+ unless (null $ linePrev line) $+ back $ drawText (drawerFgColor d) (drawerFont d) x y h prestr+ x' <- foldM (drawElem d)+ (fi $ prestrw + fi x) $ reverse pre+ x'' <- drawElem fd x' cur+ foldM_ (drawElem d) x'' aft+ unless (null $ lineNext line) $ back $ do+ (aftw,_) <- textExtents font aftstr+ drawText (drawerFgColor d) (drawerFont d)+ (x + w - aftw) y h aftstr+ Nothing -> return ()++-- | As 'mkHList', except the list is vertical. The parameter @lines@+-- (default value 10) is the number of lines shown.+mkVList :: Constructor SindreX11M+mkVList k cs = do+ n <- param "lines" <|> return 10+ mkList (composeVert n) drawVert rectHeight return k cs+ where composeVert n = do font <- gets (font . listVisual)+ return ( Unlimited,+ Exact $ (Xft.height font + 2*padding) * n)++ drawVert = drawing' listVisual $ \r d fd -> do+ let fr y r' = r { rectY = y, rectHeight = rectHeight r' }+ drawElem d' y (e, r') = do+ drawFmt d' (fr y r') $ showAs e+ return $ y + rectHeight r'+ line <- gets (lineContents . listLine)+ case line of+ Just (pre, cur, aft) -> back $ do+ y' <- foldM (drawElem d) (rectY r) $ reverse pre+ y'' <- drawElem fd y' cur+ foldM_ (drawElem d) y'' aft+ Nothing -> return ()
+ examples/askpass view
@@ -0,0 +1,15 @@+#!/bin/bash+code=$(cat <<EOF+GUI { Horizontally { Blank;+ label=Label(highlight=1);+ visible=Label(minwidth=100);+ real=Input(maxwidth=0);+ Blank } }+option prompt (-p,--prompt,"Set the input prompt", "STRING", "")+<Escape> || <C-g> { exit 1; }+<Return> { print real.value; exit 0; }+real.value->changed(from, to) { visible.label = gsub(".", "*", to) }+BEGIN { focus real; label.label = prompt; }+EOF+)+exec -a askpass sindre -e "$code" "$@"
+ examples/dial view
@@ -0,0 +1,14 @@+#!/bin/bash+code=$(cat <<EOF+GUI { Vertically { dial=Dial(max=physmax);+ label=Label(label=labelstring) } }+option min (,--min,"Minimum value of the dial", "INTEGER", 0)+option max (,--max,"Maximum value of the dial", "INTEGER", 12)+option labelstring(,--label,"Text of label below the dial", "STRING", "")+physmax=max-min;+stdin->lines(lines) { dial.value = lines; }+<Escape> || <Enter> || <C-g> { exit 0; }+BEGIN { focus dial; }+EOF+)+exec -a dial sindre -e "$code" "$@"
+ examples/dials.sindre view
@@ -0,0 +1,26 @@+GUI {+ Horizontally@"mid" {+ Vertically {+ Horizontally {+ Vertically { left=Dial(max=12); Label(label="Left") }+ Vertically {+ Vertically { master=Dial(max=12); Label(label="Master") }+ Vertically { pcm=Dial(max=12); Label(label="PCM") }+ }+ Vertically { right=Dial(max=12); Label(label="Right") }+ }+ Vertically { mic=Dial(max=12); Label(label="Mic") }+ }+ }+}+/*stdin.data(data) { master.value = data.line(0);+ pcm.value = data.line(1);+ mic.value = data.line(1); }*/+BEGIN { focus master; }+<q> { focus left }+<w> { focus master }+<e> { focus pcm }+<r> { focus right }+<t> { focus mic }+$Dial(dial)->changed(from,to) { print dial, to; }+<Escape> || <Enter> || <C-g> { exit 0 }
+ examples/dock view
@@ -0,0 +1,16 @@+#!/bin/sh++gui=$(cat <<EOF+GUI { Horizontally@"bot" {+ log=Label(bg="grey",fg="black");+ Blank(bg="grey")+ date=Label(bg="#999",fg="white");+} }+datestream->lines(lines) { date.label = gsub("\n", "", lines); }+logstream->lines(lines) { log.label = gsub(".*\n", "", gsub("\n$", "", lines)) }+EOF+)++cat |\+(while true; do date; sleep 1; done |\+sindre --wmmode dock -e "$gui" --fd=datestream=3 --fd=logstream=4 "$@" 3<&0 0<&-) 4<&0 0<&-
+ examples/fan view
@@ -0,0 +1,21 @@+#!/bin/sh+gui() {+ code=$(cat <<EOF+dial->changed(from, to) { gomanual() }+stdin->line(line) { gotlevel = 1; }+stdin->eof() { if (gotlevel) { gomanual() } else { goauto() } }+function gomanual() { print "level", dial.value; label.label = "Fan strength"; auto = 0; }+function goauto() { print "level auto"; label.label = "Automatic"; auto = 1; }+<Space> { if (auto) { gomanual() } else { goauto() } }+EOF+)+ $(dirname "$0")/dial --max 7 -e "$code"+}+if ! [ -w /proc/acpi/ibm/fan ]; then+ echo "Cannot write to /proc/acpi/ibm/fan - check that you have write permissions (and that this is a ThinkPad)."+ exit 1+fi+cat /proc/acpi/ibm/fan | grep '^level:.*[0-7]' | sed 's/level:[^0-9]*//' | gui \+| while read line; do+ echo $line > /proc/acpi/ibm/fan+done
+ examples/filesel view
@@ -0,0 +1,73 @@+#!/bin/sh++history=${XDG_CACHE_HOME:-~/.cache}/filesel/history++mkdir -p $(dirname historyfile)++history() {+ tac $history |\+awk '{gsub("\"", "\"\""); print "value=\""$0"\" show=\"^fg(white)(History) ^fg()"$0"\""; fflush(); }' |\+head -n 5+}++updatehistory() {+ (rm "$history" && awk '$0!=SEL' "SEL=$1" > "$history") < "$history"+ echo "$1" >> "$history"+}++entry() {+ awk '{gsub("\"", "\"\""); print "value=\""$0"\" show=\""substr($0, match($0, "/[^/]*/?$")+1)"\""; fflush(); }'+}++files() {+ ls -A -F "$1" | awk '{print DIR $0}' "DIR=$1"+}++gui() {+ code=$(cat <<EOF+input->changed(from, to) {+ if (to == "") {+ input.value = "/";+ next;+ }+ list.clear();+ insertfile();+ print folder(to);+}+function complete() {+ if (list.selected) {+ if (match(list.selected, "^/")) {+ input.value = list.selected+ } else {+ input.value = folder(input.value) list.selected+ }+ }+}+function folder(str) { return substr(str, 0, match(str, "/[^/]*$")) }+function file(str) { return substr(str, match(input.value, "[^/]*$"), RLENGTH); }+function insertfile() {+ if (filename) { filename = gsub("\"", "\"\"", filename);+ list.insert("value=\"" filename "\" show=\"^fg(white)" filename "\"" ) }+}+BEGIN { insertfile(); }+function filter() { list.filter(file(input.value)); }+function quit() { print; exit }+option filename(,--filename,"Default filename if a directory is selected", "filename");+EOF+ )+ dir=$(mktemp -p "${TMPDIR:-/tmp}" -d dir-XXXXXX) || exit 1+ fifo=$dir/fifo+ mkfifo "$fifo" || { rmdir "$dir"; exit 1; }+ sinmenu -l 10 -e "$code" -p File: -c $PWD/ "$@" < $fifo |\+while read line; do+ echo $line 1>&3+ history "$line"+ files "$line" 2>/dev/null | sed 's/\*$//' | entry+ done 3>&1 1>$fifo | tail -n 1 | sed '/^$/d'+ rm $fifo+ rmdir $dir+}++ret=$(gui "$@")++[ -z "$ret" ] && exit 1 || (updatehistory "$(dirname "$ret")/"; echo "$ret")
@@ -0,0 +1,2 @@+This directory contains a number of examples on how to extend sinmenu+with usage-specific functionality.
@@ -0,0 +1,3 @@+#!/bin/sh++sinmenu -e 'input->changed(from,to) { if (from!=to) { print to } }' "$@"
@@ -0,0 +1,15 @@+#!/bin/sh++actions=$(cat <<EOF+function select() { print input.value }+<C-Return> {+ elems=list.elements;+ while (i++<length(elems)) {+ print elems[i];+ }+ exit+}+EOF+)++sinmenu -e "$actions" "$@"
+ examples/suggest view
@@ -0,0 +1,41 @@+#!/bin/sh+# Interface to Google Suggest - not very useful, but a nice demo of+# how to combine Sindre with other programs through shell script.++code=$(cat <<EOF+stdin->lines(lines) { if (clear) { list.clear(); clear = 0; } }+input->changed(from, to) { clear=1; print to; next; }+function quit() { print; exit }+EOF+)+dir=$(mktemp -p "${TMPDIR:-/tmp}" -d dir-XXXX) || exit 1+fifo=$dir/fifo+mkfifo "$fifo" || { rmdir "$dir"; exit 1; }++googlesuggest() {+ python - "$@" <<EOF+import sys, string+import urllib++URI = "http://www.google.com/complete/search?hl=en&js=true&qu="++def suggest(term):+ # Pull the results as Javascript, then munge them a bit and+ # evaluate them as Python, yielding a dictionary.+ text = urllib.urlopen(URI + urllib.quote(term)).read() \+ .replace("window.google.ac.h(","").replace(",{}])", "]")+ for res in (eval(text)[1]):+ print res[0]++suggest(string.join(sys.argv[1:], ' '))+EOF+}++cat $fifo | $(dirname "$0")/dmenu -l 10 -e "$code" -p Search |\+while read line; do+ echo $line 1>&3+ # Due to Python nonsense, we have to reencode the output.+ googlesuggest "$line" | iconv -f latin1 -t utf8 &+done 3>&1 1>$fifo | tail -n 1 | sed '/^$/d'+rm $fifo+rmdir $dir
+ sindre.1 view
@@ -0,0 +1,212 @@+.TH SINDRE 1 sindre\-1.0+.SH NAME+sindre \- GUI programming language+.SH SYNOPSIS+.nh+sindre+[\fB\-f \fIprogram-file\fR]+[\fB\-e \fIprogram-text\fR]+.SH DESCRIPTION+.SS Overview+Sindre is a programming language inspired by Awk that makes it easy to+write simple graphical programs in the spirit of dzen, dmenu, xmobar,+gsmenu and the like.+.SS Options+.TP+.PD 0+.BI \-f " program-file"+.TP+.PD+.BI \-\^\-file " program-file"+Read a program fragment from the file+.IR program-file .+Multiple+.B \-f+options may be used, and may be interleaved with+.B \-e+options. See the section on+.B Multiple Fragments+below.+.TP+.PD 0+.BI \-e " program-text"+.TP+.PD+.BI \-\^\-expression " program-text"+Read program fragment from the argument+.IR program-text .+Multiple+.B \-e+options may be used, and may be interleaved with+.B \-f+options. See the section on+.B Code Substitution+below.+.TP+.PD 0+.BI \-\^\-fd " NAME=FD"+Create an input stream with the given name that reads from the given+file descriptor. The file descriptor should be created by the script+invoking Sindre, for example+.ft B+sindre --fd foostream=3 3<~/.xsession-errors.+.ft R+You should never create more than one stream per file descriptor. The+standard input stream is automatically available as the+stream 'stdin'. If multiple+.B \-\^\-fd+options are given that define the same stream name, the last one will+take priority.+.TP+.PD 0+.BI \-\^\-wmmode " normal|dock|override" " (defaults to override)"+If+.IR normal ,+put the program under the management of the window manager as a normal+client. If+.IR dock ,+run as a dock/panel, assuming window manager support. If+.IR override+(the default), grab control of the display and stay on top until the+program terminates.+.SH USAGE+.SS Lexical conventions+Identifiers start with a letter and consist of alphanumerics or+underscores. Class names start with a capital letter, while object+and variable names start with lowercase. Line-comments are supported+with // and block comments with /* ... */. Semicolons are used to+separate statements and declarations, although they are optional when+not needed to resolve ambiguity.+.SS Overview+The Sindre language is extremely similar to Awk in syntax and+semantics, although there are subtle differences as well. A program+primarily consists of action declarations that have the form+.TP+.IB pattern " { " statements " } "+.P+When an event arrives, each declaration is checked in order, and those+that match have their statements executed. Some patterns also bind+variables while executing the statements, like a function call. The+statement+.B next+can be used to immediately stop further processing of an event.+Additionally there are a few special declarations. A GUI declaration+defines a tree of possibly named widgets, and looks like+.TP+.BI "GUI { " name "=" class "(" parameters ") { " children " } }"+.P+where both name, parameters and children are optional. Each child+follows the same syntax as the body (the text between the braces) of a+GUI declaration, and should be separated by semicolons. Widget+parameters are of the form+.P+.IB param1 " = " exp1 ", " param2 " = " exp2 ", ... , " paramN " = " expN+.P+and are evaluated left-to-right. A parameter whose value is+considered false (see section+.BR VALUES )+will be ignored if its value is otherwise not valid for the+paramter. Otherwise, an error will occur if the value is not what the+widget expects (for example, the string "foo" passed as the widget+height).+.P+A global variable declaration looks like+.TP+.IB name = exp+.P+Global variables are initialised before the GUI is created, so they+can be used in widget parameters. On the other hand, they cannot+refer to widgets. If you need to perform work after the GUI has been+created, use a BEGIN declaration.+.P+Function are defined as in Awk, and recursion is supported:+.P+.BI "function " name "(" arg1 ", " arg2 ", ..., " argN ") { " statements " }"+.P+Arguments are lexically scoped within the function. If a function is+called with fewer arguments than given in its declaration, the+leftovers are given a false value. This is the only way to emulate+local variables.+.SS Patterns+.TP+.B BEGIN+At program startup, after the GUI has been created.+.TP+.BI < key >+When the given key is pressed. The syntax for keys is taken from GNU+Emacs and consists of an optional set of modifiers (C- (Control), M-+(Meta/Alt), Shift, S- (Super) or H- (Hyper)) followed by a key name.+The Shift modifier is stripped from keypresses that are characters. For example,+.B <C-a>+means a press of "a" while the Control key is held down, and+.B <C-A>+is with a capital "A". Modifiers can be chained, so you can match+.B <C-M-Shift-S-H-BackSpace>+if you really want to. The names for control characters, such as+BackSpace above, are taken from X11 keynames. You can use+.BR xev (1)+to figure out the names to a given key.+.TP+.IB object -> event ( name1 ", " name2 ", ..., " nameN )+Matches when the named object sends the named event. The names will+be bound to the value payload of the event, in the same way as with a+function call.+.TP+.BI $ class ( name ")->" event ( name1 ", " name2 ", ..., " nameN )+As above, but matches when a widget of the given class sends the named event.+.I name+will be bound to the widget that emitted the event.+.TP+.IB pat1 " || " ... " || " patN+Matches if any of the patterns, checked left-to-right, match.+.SS Multiple Fragments+When multiple+.B \-f+and+.B \-e+options are used, Sindre conceptually concatenates the given program+text fragments in the order of the options. There are two differences+from plain concatenation, however:+.TP+.B Duplicate definitions+A program fragment is normally not allowed to define two global+variables or functions with the same name, nor to contain two GUI+declarations. When the above options are used, redefinitions of previous+definitions appearing in later fragments take precedence.+.TP+.B Event handling priority+Event handlers are run from top to bottom in terms of the program+text, but event handlers in later fragments are run first. Thus,++.ft B+ sindre -e 'obj->ev() { print "foo" }+ obj->ev() { print "bar" }'+ -e 'obj->ev() { print "baz" }'+.ft R++will print "baz foo bar" whenever the event+.B obj->ev()+happens. BEGIN declaration are similarly executed in reverse order.++.ft B+ sindre -e 'BEGIN { print "I go last" }'+ -e 'BEGIN { print "I go first" }'+.ft R+.SH EXIT STATUS+Sindre returns a+.B 0+exit status on success, and+.B 1+if there was an internal problem.+.SH EXAMPLES+See the examples/ subdirectory of the Sindre source tree.+.SH SEE ALSO+.BR dmenu (1),+.BR awk (1),+.BR sinmenu (1)+.SH BUGS+The syntax and semantics for local variables are inherited from Awk,+and are rather ugly. It is possible to write programs that have no+way of exiting, short of killing the process manually. Actions are+executed atomically and synchronously, so an infinite loop can freeze+the program, requiring the user to kill it manually.
+ sindre.cabal view
@@ -0,0 +1,69 @@+name: sindre+version: 0.1+homepage: http://sigkill.dk/programs/sindre+synopsis: A programming language for simple GUIs+description:+ Sindre is a language inspired by Awk, meant for creating very simple+ graphical user interfaces.+category: GUI+license: BSD3+license-file: LICENSE+author: Troels Henriksen+maintainer: athas@sigkill.dk+cabal-version: >= 1.10+build-type: Custom++source-repository head+ type: git+ location: git@github.com:Athas/Sindre.git++executable sindre+ main-is: Main.hs+ other-modules: Sindre.X11+ Sindre.Util+ Sindre.Parser+ Sindre.Widgets+ Sindre.Runtime+ Sindre.Compiler+ Sindre.Sindre+ Sindre.Lib+ Sindre.Formatting+ Sindre.KeyVal+ Sindre.Main+ Graphics.X11.Xft++ build-depends: X11>=1.5.0.0 && < 1.6, X11-xshape>=0.1.1, X11-rm>=0.2,+ mtl, base >= 4.3 && < 5, containers, parsec>=3.1, array>=0.3,+ x11-xim>=0.0.6, setlocale, regex-pcre, process,+ text, bytestring, unix, attoparsec-text>=0.8.2,+ permute, utf8-string>=0.3++ ghc-options: -funbox-strict-fields -Wall++ ghc-prof-options: -prof -auto-all -rtsopts+ pkgconfig-depends: xft+ default-language: Haskell2010++library+ exposed-modules: Sindre.X11+ Sindre.Util+ Sindre.Parser+ Sindre.Widgets+ Sindre.Runtime+ Sindre.Compiler+ Sindre.Sindre+ Sindre.Lib+ Sindre.Formatting+ Sindre.KeyVal+ Sindre.Main+ Graphics.X11.Xft++ other-modules: Paths_sindre++ build-depends: X11>=1.5.0.0 && < 1.6, X11-xshape>=0.1.1, X11-rm,+ mtl, base >= 4.3 && < 5, containers, parsec>=3.1, array>=0.3,+ x11-xim>=0.0.5, setlocale, regex-pcre, process,+ text, bytestring, unix, attoparsec-text>=0.8.2,+ permute, utf8-string>=0.3+ pkgconfig-depends: xft+ default-language: Haskell2010
@@ -0,0 +1,61 @@+#!/bin/sh+gui=$(cat <<EOF+GUI {+Horizontally@bottom?"bot":"top" {+ prompt=Label(label=pstring,highlight=1, fg=ffg, bg=fbg);+ input=Input(minwidth=200, font=font, fg=fg, bg=bg, ffg=ffg, fbg=fbg);+ list=HList(i=ins, font=font, fg=fg, bg=bg, ffg=ffg, fbg=fbg);+ }+}+EOF+)+for arg in "$@"; do+ if [ "$arg" = '-l' ]; then+ gui=$(cat <<EOF+GUI {+Horizontally@bottom?"bot":"top" {+ Vertically {+ prompt=Label(label=pstring,highlight=1, fg=ffg, bg=fbg);+ Blank(fg=fg, bg=bg, ffg=ffg, fbg=fbg);+ }+ Vertically {+ input=Input(minwidth=0, font=font, fg=fg, bg=bg, ffg=ffg, fbg=fbg);+ list=VList(lines=lines, i=ins, font=font, fg=fg, bg=bg, ffg=ffg, fbg=fbg);+ }+}+}+option lines (-l,,"List items vertically, with the given number of lines.", "INTEGER", 10)+EOF+ )+ fi+done+code=$(cat <<EOF+BEGIN { input.value = contents }+option pstring (-p,--prompt,"Set the input prompt", "prompt", "")+option bottom (-b,,"Appear at bottom of screen")+option contents(-c,,"Starting contents of buffer", "text", "")+option ins(-i,,"Case-insensitive list matching")+option font(,--font,"Font used for text", "font")+option fg(,--nf,"Normal foreground colour", "colour")+option bg(,--nb,"Normal background colour", "colour")+option ffg(,--sf,"Selected element foreground colour", "colour")+option fbg(,--sb,"Selected element background colour", "colour")+function complete() { if (list.selected) { input.value = list.selected } }+function filter() { list.filter(input.value) }+function select() { print input.value; exit }+function quit() { exit 1 }+stdin->lines(lines) { list.insert(lines) }+BEGIN { focus input }+<C-g> || <Escape> || <C-c> { quit() }+<Up> || <C-p> || <C-r> { list.prev() }+<Down> || <C-n> || <C-s> { list.next() }+<Return> || <C-j> { complete(); select(); }+<Shift-Return> || <C-J> { select(); }+<C-i> || <Tab> { complete() }+<C-y> { input.value = sub("\n.*", "", osystem("sselp")) }+<C-e> { list.last() }+<C-a> { list.first() }+input.value->changed(from, to) { filter() }+EOF+)+sindre -e "$gui" -e "$code" "$@"
@@ -0,0 +1,71 @@+.TH SINMENU 1 sinmenu\-1.0+.SH NAME+sinmenu \- slower dmenu that uses more memory+.SH SYNOPSIS+.B sinmenu+[\fB\-b\fR]+[\fB\-i\fR]+[\fB\-l\fI lines\fR]+[\fB\-p\fI prompt\fR]+[\fISindre options...\fR]+.SH DESCRIPTION+.B sinmenu+is a dynamic menu for X, a clone of+.BR dmenu (1)+written in Sindre. It manages large numbers of user\-defined menu+items efficiently.+.P+sinmenu reads a list of newline\-separated items from standard input+and creates a menu. When the user selects an item or enters any text+and presses Return, their choice is printed to standard output and+sinmenu terminates.+.P+.SH OPTIONS+.TP+.B \-b+Appear at bottom of screen.+.TP+.B \-i+Match menu items case insensitively.+.TP+.BI \-l " lines"+List items vertically, with the given number of lines.+.TP+.BI \-p " prompt"+The prompt to be displayed to the left of the input field.+.TP+.BI \-\-font " font"+The font or font set used.+.TP+.BI \-\-nb " color"+The normal background color.+.IR #RGB ,+.IR #RRGGBB ,+and X color names are supported.+.TP+.BI \-\-nf " color"+Normal foreground color.+.TP+.BI \-\-sb " color"+Background color of prompt and selected element.+.TP+.BI \-\-sf " color"+Foreground color of prompt and selected element.+.SH USAGE+sinmenu is controlled by the keyboard via an eclectic mix of Emacs,+Unix and dmenu conventions.+.TP+.B Tab (C\-i)+Copy the selected item to the input field.+.TP+.B Return (C\-j)+Confirm selection. Prints the selected item to stdout and exits, returning+success.+.TP+.B Shift\-Return (C\-J)+Confirm input. Prints the input text to stdout and exits, returning success.+.TP+.B Escape (C\-c) or C\-g+Exit without selecting an item, returning failure.+.SH SEE ALSO+.BR sindre (1), dmenu (1)
+ tests/Properties.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleInstances #-}+module Properties where++import Sindre.Sindre++import Test.QuickCheck+import Text.Printf++import Control.Applicative+import Control.Monad+import Data.Monoid++main :: IO ()+main = mapM_ (\(s,a) -> putStr (s++": ") >> a) tests++instance Arbitrary Rectangle where+ arbitrary = pure Rectangle+ <*> choose (0,1000) <*> choose (0,1000)+ <*> choose (0,1000) <*> choose (0,1000)++-- Transposing a rectangle twice is the same as identity.+prop_transposetranspose :: Rectangle -> Bool+prop_transposetranspose r =+ (rectTranspose . rectTranspose) r == r++prop_rectangle_mempty :: Rectangle -> Bool+prop_rectangle_mempty r =+ r `mappend` mempty == r && mempty `mappend` r == r++prop_rectangle_mappend_associative :: Rectangle -> Rectangle -> Rectangle -> Bool+prop_rectangle_mappend_associative r1 r2 r3 =+ r1 `mappend` (r2 `mappend` r3) == (r1 `mappend` r2) `mappend` r3++prop_rectangle_mappend_idempotent :: Rectangle -> Rectangle -> Bool+prop_rectangle_mappend_idempotent r1 r2 =+ r1 `mappend` r2 `mappend` r2 == r1 `mappend` r2 &&+ r1 `mappend` r2 `mappend` r1 == r1 `mappend` r2 &&+ r2 `mappend` r1 `mappend` r1 == r1 `mappend` r2 &&+ r2 `mappend` r1 `mappend` r2 == r1 `mappend` r2++instance Arbitrary DimNeed where+ arbitrary = oneof [ liftM Min (choose (0,100))+ , liftM Max (choose (0,100))+ , return Unlimited+ , liftM Exact (choose (0,100)) ]++newtype BigEnoughDim = BigEnoughDim ([DimNeed], Integer)+ deriving (Show)++-- The dimension is guaranteed to be able to satisfy the requirements.+instance Arbitrary BigEnoughDim where+ arbitrary = do needs <- arbitrary+ let (x1,x2) = foldl (\(x1,y1) (x2,y2) -> (x1+x2,y1+y2)) (0,0)+ $ map range needs+ dim <- choose (x1, x2)+ return $ BigEnoughDim (needs, dim)+ where range (Min x) = (x,2*x)+ range (Max x) = (0,x)+ range (Exact x) = (x,x)+ range Unlimited = (0,100)++satisfied :: DimNeed -> Integer -> Bool+satisfied (Min x) y = x <= y+satisfied (Max x) y = x >= y+satisfied (Exact x) y = x == y+satisfied Unlimited _ = True++prop_hsplit_satisfies :: BigEnoughDim -> Bool+prop_hsplit_satisfies (BigEnoughDim (needs, dim)) =+ length needs == length rs &&+ all (uncurry satisfied) (zip needs $ map rectHeight rs)+ where rs = splitHoriz (Rectangle 0 0 10 dim) needs++prop_hsplit_union :: [DimNeed] -> Rectangle -> Bool+prop_hsplit_union needs r =+ length needs == length rs && (null needs || mconcat rs == r)+ where rs = splitHoriz r needs++prop_vsplit_satisfies :: BigEnoughDim -> Bool+prop_vsplit_satisfies (BigEnoughDim (needs, dim)) =+ length needs == length rs &&+ all (uncurry satisfied) (zip needs $ map rectWidth rs)+ where rs = splitVert (Rectangle 0 0 dim 10) needs++prop_vsplit_union :: [DimNeed] -> Rectangle -> Bool+prop_vsplit_union needs r =+ length needs == length rs && (null needs || mconcat rs == r)+ where rs = splitVert r needs++prop_constrains_idempotent :: SpaceNeed -> Constraints -> Bool+prop_constrains_idempotent s c =+ constrainNeed (constrainNeed s c) c == constrainNeed s c++prop_fitRect_idempotent :: Rectangle -> SpaceNeed -> Bool+prop_fitRect_idempotent r s =+ fitRect (fitRect r s) s == fitRect r s++prop_fitRect_subrect :: Rectangle -> SpaceNeed -> Bool+prop_fitRect_subrect r s =+ fitRect r s `mappend` r == r++prop_fitRect_fits :: Rectangle -> SpaceNeed -> Bool+prop_fitRect_fits r s = check rectWidth (fst s) && check rectHeight (snd s)+ where check f (Exact x) | x <= f r = f (fitRect r s) == x+ | otherwise = f (fitRect r s) == f r+ check f (Min x) | x <= f r = f (fitRect r s) >= x+ | otherwise = f (fitRect r s) == f r+ check f (Max x) = f (fitRect r s) <= x+ check _ Unlimited = True++instance Arbitrary Align where+ arbitrary = elements [AlignCenter, AlignNeg, AlignPos]++prop_align_fits :: Align -> Property+prop_align_fits a = do+ minp <- arbitrary `suchThat` (>=(0::Integer))+ d <- arbitrary `suchThat` (>=0)+ maxp <- arbitrary `suchThat` (>=d+minp)+ let d' = align a minp d maxp+ d' >= minp .&. d' <= maxp .&. d'+d <= maxp .&.+ case a of AlignCenter -> abs ((d'-minp)-(maxp-d'-d)) <= 1+ AlignNeg -> d'==minp+ AlignPos -> d'==maxp-d++tests :: [(String, IO ())]+tests = [ ( "Transposing twice is identity"+ , quickCheck prop_transposetranspose)+ , ( "Rectangle mempty is identity"+ , quickCheck prop_rectangle_mempty)+ , ( "Rectangle mappend is associative"+ , quickCheck prop_rectangle_mappend_associative)+ , ( "Rectangle mappend is idempotent"+ , quickCheck prop_rectangle_mappend_idempotent)+ , ( "Horizontal split fulfills constraints"+ , quickCheck prop_hsplit_satisfies )+ , ( "Union is inverse of horizontal split"+ , quickCheck prop_hsplit_union )+ , ( "Vertical split fulfills constraints"+ , quickCheck prop_vsplit_satisfies )+ , ( "Union is inverse of vertical split"+ , quickCheck prop_vsplit_union )+ , ( "Constraining is idempotent"+ , quickCheck prop_constrains_idempotent )+ , ( "Rectangle fitting is idempotent"+ , quickCheck prop_fitRect_idempotent )+ , ( "Fitted rectangle is a subrectangle"+ , quickCheck prop_fitRect_subrect )+ , ( "Rectangle fitting fits"+ , quickCheck prop_fitRect_fits )+ , ( "Aligning fits and cannot be improved"+ , quickCheck prop_align_fits)+ ]