-----------------------------------------------------------------------------
--
-- 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
-}