Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial commit: based on GUI.hs from scope-cairo

  • Loading branch information...
commit 59ef1ed020739a1ad4a9b387fa2bd3b27466417b 0 parents
@kfish authored
BIN  .heapscope-cairo.cabal.swp
Binary file not shown
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Conrad Parker
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Conrad Parker nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
22 data/actions.ui
@@ -0,0 +1,22 @@
+<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>
54 heapscope-cairo.cabal
@@ -0,0 +1,54 @@
+Name: heapscope-cairo
+
+Version: 0.1.0.0
+
+Synopsis: Scope My Heap! (Cairo)
+
+Description:
+ heapscope-cairo is a GTK/Cairo tool for viewing heap profiles.
+ .
+ To run it, simply:
+ .
+ @
+ $ cabal install gtk2hs-buildtools heapscope-cairo
+ $ heapscope-cairo
+ @
+
+License: BSD3
+License-file: LICENSE
+Author: Conrad Parker
+Maintainer: conrad@metadecks.org
+Category: Development
+
+Cabal-Version: >=1.8
+Build-type: Simple
+Data-Files:
+ data/actions.ui
+
+flag splitBase
+ description: Use the split-up base package.
+
+Executable heapscope
+ if flag(splitBase)
+ build-depends:
+ base >= 3 && < 6
+ else
+ build-depends:
+ base < 3
+
+ Main-is: GUI.hs
+ Hs-Source-Dirs: ., src
+
+ Build-Depends:
+ cairo,
+ gtk,
+ mtl >= 2.0.0.0 && < 3,
+ scope >= 0.8.0.0 && < 0.9,
+ scope-cairo
+
+------------------------------------------------------------------------
+-- Git repo
+--
+source-repository head
+ type: git
+ location: git://github.com/kfish/heapscope-cairo.git
162 src/GUI.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS -Wall -fno-warn-unused-do-bind #-}
+
+module Main (
+ main
+) where
+
+import Control.Applicative ((<$>))
+import Control.Monad.Reader
+import Data.IORef
+import Data.Maybe
+import qualified Graphics.UI.Gtk as G
+import System.Environment (getArgs)
+
+import Paths_heapscope_cairo as My
+import Scope.Layer
+import Scope.Types
+
+import Scope.Cairo
+
+----------------------------------------------------------------------
+
+windowWidth, windowHeight :: Int
+windowWidth = 500
+windowHeight = 500
+
+main :: IO ()
+main = do
+ _ <- G.initGUI
+
+ args <- getArgs
+
+ 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
+
+ scopeRef <- scopeCairoNew
+ ViewCairo{..} <- viewUI . view <$> readIORef scopeRef
+
+ quita `G.on` G.actionActivated $ myQuit scopeRef window
+
+ mapM_ (modifyIORefM scopeRef . addLayersFromFile) args
+ openDialog `G.on` G.response $ myFileOpen scopeRef openDialog
+ saveDialog `G.on` G.response $ myFileSave scopeRef saveDialog
+
+ G.boxPackStart vbox frame G.PackGrow 0
+ scopeCairoDefaultEvents scopeRef
+
+ statusbar <- G.statusbarNew
+ G.boxPackStart vbox statusbar G.PackNatural 0
+
+ G.onDestroy window G.mainQuit
+
+ G.widgetShowAll window
+ G.mainGUI
+
+myQuit :: G.WidgetClass cls => IORef (Scope ViewCairo) -> cls -> IO ()
+myQuit scopeRef window = do
+ scopeModifyMUpdate scopeRef scopeClose
+ G.widgetDestroy window
+
+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"
Please sign in to comment.
Something went wrong with that request. Please try again.