scope 0.7.0.0 → 0.8.0.0
raw patch · 10 files changed
+6/−690 lines, 10 filesdep −ListLikedep −cairodep −glibdep ~base
Dependencies removed: ListLike, cairo, glib, gtk, old-locale
Dependency ranges changed: base
Files
- Scope/Cairo.hs +0/−76
- data/actions.ui +0/−22
- demo/demo1.zoom binary
- demo/demo2.zoom binary
- demo/demo3.zoom binary
- demo/demo4.zoom binary
- scope.cabal +6/−65
- src/Children.hs +0/−28
- src/GUI.hs +0/−470
- src/main.hs +0/−29
− Scope/Cairo.hs
@@ -1,76 +0,0 @@-{-# OPTIONS -Wall -fno-warn-orphans #-}--module Scope.Cairo (- -- * Types- ViewCairo(..)-- -- * Scope ViewCairo- , scopeCairoNew- , viewCairoInit-- -- * Utils- , keepState-) where--import Prelude hiding (catch)--import Control.Monad.CatchIO-import Control.Monad.Reader-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Cairo.Internal (Render(..))-import Graphics.Rendering.Cairo.Types (Cairo)-import qualified Graphics.UI.Gtk as G--import Scope.Types hiding (m, b)--------------------------------------------------------------------------data ViewCairo = ViewCairo- { canvas :: G.DrawingArea- , adj :: G.Adjustment- }--scopeCairoNew :: G.DrawingArea -> G.Adjustment -> Scope ViewCairo-scopeCairoNew c a = scopeNew (viewCairoInit c a)--viewCairoInit :: G.DrawingArea -> G.Adjustment -> ViewCairo-viewCairoInit c a = ViewCairo c a--------------------------------------------------------------------------instance MonadCatchIO C.Render where- m `catch` f = mapRender (\m' -> m' `catch` \e -> runRender $ f e) m- block = mapRender block- unblock = mapRender unblock--mapRender :: (ReaderT Cairo IO m1 -> ReaderT Cairo IO m) -> Render m1 -> Render m-mapRender f = Render . f . runRender--instance ScopeRender C.Render where- renderCmds = keepState . mapM_ cairoDrawCmd--------------------------------------------------------------------------cairoDrawCmd :: DrawCmd -> C.Render ()-cairoDrawCmd (SetRGB r g b) = C.setSourceRGB r g b-cairoDrawCmd (SetRGBA r g b a) = C.setSourceRGBA r g b a-cairoDrawCmd (MoveTo (x,y)) = C.moveTo x y--cairoDrawCmd (LineTo (x,y)) = do- C.lineTo x y- C.stroke--cairoDrawCmd (FillPoly []) = return ()-cairoDrawCmd (FillPoly ((x,y):ps)) = do- C.moveTo x y- mapM_ (uncurry C.lineTo) ps- C.fill--------------------------------------------------------------------keepState :: C.Render t -> C.Render ()-keepState render = do- C.save- _ <- render- C.restore-
− data/actions.ui
@@ -1,22 +0,0 @@-<ui>- <menubar name="menubar1">- <menu action="FMA">- <menuitem action="NEWA"/>- <menuitem action="OPENA"/>- <menuitem action="SAVEA"/>- <menuitem action="SAVEASA"/>- <separator/>- <menuitem action="QUITA"/>- </menu>- <menu action="EMA">- <menuitem action="cut1"/>- <menuitem action="copy1"/>- <menuitem action="paste1"/>- <menuitem action="delete1"/>- </menu>- <menu action="VMA"/>- <menu action="HMA">- <menuitem action="ABOUTA"/>- </menu>- </menubar>-</ui>
− demo/demo1.zoom
binary file changed (111570 → absent bytes)
− demo/demo2.zoom
binary file changed (111570 → absent bytes)
− demo/demo3.zoom
binary file changed (175266 → absent bytes)
− demo/demo4.zoom
binary file changed (557442 → absent bytes)
scope.cabal view
@@ -1,40 +1,19 @@ Name: scope -Version: 0.7.0.0+Version: 0.8.0.0 Synopsis: An interactive renderer for plotting time-series data Description: scope is a framework for plotting time-series data, using zoom-cache- files.- .- This version includes a Gtk/Cairo application. It's a desktop- application with a /File/ menu; remember those? wow! This will probably- be split out into a separate package later, and there'll be a webby- javascripty version too, but for now there's this desktop app.- .- To run it, simply:- .- @- $ cabal install gtk2hs-buildtools scope- $ scope- @- .- Then, select /File->Open/ from the menubar, with your mouse: there's no- swiping gestures back here, baby! Four (yes, 4) demo files are included- in this version of the package. Choose one, and it will be drawn in the- window. Amazing! It should look something like what you saw in the post- you read about this in, but more personal because now it's happening to- you.+ files. This package contains the core Scope library; to use it for+ interactive plotting, you need a rendering backend such as scope-cairo: .- Zoom in with the scroll wheel on your mouse. If you don't have a scroll- wheel, use the Up and Down arrow keys on your keyboard. If you don't have- up and down arrows /you are elite/!+ <http://hackage.haskell.org/package/scope-cairo> .- Pan around by dragging it. There's a scrollbar too if you're into that.+ For more information about zoom-cache files, see the zoom-cache package: .- Load up another file! It will also be drawn. Zoom in and out and pan- around, yay! Life is gooood!+ <http://hackage.haskell.org/package/zoom-cache> License: BSD3 License-file: LICENSE@@ -44,12 +23,6 @@ Cabal-Version: >= 1.8 Build-type: Simple-Data-Files:- data/actions.ui- demo/demo1.zoom- demo/demo2.zoom- demo/demo3.zoom- demo/demo4.zoom flag splitBase description: Use the split-up base package.@@ -63,53 +36,21 @@ base < 3 Build-Depends:- cairo,- gtk, bytestring >= 0.9 && < 0.10, containers >= 0.2 && < 0.5, iteratee >= 0.8.6.0 && < 0.9, MonadCatchIO-transformers > 0.2 && < 0.3, mtl >= 2.0.0.0 && < 3, mwc-random,- old-locale, time, unix, zoom-cache >= 1.2.0.0 && < 1.3.0.0 Exposed-modules:- Scope.Cairo Scope.Layer Scope.Numeric.IEEE754 Scope.Types Scope.View--Executable scope- if flag(splitBase)- build-depends:- base >= 3 && < 6- else- build-depends:- base < 3-- Main-Is: main.hs- Other-Modules: Children- GUI- Hs-Source-Dirs: ., src- Build-Depends:- cairo,- glib,- gtk,- bytestring >= 0.9 && < 0.10,- containers >= 0.2 && < 0.5,- iteratee >= 0.8.6.0 && < 0.9,- ListLike >= 1.0 && < 4,- MonadCatchIO-transformers > 0.2 && < 0.3,- mtl >= 2.0.0.0 && < 3,- mwc-random,- old-locale,- time,- unix,- zoom-cache >= 1.2.0.0 && < 1.3.0.0 ------------------------------------------------------------------------ -- Git repo
− src/Children.hs
@@ -1,28 +0,0 @@-{-# OPTIONS -Wall #-}--module Children where--import Control.Concurrent-import Control.Exception (finally)--import System.IO.Unsafe (unsafePerformIO)--children :: MVar [MVar ()]-children = unsafePerformIO (newMVar [])--waitForChildren :: IO ()-waitForChildren = do- cs <- takeMVar children- case cs of- [] -> return ()- m:ms -> do- putMVar children ms- takeMVar m- waitForChildren--forkChild :: IO () -> IO ThreadId-forkChild io = do- mvar <- newEmptyMVar- childs <- takeMVar children- putMVar children (mvar:childs)- forkIO (io `finally` putMVar mvar ())
− src/GUI.hs
@@ -1,470 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS -Wall -fno-warn-unused-do-bind #-}--module GUI (- guiMain-) where--import Control.Applicative ((<$>))-import Control.Concurrent-import Control.Monad.Reader-import Data.IORef-import Data.Maybe-import Data.Time (UTCTime, formatTime)-import Data.ZoomCache (TimeStamp(..), prettyTimeStamp)-import qualified Graphics.UI.Gtk as G-import qualified Graphics.Rendering.Cairo as C-import qualified Graphics.Rendering.Cairo.Matrix as M-import System.Locale (defaultTimeLocale)--import Paths_scope as My-import Scope.Layer-import Scope.Types-import Scope.View--import Scope.Cairo--------------------------------------------------------------------------windowWidth, windowHeight :: Int-windowWidth = 500-windowHeight = 500---- Display image in window-guiMain :: Chan String -> [String] -> IO ()-guiMain chan args = do- _ <- G.initGUI-- window <- G.windowNew- G.widgetSetSizeRequest window windowWidth windowHeight- G.widgetSetAppPaintable window True- G.widgetSetDoubleBuffered window True-- vbox <- G.vBoxNew False 0- G.containerAdd window vbox-- ui <- G.uiManagerNew-- filename <- My.getDataFileName "data/actions.ui"- G.uiManagerAddUiFromFile ui filename-- let getWidget = fmap fromJust . G.uiManagerGetWidget ui-- -- Menubar- fma <- G.actionNew "FMA" "File" Nothing Nothing- ema <- G.actionNew "EMA" "Edit" Nothing Nothing- vma <- G.actionNew "VMA" "View" Nothing Nothing- hma <- G.actionNew "HMA" "Help" Nothing Nothing-- -- File menu- newa <- G.actionNew "NEWA" "New" (Just "Just a Stub") (Just G.stockNew)- newa `G.on` G.actionActivated $ myNew- opena <- G.actionNew "OPENA" "Open" (Just "Just a Stub") (Just G.stockOpen)- savea <- G.actionNew "SAVEA" "Save" (Just "Just a Stub") (Just G.stockSave)- saveasa <- G.actionNew "SAVEASA" "Save As" (Just "Just a Stub") (Just G.stockSaveAs)- quita <- G.actionNew "QUITA" "Quit" (Just "Just a Stub") (Just G.stockQuit)-- let fChooser action label = G.fileChooserDialogNew Nothing (Just window) action- [(G.stockCancel, G.ResponseCancel), (label, G.ResponseAccept)]-- openDialog <- fChooser G.FileChooserActionOpen G.stockOpen- demoPath <- My.getDataFileName "demo"- G.fileChooserSetCurrentFolder openDialog demoPath-- opena `G.on` G.actionActivated $ G.widgetShow openDialog-- saveDialog <- fChooser G.FileChooserActionSave G.stockSave- savea `G.on` G.actionActivated $ G.widgetShow saveDialog- saveasa `G.on` G.actionActivated $ G.widgetShow saveDialog-- -- Edit menu- cut1 <- G.actionNew "cut1" "Cut" (Just "Just a Stub") (Just G.stockCut)- cut1 `G.on` G.actionActivated $ myCut- copy1 <- G.actionNew "copy1" "Copy" (Just "Just a Stub") (Just G.stockCopy)- copy1 `G.on` G.actionActivated $ myCopy- paste1 <- G.actionNew "paste1" "Paste" (Just "Just a Stub") (Just G.stockPaste)- paste1 `G.on` G.actionActivated $ myPaste- delete1 <- G.actionNew "delete1" "Delete" (Just "Just a Stub") (Just G.stockDelete)- delete1 `G.on` G.actionActivated $ myDelete-- -- Help menu- -- About dialog- aboutdialog <- G.aboutDialogNew- abouta <- G.actionNew "ABOUTA" "About" (Just "Just a Stub") Nothing- abouta `G.on` G.actionActivated $ G.widgetShow aboutdialog- aboutdialog `G.on` G.response $ const $ G.widgetHide aboutdialog-- -- Action group- agr <- G.actionGroupNew "AGR"- mapM_ (G.actionGroupAddAction agr) [fma, ema, vma, hma]- mapM_ (\act -> G.actionGroupAddActionWithAccel agr act Nothing)- [ newa, opena, savea, saveasa, quita- , cut1, copy1, paste1, delete1- , abouta- ]-- G.uiManagerInsertActionGroup ui agr 0-- menubar <- getWidget "/ui/menubar1"- G.boxPackStart vbox menubar G.PackNatural 0-- adj <- G.adjustmentNew (0.0) (0.0) (1.0) (0.1) 1.0 1.0- drawingArea <- G.drawingAreaNew-- let scope = scopeCairoNew drawingArea adj- scopeRef <- newIORef scope-- quita `G.on` G.actionActivated $ myQuit scopeRef window chan-- mapM_ (modifyIORefM scopeRef . addLayersFromFile) args- openDialog `G.on` G.response $ myFileOpen scopeRef openDialog- saveDialog `G.on` G.response $ myFileSave scopeRef saveDialog-- adj `G.onValueChanged` (scroll scopeRef)-- G.boxPackStart vbox drawingArea G.PackGrow 0-- drawingArea `G.on` G.buttonPressEvent $ G.tryEvent $ buttonDown scopeRef- drawingArea `G.on` G.buttonReleaseEvent $ G.tryEvent $ buttonRelease scopeRef- drawingArea `G.on` G.scrollEvent $ G.tryEvent $ wheel scopeRef- drawingArea `G.on` G.motionNotifyEvent $ G.tryEvent $ motion scopeRef- drawingArea `G.on` G.keyPressEvent $ G.tryEvent $ keyDown scopeRef- G.widgetAddEvents drawingArea- [ G.KeyPressMask- , G.KeyReleaseMask- , G.PointerMotionMask- , G.ButtonMotionMask- , G.ScrollMask- ]-- G.widgetSetCanFocus drawingArea True-- drawingArea `G.on` G.exposeEvent $ G.tryEvent $ do- liftIO $ updateCanvas scopeRef- return ()-- scrollbar <- G.hScrollbarNew adj- G.boxPackStart vbox scrollbar G.PackNatural 0-- statusbar <- G.statusbarNew- G.boxPackStart vbox statusbar G.PackNatural 0-- G.onDestroy window ((myWriteChan chan "quit") >> G.mainQuit)-- G.widgetShowAll window- G.mainGUI--myQuit :: G.WidgetClass cls => IORef (Scope ViewCairo) -> cls -> Chan String -> IO ()-myQuit scopeRef window chan = do- scopeModifyMUpdate scopeRef scopeClose- G.widgetDestroy window- myWriteChan chan "quit"--myWriteChan :: Chan String -> String -> IO ()-myWriteChan chan s = do writeChan chan s- yield-myNew :: IO ()-myNew = putStrLn "New"--myFileOpen :: IORef (Scope ViewCairo) -> G.FileChooserDialog -> G.ResponseId -> IO ()-myFileOpen scopeRef fcdialog response = do- case response of- G.ResponseAccept -> do- Just filename <- G.fileChooserGetFilename fcdialog- scopeModifyMUpdate scopeRef (addLayersFromFile filename)- _ -> return ()- G.widgetHide fcdialog--myFileSave :: IORef (Scope ViewCairo) -> G.FileChooserDialog -> G.ResponseId -> IO ()-myFileSave scopeRef fcdialog response = do- case response of- G.ResponseAccept -> do- Just filename <- G.fileChooserGetFilename fcdialog- writePng filename scopeRef- _ -> return ()- G.widgetHide fcdialog--myCut :: IO ()-myCut = putStrLn "Cut"--myCopy :: IO ()-myCopy = putStrLn "Copy"--myPaste :: IO ()-myPaste = putStrLn "Paste"--myDelete :: IO ()-myDelete = putStrLn "Delete"--updateCanvas :: IORef (Scope ViewCairo) -> IO Bool-updateCanvas ref = do- scope <- readIORef ref- let c = canvas . viewUI . view $ scope- win <- G.widgetGetDrawWindow c- (width, height) <- G.widgetGetSize c- G.renderWithDrawable win $ plotWindow width height ref- return True--writePng :: FilePath -> IORef (Scope ViewCairo) -> IO ()-writePng path ref = do- scope <- readIORef ref- let c = canvas . viewUI . view $ scope- (width, height) <- G.widgetGetSize c- C.withImageSurface C.FormatARGB32 width height $ \ result -> do- C.renderWith result $ plotWindow width height ref- C.surfaceWriteToPNG result path--------------------------------------------------------------------scopeModifyMUpdate :: IORef (Scope ViewCairo)- -> (Scope ViewCairo -> IO (Scope ViewCairo))- -> IO ()-scopeModifyMUpdate ref f = do- modifyIORefM ref f- viewCairoUpdate =<< view <$> readIORef ref--scopeModifyUpdate :: IORef (Scope ViewCairo)- -> (View ViewCairo -> View ViewCairo)- -> IO ()-scopeModifyUpdate ref f = do- modifyIORef ref (scopeModifyView f)- viewCairoUpdate =<< view <$> readIORef ref--viewCairoUpdate :: View ViewCairo -> IO ()-viewCairoUpdate View{..} = do- G.adjustmentSetValue (adj viewUI) (toDouble viewX1)- G.adjustmentSetPageSize (adj viewUI) $ toDouble (distance viewX1 viewX2)- G.widgetQueueDraw (canvas viewUI)--------------------------------------------------------------------_canvasToScreen :: G.DrawingArea -> CanvasX -> IO ScreenX-_canvasToScreen c (CanvasX cX) = do- (width, _height) <- G.widgetGetSize c- return $ ScreenX (fromIntegral width * cX)--screenToCanvas :: ViewCairo -> ScreenX -> IO CanvasX-screenToCanvas vc (ScreenX sX) = do- (width, _height) <- G.widgetGetSize (canvas vc)- return $ CanvasX (sX / fromIntegral width)--------------------------------------------------------------------buttonDown :: IORef (Scope ViewCairo) -> G.EventM G.EButton ()-buttonDown ref = do- (x, _y) <- G.eventCoordinates- liftIO $ do- vc <- viewUI . view <$> readIORef ref- cX <- screenToCanvas vc (ScreenX x)- scopeModifyUpdate ref (viewButtonDown cX)--buttonRelease :: IORef (Scope ViewCairo) -> G.EventM G.EButton ()-buttonRelease ref = liftIO $ modifyIORef ref (scopeModifyView viewButtonRelease)--motion :: IORef (Scope ViewCairo) -> G.EventM G.EMotion ()-motion ref = do- (x, _y) <- G.eventCoordinates- liftIO $ do- View{..} <- view <$> readIORef ref- cX <- screenToCanvas viewUI (ScreenX x)- scopeModifyUpdate ref (viewButtonMotion cX)--wheel :: IORef (Scope ViewCairo) -> G.EventM G.EScroll ()-wheel ref = do- (x, _y) <- G.eventCoordinates- dir <- G.eventScrollDirection- liftIO $ do- scope <- readIORef ref- let View{..} = view scope- cX <- screenToCanvas viewUI (ScreenX x)- case dir of- G.ScrollUp -> scopeModifyUpdate ref (viewZoomInOn cX 1.2)- G.ScrollDown -> scopeModifyUpdate ref (viewZoomOutOn cX 1.2)- _ -> return ()--scroll :: IORef (Scope ViewCairo) -> IO ()-scroll ref = do- val <- G.adjustmentGetValue =<< adj . viewUI . view <$> readIORef ref- scopeModifyUpdate ref (viewMoveTo val)---------------------------------------------------------------------- Some keys we are interested in, from:--- http://cgit.freedesktop.org/xorg/proto/x11proto/plain/keysymdef.h-#define XK_Home 0xff50-#define XK_Left 0xff51 /* Move left, left arrow */-#define XK_Up 0xff52 /* Move up, up arrow */-#define XK_Right 0xff53 /* Move right, right arrow */-#define XK_Down 0xff54 /* Move down, down arrow */-#define XK_Page_Up 0xff55-#define XK_Page_Down 0xff56-#define XK_End 0xff57 /* EOL */--keyDown :: IORef (Scope ViewCairo) -> G.EventM G.EKey ()-keyDown ref = do- v <- G.eventKeyVal- -- n <- G.eventKeyName- -- liftIO . putStrLn $ printf "Key %s (%d) pressed" n v- let f = case v of- XK_Home -> Just viewMoveStart- XK_End -> Just viewMoveEnd- XK_Up -> Just $ viewZoomIn 2.0- XK_Down -> Just $ viewZoomOut 2.0- XK_Left -> Just viewMoveRight- XK_Right -> Just viewMoveLeft- _ -> Nothing-- maybe (return ()) (liftIO . scopeModifyUpdate ref) f--------------------------------------------------------------------plotWindow :: Int -> Int -> IORef (Scope ViewCairo) -> C.Render ()-plotWindow width height ref = do- scope <- liftIO $ readIORef ref- prologue width height- modifyIORefM ref plotLayers- plotTimeline scope- plotCursor scope---- Set up stuff-prologue :: Int -> Int -> C.Render ()-prologue wWidth wHeight = do- -- Define viewport coords as (-1.0, -1.0) - (1.0, 1.0)- let width = 1.0- height = 2.0- scaleX = realToFrac wWidth / width- scaleY = realToFrac wHeight / height-- -- style and color- C.setLineCap C.LineCapRound- C.setLineJoin C.LineJoinRound- C.setLineWidth $ 1 / max scaleX scaleY- C.setSourceRGBA 0.5 0.7 0.5 0.5-- -- Set up user coordinates- C.scale scaleX scaleY- -- center origin vertically- C.translate 0 (height / 2)- -- positive y-axis upwards- let flipY = M.Matrix 1 0 0 (-1) 0 0- C.transform flipY--------------------------------------------------------------------------plotCursor :: Scope ViewCairo -> C.Render ()-plotCursor scope = maybe (return ()) f pointerX- where- View{..} = view scope- f :: CanvasX -> C.Render ()- f (CanvasX cX) = do- C.setSourceRGBA 0 0.7 0 0.4- C.moveTo cX (-1.0)- C.lineTo cX 1.0- C.stroke--------------------------------------------------------------------------class Coordinate a => Timelineable a where- timeLabel :: a -> String- toCanvas :: Scope ui -> a -> CanvasX--instance Timelineable TimeStamp where- timeLabel = prettyTimeStamp- toCanvas = timeStampToCanvas--instance Timelineable UTCTime where- timeLabel = formatTime defaultTimeLocale "%Y-%m-%d %T"- toCanvas = utcToCanvas--plotTimeline :: Scope ViewCairo -> C.Render ()-plotTimeline scope = do- case (dataToUTC scope viewX1, dataToUTC scope viewX2) of- (Just s, Just e) -> do- plotAllTicks s e- plotAllLabels s e- _ -> case (dataToTimeStamp scope viewX1, dataToTimeStamp scope viewX2) of- (Just s, Just e) -> do- plotAllTicks s e- plotAllLabels s e- _ -> return ()- maybe (return ()) plotArrow pointerX- where- View{..} = view scope-- plotAllTicks :: Timelineable a => a -> a -> C.Render ()- plotAllTicks s e = do- plotTicks 0.001 0.05 s e- plotTicks 0.01 0.1 s e- plotTicks 0.02 1.0 s e- plotTicks 0.04 5.0 s e- plotTicks 0.06 10.0 s e- plotTicks 0.08 60.0 s e- plotTicks 0.10 3600.0 s e-- plotTicks :: Timelineable a => Double -> Double -> a -> a -> C.Render ()- plotTicks len step start end =- when doDraw $ mapM_ (plotTick len start) (map fromDouble [s, s+step .. end'])- where- doDraw = (end' - start') / step < 100- s = (fromIntegral (floor (start'/step) :: Integer)) * step- start' = toDouble start- end' = toDouble end-- plotTick :: Timelineable a => Double -> a -> a -> C.Render ()- plotTick len _unify ts = do- let (CanvasX cX) = toCanvas scope ts- C.setSourceRGBA 0 0 0 1.0- C.moveTo cX 0.90- C.lineTo cX (0.90 + len)- C.stroke-- plotAllLabels :: Timelineable a => a -> a -> C.Render ()- plotAllLabels start end =- mapM_ (\s -> plotLabels s start end) steps- where- readable x = let viz = (end' - start') / x in (viz < 5 && viz >= 1)- steps = take 1 . filter readable $ [3600, 60, 10, 5, 1, 0.1, 0.05]- start' = toDouble start- end' = toDouble end-- plotLabels :: Timelineable a => Double -> a -> a -> C.Render ()- plotLabels step start end = keepState $ do- let flipY = M.Matrix 1 0 0 (-2.2) 0 0- C.transform flipY-- let s = (fromIntegral (floor (start'/step) :: Integer)) * step- mapM_ (plotLabel start . fromDouble) [s, s+step .. end']- where- start' = toDouble start- end' = toDouble end-- plotLabel :: Timelineable a => a -> a -> C.Render ()- plotLabel _unify ts = do- let CanvasX cX = toCanvas scope ts- drawString (timeLabel ts) cX (-0.44)--drawString :: String -> Double -> Double -> C.Render ()-drawString s x y = do- C.selectFontFace "sans" C.FontSlantNormal C.FontWeightNormal- C.setFontSize 0.02- C.moveTo x y- C.textPath s- C.fillPreserve--plotArrow :: CanvasX -> C.Render ()-plotArrow (CanvasX cX) = do- C.setSourceRGBA 0 0 0 0.9- C.moveTo (cX-0.004) (0.99)- C.lineTo (cX+0.004) (0.99)- C.lineTo cX (0.98)- C.fill--------------------------------------------------------------------------modifyIORefM :: MonadIO m => IORef a -> (a -> m a) -> m ()-modifyIORefM ref f = do- x <- liftIO $ readIORef ref- x' <- f x- liftIO $ writeIORef ref x'-
− src/main.hs
@@ -1,29 +0,0 @@-{-# OPTIONS -Wall #-}--module Main where--import Control.Concurrent.Chan-import Control.Monad (when)-import System.Environment (getArgs)--import Children-import GUI--main :: IO ()-main = do- args <- getArgs- setupMonitor args--setupMonitor :: [String] -> IO ()-setupMonitor args = later waitForChildren $ do- chan <- newChan- _ <- forkChild (guiMain chan args)- monitor chan- where- later x y = y >> x--monitor :: Chan String -> IO()-monitor chan = do- x <- readChan chan- -- putStrLn $ "Received message: " ++ x- when (x /= "quit") $ monitor chan