hpage 0.6.0 → 0.6.1
raw patch · 2 files changed
+47/−14 lines, 2 files
Files
- hpage.cabal +1/−1
- src/HPage/GUI/FreeTextWindow.hs +46/−13
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.6.0+version: 0.6.1 cabal-version: >=1.6 build-type: Custom license: BSD3
src/HPage/GUI/FreeTextWindow.hs view
@@ -286,6 +286,12 @@ -- test the server... runTxtHPSelection "1" model HP.interpret + --HACK: We need to keep a timer ticking just to refresh the screen when the user is doing nothing+ -- That's because the main C loop of wx only calls wxHaskell callbacks when something happens+ -- and we try to make things happen in this side but they're not reflected there until some-+ -- thing happens there+ timer win [interval := 50, on command := return ()]+ -- ...and RUN! refreshPage model guiCtx onCmd "start" openHelpPage@@ -297,20 +303,23 @@ charFiller :: GUIContext -> Process String () charFiller GUICtx{guiResults = GUIRes{resValue = txtValue, resErrors= varErrors},- guiChrVar = chv} =+ guiChrVar = chv,+ guiStatus = status} = forever $ do t <- recv liftIO $ do txt <- catch (eval t) $ \(ErrorCall desc) -> varUpdate varErrors (++ [GUIBtm desc t]) >> return bottomChar+ debugIO $ "Writing chv := " ++ txt 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}} =+ resValue = txtValue},+ guiStatus = status} = forever $ do liftDebugIO "Waiting for a new value to interpret" (val, poc) <- recv@@ -318,21 +327,37 @@ liftDebugIO "Trying to evaluate the whole value first..." liftIO $ do set txtValue [text := ""]+ varSet varErrors [] res <- valueFill guiCtx val if res == bottomChar then do debugIO "didn't work... going char by char..." varSet varErrors []- valueFiller' guiCtx val+ statusText <- valueFiller' guiCtx val+ errs <- varGet varErrors+ case (statusText, errs) of+ ("", []) ->+ set status [text := ""] >>+ set txtValue [enabled := True,+ bgcolor := white]+ ("", _) ->+ set status [text := "Expression interpreted with errors: Check them by right-clicking on each one"] >>+ set txtValue [enabled := True,+ bgcolor := yellow]+ (msg, _) ->+ set status [text := "Expression interpreted with errors: " ++ msg] >>+ set txtValue [enabled := True,+ bgcolor := yellow] else do debugIO "It worked!!" textCtrlAppendText txtValue res+ set status [text := ""]+ set txtValue [enabled := True,+ bgcolor := white] set btnInterpret [on command := poc, text := "Interpret"]- set txtValue [enabled := True,- bgcolor := white] -valueFiller' :: GUIContext -> String -> IO ()+valueFiller' :: GUIContext -> String -> IO String valueFiller' guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue, resErrors = varErrors}} val = do@@ -341,11 +366,9 @@ (c:_) -> return [c]) case h of Left (ErrorCall desc) ->- do- varUpdate varErrors (++ [GUIBtm desc val])- textCtrlAppendText txtValue bottomString+ return desc Right [] ->- return ()+ return "" Right t -> do valueFill guiCtx t >>= textCtrlAppendText txtValue@@ -834,13 +857,15 @@ resButton = btnInterpret, resValue = txtValue, res4Dots = lbl4Dots,- resType = txtType},+ resType = txtType,+ resErrors = varErrors}, guiCode = txtCode, guiCharTimer = charTimer, guiWin = win, guiChrVar = chv, guiValFiller = vfv,- guiChrFiller = chfv} =+ guiChrFiller = chfv,+ guiStatus = status} = do sel <- textCtrlGetStringSelection txtCode let runner = case sel of@@ -848,6 +873,7 @@ sl -> runTxtHPSelection sl refreshExpr model guiCtx liftTraceIO "running..."+ set status [text := "interpreting..."] set txtValue [enabled := False, bgcolor := lightgrey] res <- runner model HP.interpret@@ -858,6 +884,7 @@ Right interp -> if HP.isIntType interp then do+ set status [text := ""] set txtValue [enabled := True, bgcolor := white, text := HP.intKind interp]@@ -880,8 +907,14 @@ newvf <- spawn $ valueFiller guiCtx swapMVar vfv newvf >>= kill debugIO "Ready"+ errs <- varGet varErrors+ set status [text := case errs of+ [] -> ""+ _ -> "Expression interpreted with errors: Check them by right-clicking on each one"] set txtValue [enabled := True,- bgcolor := white]+ bgcolor := case errs of+ [] -> white+ _ -> yellow] set btnInterpret [on command := poc, text := "Interpret"] in liftIO $ set btnInterpret [text := "Cancel", on command := revert]