diff --git a/Config.hs b/Config.hs
new file mode 100644
--- /dev/null
+++ b/Config.hs
@@ -0,0 +1,87 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Config.hs
+-- Copyright : (c) Asumu Takikawa 2007
+-- License :
+--
+-- Maintainer :
+-- Stability : unstable
+-- Portability : not portable, PropLang
+--
+-- GuiHaskell configuration API
+--
+-- GuiHaskell stores each configuration value in a
+-- separate file inside of a configuration directory
+-- (e.g. ~/.guihaskell/config)
+--
+-----------------------------------------------------------------------------
+
+module Config (
+ confInit, newConfValueWithDefault
+ ) where
+
+import Control.Monad
+import System.Directory
+import System.FilePath
+import System.IO
+import System.IO.Error
+
+import PropLang.Event
+import PropLang.Value
+
+--
+-- Make sure we can do config stuff
+--
+confInit :: IO ()
+confInit = do
+ d <- getConfigDir
+ createDirectoryIfMissing True d
+
+--
+-- A value constructor that reads and writes using a
+-- set of config files
+--
+--newConfValue :: (Eq a, Show a, Read a) => String -> Event -> IO (Value a)
+--newConfValue = newConfValueWithDefault ""
+
+--
+-- Config constructor that takes a default value
+--
+newConfValueWithDefault
+ :: (Eq a, Show a, Read a) => a -> String -> Event -> IO (Value a)
+newConfValueWithDefault def name ev = do
+ cf <- confFile
+ exists <- doesFileExist cf
+ if exists then do return ()
+ else do openFile cf WriteMode >>= hClose -- touch
+ return $ Value (setter) (getter)
+ where
+ setter x = do
+ cf <- confFile
+ old <- getter
+ h <- openFile cf WriteMode
+ hPutStr h $ show x
+ hClose h
+ if old /= x then do raise ev
+ else do return ()
+
+ getter = do
+ cf <- confFile
+ h <- openFile cf ReadMode
+ val <- catch (readIO =<< hGetLine h)
+ (\e -> if isEOFError e
+ then return def
+ else ioError e)
+ hClose h
+ return val
+
+ confFile = do d <- getConfigDir; return $ d name
+
+--
+-- The directory where config files reside
+-- Might need special case for Windows?
+--
+getConfigDir :: IO FilePath
+getConfigDir = do
+ d <- getHomeDirectory
+ return $ d ".guihaskell" "config"
diff --git a/Data.hs b/Data.hs
new file mode 100644
--- /dev/null
+++ b/Data.hs
@@ -0,0 +1,227 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Data.hs
+-- Copyright : (c) Neil Mitchell 2007
+-- License :
+--
+-- Maintainer :
+-- Stability : unstable
+-- Portability : not portable, uses Gtk2Hs
+--
+-- Defines the core data structures for GuiHaskell.
+--
+-- Data passes around some global state. Data includes
+-- EvalState, which holds the states of the individual
+-- compilers that GuiHaskell can run.
+--
+-----------------------------------------------------------------------------
+
+module Data (
+ Data(..), Evaluator(..), Handles(..),
+ empty, getHandles, setHandles, setCurrentFile,
+ setupFonts, appendText, appendRed, applyEscape,
+ promptCmd
+ ) where
+
+import PropLang.Gtk
+import PropLang.Variable
+
+import Data.Map (Map)
+import qualified Data.Map as M
+
+import Control.Concurrent (ThreadId)
+import System.IO (Handle)
+import System.Process (ProcessHandle)
+import Text.EscapeCodes
+
+import Control.Monad
+import Numeric
+
+import Graphics.UI.Gtk hiding (Action, Window, ComboBox, MenuItem, TextView, ToolButton, FontButton, Event, onClicked, onChanged)
+
+
+data Data = Data {
+ -- Main Window and friends
+ window :: Window
+ , txtOut :: TextView
+ , txtIn :: TextView
+ , txtSelect :: TextEntry
+ , sb :: StatusBar
+
+ , tbRun :: ToolButton
+ , tbStop :: ToolButton
+ , tbRestart :: ToolButton
+ , tbOpen :: ToolButton
+ , tbRecent :: ToolButton
+ , tbProfile :: ToolButton
+ , tbPref :: ToolButton
+
+ , cbCompiler :: ComboBox
+
+ , fbFont :: FontButton
+
+ , miFile :: MenuItem
+ , miOpen :: MenuItem
+ , miQuit :: MenuItem
+ , miEdit :: MenuItem
+ , miCut :: MenuItem
+ , miCopy :: MenuItem
+ , miPaste :: MenuItem
+ , miView :: MenuItem
+ , miTools :: MenuItem
+ , miRun :: MenuItem
+ , miProfile :: MenuItem
+ , miPref :: MenuItem
+ , miHelp :: MenuItem
+ , miAbout :: MenuItem
+
+ -- Preferences Dialog and friends
+ , wndPref :: Window
+ , txtExecutable :: TextEntry
+ , txtProfCFlags :: TextEntry
+ , txtProfRFlags :: TextEntry
+ , tbClose :: ToolButton
+
+ -- About dialog
+ , wndAbout :: Window
+
+ , running :: Var Bool -- is the code executing
+ , filename :: Var (Maybe FilePath) -- the main file loaded
+ , outputTags :: Var [String]
+ , history :: Var ([String], [String]) -- command history
+
+ -- Configuration variables
+ , profCFlags :: Var String
+ , profRFlags :: Var String
+ , executable :: Var FilePath
+ , font :: Var String
+
+ --
+ -- Stores the current evaluator and
+ -- the states of background evaluators
+ --
+ -- When a new evaluator is chosen, the
+ -- current evaluator is swapped into the list
+ -- and the new evalutor is put into current
+ , current :: Var Evaluator
+ , states :: Var (Map Evaluator Handles)
+ }
+
+--
+-- A data structure for storing the compiler-specific
+-- details
+--
+data Handles = Handles {
+ handle :: Handle,
+ process :: ProcessHandle,
+ outId :: ThreadId,
+ errId :: ThreadId
+ }
+
+-- hack!
+-- shouldn't matter as long as you use Var like an IORef
+-- maybe ProcessHandle should instantiate Eq
+instance Eq Handles where
+ _ == _ = True
+
+data Evaluator = Hugs | GHCi deriving (Show, Read, Eq, Ord)
+
+
+-- So Main doesn't need to import Map
+empty :: Map Evaluator Handles
+empty = M.empty
+
+-- Probably belongs in Evaluator.hs
+promptCmd :: Evaluator -> String -> String
+promptCmd Hugs xs = ":set -p\"" ++ xs ++ "\""
+promptCmd GHCi xs = ":set prompt " ++ xs
+
+-- Get the current evaluator
+getHandles :: Data -> IO (Maybe Handles)
+getHandles dat = do
+ c <- getVar $ current dat
+ s <- getVar $ states dat
+ return $ M.lookup c s
+
+-- Set the handles for the current evaluator
+setHandles :: Data -> Maybe Handles -> IO ()
+setHandles dat hndls = do
+ c <- getVar $ current dat
+ s <- getVar $ states dat
+ case hndls of
+ Nothing -> states dat -< M.delete c s
+ Just x ->
+ case M.lookup c s of
+ Nothing -> states dat -< M.insert c x s
+ Just _ -> states dat -< M.adjust (\_ -> x) c s
+
+-- Set the currently open file
+setCurrentFile :: Data -> Maybe FilePath -> IO ()
+setCurrentFile dat path = do
+ filename dat -< path
+
+--
+--
+--
+setupFonts :: Data -> IO ()
+setupFonts dat@Data{txtOut=out,txtIn=inp} = do
+ buf <- textviewBuffer out
+ tags <- textBufferGetTagTable buf
+ fontStr <- getVar $ (fbFont dat)!text
+
+ mapM (addTags tags) [minBound..maxBound]
+
+ fdesc <- fontDescriptionFromString fontStr
+
+ widgetModifyFont (getTextViewRaw out) (Just fdesc)
+ widgetModifyFont (getTextViewRaw inp) (Just fdesc)
+
+ where
+ addTags tags col = do
+ let name = show col
+ (r,g,b) = getColor col
+ f x = let xs = showHex x "" in ['0' | length xs == 1] ++ xs
+ css = "#" ++ f r ++ f g ++ f b
+
+ tagFg <- textTagNew (Just $ "fg" ++ name)
+ tagBg <- textTagNew (Just $ "bg" ++ name)
+ textTagTableAdd tags tagFg
+ textTagTableAdd tags tagBg
+ set tagFg [textTagForeground := css]
+ set tagBg [textTagBackground := css]
+
+--
+-- Append text to output area
+--
+appendText :: Data -> String -> IO ()
+appendText dat@Data{txtOut=out} s = do
+ buf <- textviewBuffer out
+ end <- textBufferGetEndIter buf
+ textBufferInsert buf end s
+
+ len <- textBufferGetCharCount buf
+ strt <- textBufferGetIterAtOffset buf (len - length s)
+ end2 <- textBufferGetEndIter buf
+ tags <- getVar (outputTags dat)
+ mapM_ (f buf strt end2) tags
+ where
+ f buf strt end tag = textBufferApplyTagByName buf tag strt end
+
+
+appendRed :: Data -> String -> IO ()
+appendRed dat msg = do
+ let tags = outputTags dat
+ res <- getVar tags
+ tags -< ["fgRed"]
+ appendText dat msg
+ tags -< res
+
+
+applyEscape :: Data -> EscapeCode -> IO ()
+applyEscape dat (FormatAttribute Normal) = outputTags dat -< []
+applyEscape dat (FormatForeground Green) = outputTags dat -< ["fgGreen"]
+applyEscape _ _ = return ()
+
+
+--when_ :: Monad m => Bool -> m () -> m ()
+--when_ b x = when b (x >> return ())
diff --git a/Evaluator.hs b/Evaluator.hs
new file mode 100644
--- /dev/null
+++ b/Evaluator.hs
@@ -0,0 +1,158 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Evaluator.hs
+-- Copyright : (c) Neil Mitchell 2007
+-- License :
+--
+-- Maintainer :
+-- Stability : unstable
+-- Portability : not portable, uses Gtk2Hs
+--
+-- Evaluator functions.
+--
+-----------------------------------------------------------------------------
+
+module Evaluator (
+ switchEvaluator, startEvaluator, stopEvaluator,
+ startWithFile, runExternal
+ ) where
+
+import Control.Concurrent
+import Data.Char
+import System.Directory
+import System.IO
+import System.Process
+
+import PropLang.Variable
+
+import Data
+import Text.EscapeCodes
+import Util
+
+
+prompt :: String
+prompt = "\x1B[0;32m%s>\x1B[0m \x1B[50m"
+
+--
+-- Switch the currently running evaluator
+--
+switchEvaluator :: Data -> IO ()
+switchEvaluator dat = do
+ hndl <- getHandles dat
+ case hndl of
+ Nothing -> do
+ startEvaluator dat Nothing
+ Just (Handles inp _ _ _) -> do
+ appendText dat "\nSwitching...\n"
+ putStrLn "Switching evaluators"
+ hPutStrLn inp $ ""
+
+--
+-- Start an evaluator
+--
+startEvaluator :: Data -> Maybe [String] -> IO ()
+startEvaluator dat args = do
+ name <- getVar $ current dat
+ path <- getCompilerPath name
+ case path of
+ Nothing -> do
+ errorMessage dat $ show name ++ " not found, please install."
+ Just x -> do
+ runCompiler x
+ where
+ runCompiler path = do
+ name <- getVar $ current dat
+ (inp,out,err,pid) <- runExternal path args
+
+ appendText dat $ "\nLoading " ++ show name ++ "...\n"
+ hPutStrLn inp $ promptCmd name prompt
+ hPutStrLn inp $ "putChar '\\01'"
+
+ oid <- forkIO (readOut name out)
+ eid <- forkIO (readErr name err)
+
+ setHandles dat (Just $ Handles inp pid oid eid)
+
+ readOut :: Evaluator -> Handle -> IO ()
+ readOut Hugs hndl = do
+ c <- hGetContents hndl
+ let c2 = filter (/= '\r') $ tail $ dropWhile (/= '\01') c
+ mapM_ app $ parseEscapeCodes c2
+ readOut GHCi hndl = do
+ c <- hGetContents hndl
+ let c2 = filter (/= '\r') $ tail $ dropWhile (/= '\01') c
+ mapM_ app $ parseEscapeCodes c2
+
+ readErr :: Evaluator -> Handle -> IO ()
+ readErr Hugs _ = return ()
+ readErr GHCi hndl = do
+ c <- hGetContents hndl
+ let c2 = filter (/= '\r') c
+ mapM_ (\x -> appendRed dat [x]) c2
+
+ app (Left c) = appendText dat [c]
+ app (Right (FormatUnknown 50)) = running dat -< False
+ app (Right e) = applyEscape dat e
+
+ getCompilerPath c = do
+ case c of
+ Hugs -> getHugsPath
+ _ -> getOtherPath c
+
+--
+-- Useful wrapper around runInteractiveProcess
+--
+runExternal :: FilePath -> Maybe [String] -> IO (Handle, Handle, Handle, ProcessHandle)
+runExternal path args = do
+ hndls@(inp, out, err, _) <- runInteractiveProcess path
+ (maybe [] id args)
+ Nothing Nothing
+ putStrLn $ "Starting external tool: " ++ path
+ hSetBuffering out NoBuffering
+ hSetBuffering err NoBuffering
+ hSetBuffering inp NoBuffering
+ hSetBinaryMode out True
+ hSetBinaryMode err True
+ return hndls
+
+--
+-- Stop the currently running evaluator
+--
+stopEvaluator :: Data -> IO ()
+stopEvaluator dat = do
+ hndls <- getHandles dat
+ case hndls of
+ Nothing -> return ()
+ Just (Handles inp pid _ _) -> do
+ setHandles dat Nothing
+ hPutStrLn inp "\n:quit\n"
+ waitForProcess pid
+ return ()
+
+--
+-- Run a compiler with a file
+--
+startWithFile :: Data -> IO ()
+startWithFile dat = do
+ path <- getVar $ filename dat
+ case path of
+ Nothing ->
+ errorMessage dat "No file selected for evaluation."
+ Just p -> do
+ stopEvaluator dat
+ appendText dat "Evaluating file...\n"
+ startEvaluator dat $ Just [p]
+
+getHugsPath :: IO (Maybe FilePath)
+getHugsPath = do
+ path <- findExecutable "hugs"
+ case path of
+ Just x -> return $ Just x
+ Nothing -> do
+ let guesses = ["c:\\Program Files\\WinHugs\\hugs.exe"]
+ res <- mapM doesFileExist guesses
+ let ans = map snd $ filter fst $ zip res guesses
+ return $ if null ans then Nothing else Just (head ans)
+
+getOtherPath :: Evaluator -> IO (Maybe FilePath)
+getOtherPath = findExecutable . map toLower . show
diff --git a/GuiHaskell.cabal b/GuiHaskell.cabal
new file mode 100644
--- /dev/null
+++ b/GuiHaskell.cabal
@@ -0,0 +1,21 @@
+Name: GuiHaskell
+Synopsis: A graphical REPL and development environment for Haskell
+Description:
+ GuiHaskell aims to be a cross-platform development environment
+ for Haskell that is integrated with other popular Haskell tools.
+ The program uses the PropLang GUI combinator library to declaratively
+ define the relationships between UI elements and data.
+Version: 0.1
+License: BSD3
+License-file: LICENSE
+Author: Neil Mitchell, Asumu Takikawa
+Stability: Alpha
+Homepage: http://www-users.cs.york.ac.uk/~ndm/guihaskell/
+Category: Development
+Build-Depends: base>=2.0, filepath>=1.0, proplang>=0.1, gtk>=0.9.11, glade>=0.9.11, parsec
+Data-files: res/guihaskell.glade res/prefdialog.glade res/about.glade
+
+Executable: guihaskell
+Main-is: Main.hs
+Other-modules: Config Data Evaluator Prof Util Text.EscapeCodes
+Ghc-options: -O2 -Wall
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) Neil Mitchell
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. 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.
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.
diff --git a/Main.hs b/Main.hs
new file mode 100644
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,295 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main.hs
+-- Copyright : (c) Neil Mitchell 2007
+-- License :
+--
+-- Maintainer :
+-- Stability : unstable
+-- Portability : not portable, uses Gtk2Hs
+--
+-----------------------------------------------------------------------------
+
+module Main where
+
+import PropLang.Gtk
+import PropLang.Variable
+import PropLang.Value
+import PropLang.Event
+
+import Control.Monad
+import Data.Char
+import Data.Maybe
+import System.IO
+
+import Control.Concurrent
+
+import Graphics.UI.Gtk hiding (Action, Window, ComboBox, MenuItem, TextView, ToolButton, FontButton, Event, onClicked, onChanged)
+import Graphics.UI.Gtk.Glade
+
+import System.Exit
+import System.Posix.Signals
+import System.Process
+
+import Config
+import Data
+import Evaluator
+import Prof
+import Util
+
+main :: IO ()
+main = do
+ initPropLang
+ confInit
+ window <- getWindow "res/guihaskell.glade" "wndMain"
+ prefWindow <- getWindow "res/prefdialog.glade" "wndPref"
+ aboutWindow <- getWindow "res/about.glade" "wndAbout"
+ running <- newVarName "evaluator_on_off" True
+ filename <- newVarWithName "selected_filename"
+ (newConfValueWithDefault Nothing "selected_filename")
+ tags <- newVar []
+ history <- newVar ([], [])
+
+ -- Configuration variables
+ profCFlags <- newVarWithName "profiler_cflags_conf"
+ (newConfValueWithDefault "-prof -auto-all" "profCFlags")
+ profRFlags <- newVarWithName "profiler_rflags_conf"
+ (newConfValueWithDefault "+RTS -p" "profRFlags")
+ executable <- newVarWithName "executable_name"
+ (newConfValueWithDefault "foobar.exe" "executable")
+ font <- newVarWithName "textview_font"
+ (newConfValueWithDefault "Monospace 12" "textview_font")
+
+ -- Evaluator variables
+ current <- newVarWithName "current_evaluator"
+ (newConfValueWithDefault GHCi "current_evaluator")
+ states <- newVarName "evaluator_states" empty
+
+ let f x = getCtrl window x
+ g x = getCtrl prefWindow x
+ dat = Data window
+ (f "txtOut") (f "txtIn") (f "txtSelect") (f "sb")
+ (f "tbRun") (f "tbStop") (f "tbRestart")
+ (f "tbOpen") (f "tbRecent") (f "tbProfile") (f "tbPref")
+ (f "cbCompiler") (f "fbFont")
+ (f "miFile") (f "miOpen") (f "miQuit")
+ (f "miEdit") (f "miCut") (f "miCopy") (f "miPaste")
+ (f "miView")
+ (f "miTools") (f "miRun") (f "miProfile") (f "miPref")
+ (f "midHelp") (f "miAbout")
+ prefWindow
+ (g "txtExecutable") (g "txtProfCFlags") (g "txtProfRFlags")
+ (g "tbClose")
+ aboutWindow
+ running filename tags history
+ profCFlags profRFlags executable font
+ current states
+
+ startEvaluator dat Nothing
+ setupRelations dat
+ setupFonts dat
+
+ showWindowMain window
+
+--
+-- Run an open file dialog and
+-- return the selection
+--
+runFileDialog :: IO (Maybe FilePath)
+runFileDialog = do
+ dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen [("Okay", ResponseOk), ("Cancel", ResponseCancel)]
+ response <- dialogRun dialog
+ widgetHide dialog
+ handleResponse dialog response
+ where
+ handleResponse dialog response =
+ case response of
+ ResponseOk -> fileChooserGetFilename dialog
+ _ -> return Nothing
+
+--
+-- Defines the actions for GUI elements
+--
+setupRelations :: Data -> IO ()
+setupRelations dat@Data
+ -- This is ugly, but at least it's readable
+ { window =window
+ , tbRun =tbRun
+ , tbStop =tbStop
+ , tbRestart =tbRestart
+ , tbOpen =tbOpen
+ , tbPref =tbPref
+ , tbProfile =tbProfile
+ , cbCompiler =cbCompiler
+ , fbFont =fbFont
+ , txtIn =txtIn
+ , txtSelect =txtSelect
+ , miFile =miFile
+ , miOpen =miOpen
+ , miQuit =miQuit
+ , miRun =miRun
+ , miProfile =miProfile
+ , miPref =miPref
+ , miHelp =miHelp
+ , miAbout =miAbout
+ , wndPref =wndPref
+ , txtExecutable =txtExecutable
+ , txtProfCFlags =txtProfCFlags
+ , txtProfRFlags =txtProfRFlags
+ , tbClose =tbClose
+ , wndAbout =wndAbout
+ , running =running
+ , filename =filename
+ , executable =executable
+ , profCFlags =profCFlags
+ , profRFlags =profRFlags
+ , font =font
+ , current =current
+ } = do
+
+ -- Evaluator events
+ tbRun!onClicked += fireCommand dat
+ tbRestart!onClicked += refreshCommand dat
+ tbOpen!onClicked += (runFileDialog >>= setCurrentFile dat >> startWithFile dat)
+ tbStop!onClicked += stopCommand dat
+ onEnterKey txtIn $ fireCommand dat
+
+ -- Evaluator selection
+ injectWith (cbCompiler!text) current show
+ current =< with1 (cbCompiler!text) (\x -> if null x then Hugs else read x)
+ current += switchEvaluator dat
+
+ -- Filename selection
+ injectWith (txtSelect!text) filename (maybe "" id)
+ tie (txtSelect!text) filename
+ (\t -> if null t then Nothing else Just t) (maybe "" id)
+
+ -- Evaluator runtime status
+ tbRun!enabled =< with1 running not
+ tbStop!enabled =<= running
+
+ -- Tools
+ tbProfile!onClicked += runProf dat
+
+ -- Config Events
+ tbPref!onClicked += showWindow wndPref
+ miPref!onActivated += showWindow wndPref
+ -- Hack
+ tbClose!onClicked += closeWindow wndPref
+ fbFont!text -<- font
+ fbFont!text =<>= font
+ fbFont!text += setupFonts dat
+
+ -- Need "-<-" first to populate GUI at startup
+ -- Then tie them
+ txtExecutable!text -<- executable
+ txtExecutable!text =<>= executable
+ txtProfCFlags!text -<- profCFlags
+ txtProfCFlags!text =<>= profCFlags
+ txtProfRFlags!text -<- profRFlags
+ txtProfRFlags!text =<>= profRFlags
+
+ -- Key Events
+ -- Fixed some of the key event bugs. This should work.
+ -- The enter key still doesn't work though...
+ --enterKey <- newVarWithName "enter_key_pressed?"
+ -- (newPredValue "" ((==) "Return"))
+ --enterKey =<= (txtIn!key)
+ --enterKey += (fireCommand dat)
+ upKey <- newVarWithName "arrow_up_pressed?"
+ (newPredValue "" ((==) "Up"))
+ upKey =<= (txtIn!key)
+ upKey += (nextHistory dat)
+ downKey <- newVarWithName "arrow_down_pressed?"
+ (newPredValue "" ((==) "Down"))
+ downKey =<= (txtIn!key)
+ downKey += (previousHistory dat)
+
+ -- Menus
+ miOpen!onActivated += (raise $ tbOpen!onClicked)
+ miQuit!onActivated += mainQuit
+ -- TODO: This should also run "main" too like in most IDEs,
+ -- but concurrency makes that weird
+ miRun!onActivated += refreshCommand dat
+ miProfile!onActivated += runProf dat
+ miAbout!onActivated += (runDialogRaw wndAbout >> closeWindow wndAbout)
+
+ return ()
+
+ where
+ runDialogRaw = dialogRun . castToDialog . getWindowRaw
+ closeWindow = widgetHide . getWindowRaw
+
+--
+-- Sends entered text to processes
+--
+fireCommand :: Data -> IO ()
+fireCommand dat@Data{txtOut=txtOut, txtIn=txtIn} = do
+ handles <- getHandles dat
+ hist <- getVar $ history dat
+ case handles of
+ Nothing -> errorMessage dat "Can't send command; compiler not running."
+ Just (Handles inp _ _ _) -> do
+ s <- getVar (txtIn!text)
+ running dat -< True
+ appendText dat (s ++ "\n")
+ forkIO (hPutStrLn inp s)
+ txtIn!text -< ""
+ if null $ dropWhile isSpace s
+ then history dat -< ([], fst hist ++ snd hist)
+ else history dat -< ([], s : fst hist ++ snd hist)
+
+refreshCommand :: Data -> IO ()
+refreshCommand dat = do
+ path <- getVar $ filename dat
+ case path of
+ Nothing -> startEvaluator dat Nothing
+ Just _ -> startWithFile dat
+
+--
+-- Stop the currently running process
+--
+stopCommand :: Data -> IO ()
+stopCommand dat = do
+ handles <- getHandles dat
+ case handles of
+ Nothing -> errorMessage dat "No compiler running to stop."
+ Just (Handles inp pid oid eid) -> do
+ killThread oid
+ killThread eid
+ terminateProcess pid
+ waitForProcess pid
+ setHandles dat Nothing
+ startEvaluator dat Nothing
+
+-- Get the next oldest command from history
+nextHistory :: Data -> IO ()
+nextHistory dat@Data {txtIn=txtIn} = do
+ h <- getVar $ history dat
+ case h of
+ (xs, y:ys) -> do
+ (txtIn!text) -< y
+ history dat -< (y:xs, ys)
+ _ -> return ()
+
+-- Get a command that's one newer
+previousHistory :: Data -> IO ()
+previousHistory dat@Data {txtIn=txtIn} = do
+ h <- getVar $ history dat
+ case h of
+ (x:x2:xs, ys) -> do
+ (txtIn!text) -< x2
+ history dat -< (x2:xs, x:ys)
+ _ -> do
+ (txtIn!text) -< ""
+ history dat -< ([], fst h ++ snd h)
+
+{-
+stopCommand :: Data -> IO ()
+stopCommand dat = do
+ handles <- getHandles dat
+ case handles of
+ Nothing -> return ()
+ Just (pid, inp) -> do
+ signalProcess sigINT pid
+-}
diff --git a/Prof.hs b/Prof.hs
new file mode 100644
--- /dev/null
+++ b/Prof.hs
@@ -0,0 +1,166 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Prof.hs
+-- Copyright : (c) Asumu Takikawa 2007
+-- License :
+--
+-- Maintainer :
+-- Stability : unstable
+-- Portability : not portable
+--
+-----------------------------------------------------------------------------
+
+module Prof where
+
+import Data.Char
+import System.Directory (doesFileExist)
+import System.FilePath
+import System.IO
+import System.Process
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Token
+import Text.ParserCombinators.Parsec.Language (haskellDef)
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.ModelView.CellLayout
+import qualified Graphics.UI.Gtk.ModelView as MView
+
+import PropLang.Variable
+
+import Data
+import Evaluator
+import Util
+
+data Profile = Profile
+ { title :: String
+ , flags :: String
+ , time :: String
+ , alloc :: String
+ }
+
+data ProfileLine = ProfileLine
+ { costCentre :: String
+ , moduleName :: String
+ , entries :: Integer
+ , indvTime :: Double
+ , indvAlloc :: Double
+ , inhTime :: Double
+ , inhAlloc :: Double
+ }
+
+--
+-- Run the profiler
+--
+runProf :: Data -> IO ()
+runProf dat = do
+ cF <- getVar $ profCFlags dat
+ rF <- getVar $ profRFlags dat
+ o <- getVar $ executable dat
+ src <- getVar $ filename dat
+ case src of
+ Just x -> do
+ exist <- doesFileExist x
+ if not exist
+ then errorMessage dat "Selected file does not exist."
+ else do
+ (_,_,_,pid) <- runExternal "ghc" $
+ Just $ words cF ++ ["-o", o] ++ [x]
+ waitForProcess pid
+ let exe = if inCurrentDir o then "." o else o
+ (_,_,_,pid2) <- runExternal exe $ Just $ words rF
+ waitForProcess pid2
+ res <- runProfileParser $ o ++ ".prof"
+ case res of
+ Left s -> errorMessage dat s
+ Right p -> runParseDialog p
+ Nothing -> do
+ errorMessage dat "No file selected for profiling."
+
+ where
+ inCurrentDir = null . fst . splitFileName
+
+-- Parse a line
+parseProfileLine :: Parser ProfileLine
+parseProfileLine = do
+ let lexer = makeTokenParser haskellDef
+ spaces
+ cc <- notSpaces ; spaces
+ mn <- notSpaces ; spaces
+ no <- natural lexer ; spaces
+ en <- natural lexer ; spaces
+ it <- float lexer ; spaces
+ ia <- float lexer ; spaces
+ iht <- float lexer ; spaces
+ iha <- float lexer
+ return $ ProfileLine cc mn en it ia iht iha
+
+ where
+ notSpaces = many $ satisfy $ not . isSpace
+
+-- Parse the profiling output
+parseProfile :: Parser [ProfileLine]
+parseProfile = do
+ ls <- many1 parseProfileLine
+ return ls
+
+-- Run the profile parsers
+runProfileParser :: FilePath -> IO (Either String (Profile, [ProfileLine]))
+runProfileParser file = do
+ b <- doesFileExist file
+ if not b
+ then return $ Left "No .prof file was found. Check that there are no compile errors or missing profiling flags."
+ else do
+ contents <- readFile file
+ let (title:_:flags:_:time:alloc:rest) = lines contents
+ prof = Profile (dropWhile isSpace title) (dropWhile isSpace flags)
+ (dropWhile isSpace time) (dropWhile isSpace alloc)
+ case parse parseProfile "" (unlines $ drop 11 $ rest) of
+ Left x -> return $ Left $ "Parse error: " ++ show x ++ "\n\n" ++
+ "This is likely a bug. Please file a report."
+ Right x -> return $ Right (prof, x)
+
+-- Set up and display the profiling dialog
+runParseDialog :: (Profile, [ProfileLine]) -> IO ()
+runParseDialog (p, ls) = do
+ d <- dialogNew
+ dialogAddButton d "gtk-close" ResponseClose
+ up <- dialogGetUpper d
+ titleLabel <- labelNew $ Just $ title p
+ flagLabel <- labelNew $ Just $ flags p
+ timeLabel <- labelNew $ Just $ time p
+ allocLabel <- labelNew $ Just $ alloc p
+
+ view <- MView.treeViewNew
+ store <- MView.treeStoreNew []
+ MView.treeViewSetModel view store
+
+ -- Thanks to the Gtk2hs folks for this
+ let createTextColumn name field = do
+ column <- MView.treeViewColumnNew
+ MView.treeViewAppendColumn view column
+ MView.treeViewColumnSetTitle column name
+ cell <- cellRendererTextNew
+ MView.treeViewColumnPackStart column cell True
+ cellLayoutSetAttributes column cell store
+ (\record -> [MView.cellText := field record])
+
+ createTextColumn "Cost Centre" costCentre
+ createTextColumn "Module" moduleName
+ createTextColumn "Entries" (show . entries)
+ createTextColumn "Individual %time" (show . indvTime)
+ createTextColumn "Individual %alloc" (show . indvAlloc)
+ createTextColumn "Inherited %time" (show . inhTime)
+ createTextColumn "Inherited %alloc" (show . inhAlloc)
+
+ mapM_ (MView.treeStoreInsert store [] 0) ls
+
+ boxPackStart up titleLabel PackNatural 0
+ boxPackStart up flagLabel PackNatural 0
+ boxPackStart up timeLabel PackNatural 0
+ boxPackStart up allocLabel PackNatural 0
+ boxPackStart up view PackRepel 0
+
+ widgetShowAll d
+ dialogRun d
+ widgetHide d
+ return ()
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/Text/EscapeCodes.hs b/Text/EscapeCodes.hs
new file mode 100644
--- /dev/null
+++ b/Text/EscapeCodes.hs
@@ -0,0 +1,69 @@
+
+module Text.EscapeCodes where
+
+import Data.Char
+import Data.Maybe
+
+
+data Attribute = Normal | Bold | Underline | Blink | Reverse | Invisible
+ deriving (Show, Eq)
+
+data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
+ deriving (Show, Eq, Enum, Bounded)
+
+
+data EscapeCode = FormatAttribute Attribute
+ | FormatForeground Color
+ | FormatBackground Color
+ | FormatUnknown Int
+ deriving (Show, Eq)
+
+
+escapeChar :: Char
+escapeChar = chr 27
+
+
+parseEscapeCodes :: String -> [Either Char EscapeCode]
+parseEscapeCodes x = f 0 x
+ where
+ f 0 (c1:c2:cs) | c1 == escapeChar && c2 == '[' = f 1 cs
+
+ f 1 (c:cs) | isDigit c = Right (g $ read a) : f 2 b
+ where (a,b) = span isDigit (c:cs)
+
+ f 2 (';':cs) = f 1 cs
+ f 2 ('m':cs) = f 0 cs
+
+ -- defensive coding, never pattern match
+ -- always continue producing
+ f _ (c:cs) = Left c : f 0 cs
+ f _ [] = []
+
+
+ g :: Int -> EscapeCode
+ g x | x >= 30 && x <= 37 = FormatForeground $ toEnum (x - 30)
+ | x >= 40 && x <= 47 = FormatBackground $ toEnum (x - 40)
+ | otherwise = case lookup x attribs of
+ Nothing -> FormatUnknown x
+ Just y -> FormatAttribute y
+
+ attribs = [(0, Normal),
+ (1, Bold),
+ (4, Underline),
+ (5, Blink),
+ (7, Reverse),
+ (8, Invisible)]
+
+
+getColor :: Color -> (Int,Int,Int)
+getColor x = case lookup x colors of
+ Nothing -> (0,0,0)
+ Just t -> t
+ where
+ colors = [(Black, (0,0,0)),
+ (Red, (h,0,0)),
+ (Green, (0,h,0)),
+ (White, (f,f,f))]
+
+ h = 0x80
+ f = 0xff
diff --git a/Util.hs b/Util.hs
new file mode 100644
--- /dev/null
+++ b/Util.hs
@@ -0,0 +1,15 @@
+
+
+module Util where
+
+import PropLang.Gtk
+
+import Data
+import Graphics.UI.Gtk
+
+errorMessage :: Data -> String -> IO ()
+errorMessage dat msg = do
+ let parent = getWindowRaw (window dat)
+ md <- messageDialogNew (Just parent) [] MessageError ButtonsOk msg
+ dialogRun md
+ widgetHide md
diff --git a/res/about.glade b/res/about.glade
new file mode 100644
--- /dev/null
+++ b/res/about.glade
@@ -0,0 +1,39 @@
+
+
+
+
+
+ GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK
+ 5
+ About GuiHaskell
+ False
+ GTK_WIN_POS_CENTER_ON_PARENT
+ GDK_WINDOW_TYPE_HINT_DIALOG
+ False
+ GuiHaskell
+ 0.0a
+ Copyright 2007
+ A Haskell IDE written in Haskell.
+ http://www-users.cs.york.ac.uk/~ndm/guihaskell/
+ Neil Mitchell, Asumu Takikawa
+
+
+
+ True
+ GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK
+ 2
+
+
+ True
+ GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK
+ GTK_BUTTONBOX_END
+
+
+ False
+ GTK_PACK_END
+
+
+
+
+
+
diff --git a/res/guihaskell.glade b/res/guihaskell.glade
new file mode 100644
--- /dev/null
+++ b/res/guihaskell.glade
@@ -0,0 +1,524 @@
+
+
+
+
+
+ 300
+ 450
+ True
+ GuiHaskell
+ gtk-yes
+
+
+ True
+
+
+
+ False
+ False
+
+
+
+
+ True
+ True
+ 5
+ False
+ True
+
+
+ True
+ 1
+ 1
+
+
+ True
+ GTK_TOOLBAR_BOTH_HORIZ
+
+
+ True
+ True
+ Run
+ True
+ gtk-media-play
+
+
+ False
+
+
+
+
+ True
+ True
+ Stop
+ True
+ gtk-stop
+
+
+ False
+
+
+
+
+ True
+ True
+ Refresh
+ True
+ gtk-refresh
+
+
+ False
+
+
+
+
+ True
+
+
+ False
+ False
+
+
+
+
+ True
+ True
+ Open
+ True
+ gtk-open
+
+
+ False
+
+
+
+
+
+ False
+ False
+
+
+
+
+
+
+ False
+
+
+
+
+ True
+ Home
+
+
+ tab
+ False
+ False
+
+
+
+
+ True
+ GTK_TOOLBAR_BOTH_HORIZ
+
+
+ True
+
+
+ True
+ True
+ 0
+
+
+
+
+ False
+ False
+
+
+
+
+ True
+
+
+ True
+ 4
+ Compiler:
+
+
+
+
+ False
+ False
+
+
+
+
+ True
+
+
+ True
+ GHCi
+Hugs
+
+
+
+
+ False
+ False
+
+
+
+
+ True
+ True
+ gtk-preferences
+
+
+ False
+
+
+
+
+ 1
+ False
+
+
+
+
+ True
+ Options
+
+
+ tab
+ 1
+ False
+ False
+
+
+
+
+ True
+ GTK_TOOLBAR_BOTH_HORIZ
+
+
+ True
+ True
+ Profile
+ True
+ gtk-zoom-fit
+
+
+ False
+
+
+
+
+ 2
+ False
+
+
+
+
+ True
+ Tools
+
+
+ tab
+ 2
+ False
+ False
+
+
+
+
+ False
+ 1
+
+
+
+
+ True
+
+
+ True
+ Selected File:
+
+
+ False
+ False
+ 6
+
+
+
+
+ True
+ True
+ GTK_POLICY_NEVER
+ GTK_POLICY_NEVER
+ GTK_SHADOW_IN
+
+
+ True
+
+
+ True
+ True
+
+
+
+
+
+
+ 1
+
+
+
+
+ False
+ False
+ 2
+
+
+
+
+ True
+ 0
+ GTK_SHADOW_IN
+
+
+ True
+ True
+ GTK_POLICY_AUTOMATIC
+ GTK_POLICY_AUTOMATIC
+
+
+ True
+ True
+ False
+ GTK_WRAP_CHAR
+
+
+
+
+
+
+ 1
+ 3
+
+
+
+
+ True
+ 2
+ 2
+
+
+ True
+ True
+ GTK_POLICY_NEVER
+ GTK_POLICY_NEVER
+ GTK_SHADOW_ETCHED_IN
+
+
+ 20
+ True
+ True
+ True
+ False
+
+
+
+
+
+
+ False
+ False
+ 4
+
+
+
+
+ 19
+ True
+
+
+ False
+ False
+ 5
+
+
+
+
+
+
diff --git a/res/prefdialog.glade b/res/prefdialog.glade
new file mode 100644
--- /dev/null
+++ b/res/prefdialog.glade
@@ -0,0 +1,317 @@
+
+
+
+
+
+
+ Preferences
+ GTK_WINDOW_TOPLEVEL
+ GTK_WIN_POS_CENTER
+ True
+ True
+ False
+ True
+ False
+ False
+ GDK_WINDOW_TYPE_HINT_DIALOG
+ GDK_GRAVITY_NORTH_WEST
+ True
+ False
+
+
+
+ True
+ False
+ 0
+
+
+
+ True
+ True
+ True
+ True
+ GTK_POS_TOP
+ False
+ False
+
+
+
+ True
+ False
+ 0
+
+
+
+ True
+ False
+ 0
+
+
+
+ True
+ Executable name:
+ False
+ False
+ GTK_JUSTIFY_LEFT
+ False
+ False
+ 0.5
+ 0.5
+ 0
+ 0
+ PANGO_ELLIPSIZE_NONE
+ -1
+ False
+ 0
+
+
+ 15
+ False
+ False
+
+
+
+
+
+ True
+ True
+ True
+ True
+ 0
+
+ True
+ ●
+ False
+
+
+ 15
+ False
+ False
+
+
+
+
+ 0
+ True
+ True
+
+
+
+
+ False
+ True
+
+
+
+
+
+ True
+ Compilation
+ False
+ False
+ GTK_JUSTIFY_LEFT
+ False
+ False
+ 0.5
+ 0.5
+ 0
+ 0
+ PANGO_ELLIPSIZE_NONE
+ -1
+ False
+ 0
+
+
+ tab
+
+
+
+
+
+ True
+ False
+ 0
+
+
+
+ True
+ False
+ 0
+
+
+
+ True
+ Compile Flags:
+ False
+ False
+ GTK_JUSTIFY_LEFT
+ False
+ False
+ 0.5
+ 0.5
+ 0
+ 0
+ PANGO_ELLIPSIZE_NONE
+ -1
+ False
+ 0
+
+
+ 15
+ False
+ False
+
+
+
+
+
+ True
+ True
+ True
+ True
+ 0
+
+ True
+ ●
+ False
+
+
+ 15
+ False
+ False
+
+
+
+
+ 0
+ True
+ True
+
+
+
+
+
+ True
+ False
+ 0
+
+
+
+ True
+ Runtime Flags:
+ False
+ False
+ GTK_JUSTIFY_LEFT
+ False
+ False
+ 0.5
+ 0.5
+ 0
+ 0
+ PANGO_ELLIPSIZE_NONE
+ -1
+ False
+ 0
+
+
+ 15
+ False
+ False
+
+
+
+
+
+ True
+ True
+ True
+ True
+ 0
+
+ True
+ ●
+ False
+
+
+ 15
+ False
+ False
+
+
+
+
+ 0
+ True
+ True
+
+
+
+
+ False
+ True
+
+
+
+
+
+ True
+ Profiler
+ False
+ False
+ GTK_JUSTIFY_LEFT
+ False
+ False
+ 0.5
+ 0.5
+ 0
+ 0
+ PANGO_ELLIPSIZE_NONE
+ -1
+ False
+ 0
+
+
+ tab
+
+
+
+
+ 10
+ True
+ True
+
+
+
+
+
+ True
+ GTK_ORIENTATION_HORIZONTAL
+ GTK_TOOLBAR_BOTH_HORIZ
+ True
+ True
+
+
+
+ True
+ gtk-close
+ True
+ True
+ True
+
+
+ False
+ True
+
+
+
+
+ 4
+ False
+ False
+
+
+
+
+
+
+