diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -73,4 +73,4 @@ makeExecutable f = system $ "chmod a+x " ++ f hPageTestRunner :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -hPageTestRunner _ _ _ _ = system "cd src && runhaskell HPage/Test/Server.hs" >> return () +hPageTestRunner _ _ _ _ = system "runhaskell -isrc -idist/build/autogen HPage.Test.Server" >> return () diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.5.5 +version: 0.5.6 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -42,10 +42,11 @@ wxcore >=0.11.1, wxcore < 0.13, wx >=0.11.1, wx < 0.13, filepath >=1.1.0, filepath < 1.2, - Cabal >= 1.6, Cabal < 1.9, + Cabal >= 1.6, Cabal < 1.9, hint >= 0.3.2, hint < 0.4, eprocess >= 1.1.0, eprocess < 2, - hint-server >= 1.1.0, hint-server < 2 + hint-server >= 1.1.0, hint-server < 2, + time >= 1.1.4, time < 2 main-is: Main.hs buildable: True hs-source-dirs: src diff --git a/src/HPage/GUI/Constants.hs b/src/HPage/GUI/Constants.hs --- a/src/HPage/GUI/Constants.hs +++ b/src/HPage/GUI/Constants.hs @@ -5,4 +5,4 @@ bottomChar = "\724" charTimeout :: Int -charTimeout = 1000 +charTimeout = 2000 diff --git a/src/HPage/GUI/FreeTextWindow.hs b/src/HPage/GUI/FreeTextWindow.hs --- a/src/HPage/GUI/FreeTextWindow.hs +++ b/src/HPage/GUI/FreeTextWindow.hs @@ -9,8 +9,8 @@ import Prelude hiding (catch) import Control.Exception -import Control.Concurrent.MVar import Control.Concurrent.Process +import Control.Concurrent.MVar import System.FilePath import System.Directory import System.IO.Error hiding (try, catch) @@ -54,14 +54,18 @@ resType :: TextCtrl (), resErrors :: Var [GUIBottom] } -data GUIContext = GUICtx { guiWin :: Frame (), - guiPages :: SingleListBox (), - guiModules :: (Var Int, ListCtrl ()), - guiCode :: TextCtrl (), - guiResults :: GUIResults, - guiStatus :: StatusField, - guiTimer :: Var (TimerEx ()), - guiSearch :: FindReplaceData ()} +data GUIContext = GUICtx { guiWin :: Frame (), + guiPages :: SingleListBox (), + guiModules :: (Var Int, ListCtrl ()), + guiCode :: TextCtrl (), + guiResults :: GUIResults, + guiStatus :: StatusField, + guiTimer :: TimerEx (), + guiCharTimer :: TimerEx (), + guiSearch :: FindReplaceData (), + guiChrVar :: MVar (Maybe String), + guiChrFiller :: MVar (Handle String), + guiValFiller :: MVar (Handle (String, IO ()))} gui :: IO () gui = @@ -116,20 +120,39 @@ status <- statusField [text := "hello... this is \955Page! type in your instructions :)"] set win [statusBar := [status]] - -- Timer ... - refreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"] - varTimer <- varCreate refreshTimer + -- Timers ... + refreshTimer <- timer win [] + charTimer <- timer win [] -- Search ... search <- findReplaceDataCreate wxFR_DOWN + + chv <- newEmptyMVar + chfv <- newEmptyMVar + vfv <- newEmptyMVar let guiRes = GUIRes btnInterpret lblInterpret txtValue lbl4Dots txtType varErrors - let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status varTimer search + let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status refreshTimer charTimer search chv chfv vfv let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx - set btnInterpret [on command := onCmd "interpret" interpret] + -- Helper processes + chf <- spawn $ charFiller guiCtx + putMVar chfv chf + vf <- spawn $ valueFiller guiCtx + putMVar vfv vf -- Events + timerOnCommand refreshTimer $ refreshExpr model guiCtx + timerOnCommand charTimer $ do + wasEmpty <- tryPutMVar chv Nothing + if wasEmpty + then do + newchf <- spawn $ charFiller guiCtx + swapMVar chfv newchf >>= kill + else return () + + set btnInterpret [on command := onCmd "interpret" interpret] + set lstPages [on select := onCmd "pageChange" pageChange] set txtCode [on keyboard := \_ -> onCmd "restartTimer" restartTimer >> propagateEvent, on mouse := \e -> case e of @@ -260,18 +283,107 @@ set win [layout := column 5 [fill $ row 10 [leftL, rightL], resultsL], clientSize := sz 800 600] + -- test the server... + runTxtHPSelection "1" model HP.interpret + -- ...and RUN! refreshPage model guiCtx onCmd "start" openHelpPage set win [visible := True] focusOn txtCode +-- PROCESSES ------------------------------------------------------------------- +charFiller :: GUIContext -> Process String () +charFiller GUICtx{guiResults = GUIRes{resValue = txtValue, + resErrors= varErrors}, + guiChrVar = chv} = + forever $ do + t <- recv + liftIO $ do + txt <- catch (eval t) $ \(ErrorCall desc) -> + varUpdate varErrors (++ [GUIBtm desc t]) >> + return bottomChar + tryPutMVar chv $ Just txt + where eval t = t `seq` length t `seq` return t + +valueFiller :: GUIContext -> Process (String, IO ()) () +valueFiller guiCtx@GUICtx{guiResults = GUIRes{resButton = btnInterpret, + resErrors = varErrors, + resValue = txtValue}} = + forever $ do + liftDebugIO "Waiting for a new value to interpret" + (val, poc) <- recv + liftDebugIO "Value received in valueFiller" + liftDebugIO "Trying to evaluate the whole value first..." + liftIO $ do + set txtValue [text := ""] + res <- valueFill guiCtx val + if res == bottomChar + then do + debugIO "didn't work... going char by char..." + varSet varErrors [] + valueFiller' guiCtx val + else do + debugIO "It worked!!" + textCtrlAppendText txtValue res + set btnInterpret [on command := poc, + text := "Interpret"] + set txtValue [enabled := True, + bgcolor := white] + +valueFiller' :: GUIContext -> String -> IO () +valueFiller' guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue, + resErrors = varErrors}} val = + do + h <- try (case val of + [] -> return [] + (c:_) -> return [c]) + case h of + Left (ErrorCall desc) -> + do + varUpdate varErrors (++ [GUIBtm desc val]) + textCtrlAppendText txtValue bottomString + Right [] -> + return () + Right t -> + do + valueFill guiCtx t >>= textCtrlAppendText txtValue + valueFiller' guiCtx $ tail val + +valueFill :: GUIContext -> String -> IO String +valueFill GUICtx{guiResults = GUIRes{resErrors = varErrors}, + guiCharTimer = charTimer, + guiChrVar = chv, + guiChrFiller = chfv} val = + do + debugIO "valueFill starting..." + tryTakeMVar chv --NOTE: empty the var + debugIO "timer starting..." + timerStart charTimer charTimeout True + debugIO "sending msg to charFiller..." + readMVar chfv >>= flip sendTo val + debugIO "waiting for value toAdd..." + toAdd <- readMVar chv --NOTE: Not using "take" to be sure that noone touches it + debugIO ("Ready to add...", toAdd) + case toAdd of + Just txt -> + do + isR <- timerIsRuning charTimer + if isR then timerStop charTimer else return () + debugIO $ "returning " ++ txt + return txt + Nothing -> --NOTE: Means "Timed Out" + do + varUpdate varErrors (++ [GUIBtm "Timed Out" val]) + debugIO $ "timed out" + return bottomChar + -- EVENT HANDLERS -------------------------------------------------------------- refreshPage, savePageAs, savePage, openPage, pageChange, copy, copyResult, copyType, cut, paste, justFind, justFindNext, justFindPrev, findReplace, textContextMenu, moduleContextMenu, valueContextMenu, - restartTimer, killTimer, interpret, hayoo, explain, + restartTimer, interpret, hayoo, explain, loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () @@ -703,24 +815,33 @@ resButton = btnInterpret, resValue = txtValue, res4Dots = lbl4Dots, - resType = txtType, - resErrors = varErrors}, - guiCode = txtCode, guiWin = win} = + resType = txtType}, + guiCode = txtCode, + guiCharTimer = charTimer, + guiWin = win, + guiChrVar = chv, + guiValFiller = vfv, + guiChrFiller = chfv} = do sel <- textCtrlGetStringSelection txtCode let runner = case sel of "" -> tryIn sl -> runTxtHPSelection sl refreshExpr model guiCtx + liftTraceIO "running..." + set txtValue [enabled := False, + bgcolor := lightgrey] res <- runner model HP.interpret + liftTraceIO "ready" case res of Left err -> - do - warningDialog win "Error" err + warningDialog win "Error" err Right interp -> if HP.isIntType interp then do - set txtValue [text := HP.intKind interp] + set txtValue [enabled := True, + bgcolor := white, + text := HP.intKind interp] set lbl4Dots [visible := False] set txtType [visible := False] set lblInterpret [text := "Kind:"] @@ -729,63 +850,25 @@ set txtType [visible := True, text := HP.intType interp] set lblInterpret [text := "Value:"] -- now we fill the textbox -- - varSet varErrors [] - set txtValue [text := ""] - spawn . valueFiller $ HP.intValue interp - return () - where valueFiller :: String -> Process a () - valueFiller val = - do - prevOnCmd <- liftIO $ get btnInterpret $ on command - myself <- self - let revert = set btnInterpret [on command := prevOnCmd, - text := "Interpret"] - liftIO $ set btnInterpret [text := "Cancel", - on command := do - spawn $ liftIO revert >> kill myself - return ()] - h <- liftIO $ try (case val of - [] -> return [] - (c:_) -> return [c]) - case h of - Left (ErrorCall desc) -> - liftIO $ do - varUpdate varErrors (++ [GUIBtm desc val]) - addText bottomString - revert - Right [] -> - liftIO revert - Right t -> - do - ready <- liftIO newEmptyMVar - cfh <- liftIO . spawn $ charFiller t ready - let killCmd = - do - stillRunning <- isEmptyMVar ready - if stillRunning - then do - kill cfh - varUpdate varErrors (++ [GUIBtm "Timed Out" t]) - addText bottomChar - tryPutMVar ready () - return () - else - return () - timeKiller <- liftIO $ timer win [interval := charTimeout, - on command := killCmd] - liftIO $ readMVar ready - liftIO $ timerOnCommand timeKiller $ return () - valueFiller $ tail val - charFiller :: String -> MVar () -> Process a () - charFiller t r = liftIO $ do - catch (addText t) $ \(ErrorCall desc) -> - varUpdate varErrors (++ [GUIBtm desc t]) >> - addText bottomChar - putMVar r () - addText t = do - orig <- get txtValue text - set txtValue [text := orig ++ t] - + poc <- liftIO $ get btnInterpret $ on command + let revert = do + debugIO "Cancelling..." + tryTakeMVar chv --NOTE: empty the var + debugIO "Killing the char filler..." + newchf <- spawn $ charFiller guiCtx + swapMVar chfv newchf >>= kill + debugIO "Killing the value filler..." + newvf <- spawn $ valueFiller guiCtx + swapMVar vfv newvf >>= kill + debugIO "Ready" + set txtValue [enabled := True, + bgcolor := white] + set btnInterpret [on command := poc, text := "Interpret"] + in liftIO $ set btnInterpret [text := "Cancel", + on command := revert] + liftDebugIO "sending the value to the Value Filler..." + readMVar vfv >>= flip sendTo ((HP.intValue interp), poc) + runTxtHPSelection :: String -> HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError HP.Interpretation) -> IO (Either ErrorString HP.Interpretation) runTxtHPSelection s model hpacc = @@ -807,7 +890,8 @@ refreshExpr :: HPS.ServerHandle -> GUIContext -> IO () refreshExpr model guiCtx@GUICtx{guiCode = txtCode, - guiWin = win} = + guiWin = win, + guiTimer = refreshTimer} = do txt <- get txtCode text ip <- textCtrlGetInsertionPoint txtCode @@ -820,23 +904,16 @@ Right _ -> debugIO "refreshExpr done" - killTimer model guiCtx + timerStop refreshTimer -- TIMER HANDLERS -------------------------------------------------------------- -restartTimer model guiCtx@GUICtx{guiWin = win, guiTimer = varTimer} = - do - newRefreshTimer <- timer win [interval := 1000, - on command := refreshExpr model guiCtx] - refreshTimer <- varSwap varTimer newRefreshTimer - timerOnCommand refreshTimer $ return () - -killTimer _model GUICtx{guiWin = win, guiTimer = varTimer} = +restartTimer model guiCtx@GUICtx{guiWin = win, guiTimer = refreshTimer} = do - -- kill the timer till there's new notices - newRefreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"] - refreshTimer <- varSwap varTimer newRefreshTimer - timerOnCommand refreshTimer $ return () + started <- timerStart refreshTimer 1000 True + if started + then return () + else fail "Could not start more timers" -- INTERNAL UTILS -------------------------------------------------------------- type ErrorString = String diff --git a/src/HPage/GUI/IDs.hs b/src/HPage/GUI/IDs.hs --- a/src/HPage/GUI/IDs.hs +++ b/src/HPage/GUI/IDs.hs @@ -7,15 +7,13 @@ wxId_CANCEL = 5101 wxId_BACKWARD, wxId_CLOSE, wxId_COPY, wxId_CUT, wxId_FIND, wxId_FORWARD, - wxId_HELP, wxId_NEW, wxId_OPEN, wxId_PASTE, wxId_REDO, wxId_SAVE, - wxId_SAVEAS, wxId_UNDO :: Int + wxId_HELP, wxId_NEW, wxId_OPEN, wxId_PASTE, wxId_SAVE, + wxId_SAVEAS :: Int wxId_OPEN = 5000 wxId_CLOSE = 5001 wxId_NEW = 5002 wxId_SAVE = 5003 wxId_SAVEAS = 5004 -wxId_UNDO = 5007 -wxId_REDO = 5008 wxId_HELP = 5009 wxId_CUT = 5031 wxId_COPY = 5032 @@ -23,6 +21,10 @@ wxId_FIND = 5035 wxId_FORWARD = 5106 wxId_BACKWARD = 5107 + +wxId_REDO, wxId_UNDO :: Int +wxId_UNDO = 5207 +wxId_REDO = 5208 wxId_REPLACE, wxId_REPLACE_ALL, wxId_PREFERENCES, wxId_CLOSE_ALL :: Int diff --git a/src/HPage/Utils/Log.hs b/src/HPage/Utils/Log.hs --- a/src/HPage/Utils/Log.hs +++ b/src/HPage/Utils/Log.hs @@ -2,12 +2,14 @@ module HPage.Utils.Log where import Control.Monad.Trans +import Data.Time() +import Data.Time.Clock data LogLevel = Trace | Debug | Info | Warning | Error | Fatal deriving (Show, Eq) logIO :: Show a => LogLevel -> a -> IO () -logIO lvl msg = putStrLn $ (show lvl) ++ ": " ++ (show msg) +logIO lvl msg = getCurrentTime >>= \ts -> putStrLn $ (show ts) ++ " (" ++ (show lvl) ++ "): " ++ (show msg) liftLogIO :: (MonadIO m, Show a) => LogLevel -> a -> m () liftLogIO lvl = liftIO . (logIO lvl) @@ -29,7 +31,7 @@ {- with log... liftTraceIO = liftLogIO Trace -} -liftTraceIO _ = return () +liftTraceIO _ = return () liftDebugIO = liftLogIO Debug liftInfoIO = liftLogIO Info liftWarnIO = liftLogIO Warning diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,3 @@ - module Main where import Graphics.UI.WX