hpage 0.5.5 → 0.5.6
raw patch · 7 files changed
+185/−104 lines, 7 filesdep +timesetup-changed
Dependencies added: time
Files
- Setup.hs +1/−1
- hpage.cabal +4/−3
- src/HPage/GUI/Constants.hs +1/−1
- src/HPage/GUI/FreeTextWindow.hs +169/−92
- src/HPage/GUI/IDs.hs +6/−4
- src/HPage/Utils/Log.hs +4/−2
- src/Main.hs +0/−1
Setup.hs view
@@ -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 ()
hpage.cabal view
@@ -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
src/HPage/GUI/Constants.hs view
@@ -5,4 +5,4 @@ bottomChar = "\724" charTimeout :: Int-charTimeout = 1000+charTimeout = 2000
src/HPage/GUI/FreeTextWindow.hs view
@@ -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
src/HPage/GUI/IDs.hs view
@@ -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
src/HPage/Utils/Log.hs view
@@ -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
src/Main.hs view
@@ -1,4 +1,3 @@- module Main where import Graphics.UI.WX