diff --git a/Scope/Cairo.hs b/Scope/Cairo.hs deleted file mode 100644 --- a/Scope/Cairo.hs +++ /dev/null @@ -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 - diff --git a/data/actions.ui b/data/actions.ui deleted file mode 100644 --- a/data/actions.ui +++ /dev/null @@ -1,22 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - diff --git a/demo/demo1.zoom b/demo/demo1.zoom deleted file mode 100644 Binary files a/demo/demo1.zoom and /dev/null differ diff --git a/demo/demo2.zoom b/demo/demo2.zoom deleted file mode 100644 Binary files a/demo/demo2.zoom and /dev/null differ diff --git a/demo/demo3.zoom b/demo/demo3.zoom deleted file mode 100644 Binary files a/demo/demo3.zoom and /dev/null differ diff --git a/demo/demo4.zoom b/demo/demo4.zoom deleted file mode 100644 Binary files a/demo/demo4.zoom and /dev/null differ diff --git a/scope.cabal b/scope.cabal --- a/scope.cabal +++ b/scope.cabal @@ -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/! + . - 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! + 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 diff --git a/src/Children.hs b/src/Children.hs deleted file mode 100644 --- a/src/Children.hs +++ /dev/null @@ -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 ()) diff --git a/src/GUI.hs b/src/GUI.hs deleted file mode 100644 --- a/src/GUI.hs +++ /dev/null @@ -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' - diff --git a/src/main.hs b/src/main.hs deleted file mode 100644 --- a/src/main.hs +++ /dev/null @@ -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