diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist +*.hi +*.o diff --git a/Graphics/X11/Xft.hsc b/Graphics/X11/Xft.hsc new file mode 100644 --- /dev/null +++ b/Graphics/X11/Xft.hsc @@ -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 +#include + +-- | 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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") diff --git a/Sindre/ANSI.hs b/Sindre/ANSI.hs new file mode 100644 --- /dev/null +++ b/Sindre/ANSI.hs @@ -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 diff --git a/Sindre/Compiler.hs b/Sindre/Compiler.hs new file mode 100644 --- /dev/null +++ b/Sindre/Compiler.hs @@ -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 "" + 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 diff --git a/Sindre/Formatting.hs b/Sindre/Formatting.hs new file mode 100644 --- /dev/null +++ b/Sindre/Formatting.hs @@ -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 ")") diff --git a/Sindre/KeyVal.hs b/Sindre/KeyVal.hs new file mode 100644 --- /dev/null +++ b/Sindre/KeyVal.hs @@ -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 (==' ') diff --git a/Sindre/Lib.hs b/Sindre/Lib.hs new file mode 100644 --- /dev/null +++ b/Sindre/Lib.hs @@ -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) diff --git a/Sindre/Main.hs b/Sindre/Main.hs new file mode 100644 --- /dev/null +++ b/Sindre/Main.hs @@ -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 " + +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 diff --git a/Sindre/Parser.hs b/Sindre/Parser.hs new file mode 100644 --- /dev/null +++ b/Sindre/Parser.hs @@ -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 diff --git a/Sindre/Runtime.hs b/Sindre/Runtime.hs new file mode 100644 --- /dev/null +++ b/Sindre/Runtime.hs @@ -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) diff --git a/Sindre/Sindre.hs b/Sindre/Sindre.hs new file mode 100644 --- /dev/null +++ b/Sindre/Sindre.hs @@ -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) = "#" + 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 = ("", 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. + } diff --git a/Sindre/Util.hs b/Sindre/Util.hs new file mode 100644 --- /dev/null +++ b/Sindre/Util.hs @@ -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 diff --git a/Sindre/Widgets.hs b/Sindre/Widgets.hs new file mode 100644 --- /dev/null +++ b/Sindre/Widgets.hs @@ -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 diff --git a/Sindre/X11.hs b/Sindre/X11.hs new file mode 100644 --- /dev/null +++ b/Sindre/X11.hs @@ -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 "" + +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@. +-- @@ and @

@ 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 () diff --git a/examples/askpass b/examples/askpass new file mode 100644 --- /dev/null +++ b/examples/askpass @@ -0,0 +1,15 @@ +#!/bin/bash +code=$(cat < || { exit 1; } + { 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" "$@" diff --git a/examples/dial b/examples/dial new file mode 100644 --- /dev/null +++ b/examples/dial @@ -0,0 +1,14 @@ +#!/bin/bash +code=$(cat <lines(lines) { dial.value = lines; } + || || { exit 0; } +BEGIN { focus dial; } +EOF +) +exec -a dial sindre -e "$code" "$@" diff --git a/examples/dials.sindre b/examples/dials.sindre new file mode 100644 --- /dev/null +++ b/examples/dials.sindre @@ -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; } + { focus left } + { focus master } + { focus pcm } + { focus right } + { focus mic } +$Dial(dial)->changed(from,to) { print dial, to; } + || || { exit 0 } diff --git a/examples/dock b/examples/dock new file mode 100644 --- /dev/null +++ b/examples/dock @@ -0,0 +1,16 @@ +#!/bin/sh + +gui=$(cat <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<&- diff --git a/examples/fan b/examples/fan new file mode 100644 --- /dev/null +++ b/examples/fan @@ -0,0 +1,21 @@ +#!/bin/sh +gui() { + code=$(cat <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; } + { 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 diff --git a/examples/filesel b/examples/filesel new file mode 100644 --- /dev/null +++ b/examples/filesel @@ -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 <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") diff --git a/examples/sinmenu_patches/README b/examples/sinmenu_patches/README new file mode 100644 --- /dev/null +++ b/examples/sinmenu_patches/README @@ -0,0 +1,2 @@ +This directory contains a number of examples on how to extend sinmenu +with usage-specific functionality. diff --git a/examples/sinmenu_patches/sinmenu_incremental b/examples/sinmenu_patches/sinmenu_incremental new file mode 100644 --- /dev/null +++ b/examples/sinmenu_patches/sinmenu_incremental @@ -0,0 +1,3 @@ +#!/bin/sh + +sinmenu -e 'input->changed(from,to) { if (from!=to) { print to } }' "$@" diff --git a/examples/sinmenu_patches/sinmenu_multiselect b/examples/sinmenu_patches/sinmenu_multiselect new file mode 100644 --- /dev/null +++ b/examples/sinmenu_patches/sinmenu_multiselect @@ -0,0 +1,15 @@ +#!/bin/sh + +actions=$(cat < { + elems=list.elements; + while (i++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 - "$@" <&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 diff --git a/sindre.1 b/sindre.1 new file mode 100644 --- /dev/null +++ b/sindre.1 @@ -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 +means a press of "a" while the Control key is held down, and +.B +is with a capital "A". Modifiers can be chained, so you can match +.B +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. diff --git a/sindre.cabal b/sindre.cabal new file mode 100644 --- /dev/null +++ b/sindre.cabal @@ -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 diff --git a/sinmenu b/sinmenu new file mode 100644 --- /dev/null +++ b/sinmenu @@ -0,0 +1,61 @@ +#!/bin/sh +gui=$(cat <lines(lines) { list.insert(lines) } +BEGIN { focus input } + || || { quit() } + || || { list.prev() } + || || { list.next() } + || { complete(); select(); } + || { select(); } + || { complete() } + { input.value = sub("\n.*", "", osystem("sselp")) } + { list.last() } + { list.first() } +input.value->changed(from, to) { filter() } +EOF +) +sindre -e "$gui" -e "$code" "$@" diff --git a/sinmenu.1 b/sinmenu.1 new file mode 100644 --- /dev/null +++ b/sinmenu.1 @@ -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) diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -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) + ]