diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.4.7 +version: 0.4.8 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -42,10 +42,10 @@ wxcore >=0.11.1, wxcore < 0.12, wx >=0.11.1, wx < 0.12, filepath >=1.1.0, filepath < 1.2, - Cabal >= 1.6, Cabal < 1.7, + Cabal >= 1.6, Cabal < 1.7, hint >= 0.3.2, hint < 0.4, - eprocess >= 1.0.0, eprocess < 2, - hint-server >= 1.0.0, hint-server < 2 + eprocess >= 1.1.0, eprocess < 2, + hint-server >= 1.1.0, hint-server < 2 main-is: Main.hs buildable: True hs-source-dirs: src diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -81,7 +81,8 @@ import Distribution.ModuleName import Distribution.Compiler -data Interpretation = Type {intKind :: String} | Expr {intValue :: String, intType :: String} +data Interpretation = Type {intKind :: String} | + Expr {intValue :: String, intType :: String} deriving (Eq, Show) isIntType :: Interpretation -> Bool @@ -441,9 +442,17 @@ do valueRes <- valueOfNth i case valueRes of - Left verr -> return $ Left verr + Left verr -> + let verrStr = show verr + in if isNotShowable verr + then return $ Right $ Expr{intValue = "", intType = t} + else return $ Left verr Right v -> return $ Right $ Expr{intValue = v, intType = t} - + where isNotShowable (Hint.WontCompile ghcerrs) = any complainsAboutShow ghcerrs + isNotShowable _ = False + complainsAboutShow err = let errMsg = Hint.errMsg err + in "No instance for (GHC.Show" `isPrefixOf` errMsg + valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String) valueOfNth = runInExprNthWithLets Hint.eval kindOfNth = runInExprNth Hint.kindOf @@ -703,7 +712,7 @@ running = Nothing}) prettyPrintError :: Hint.InterpreterError -> String -prettyPrintError (Hint.WontCompile ghcerr) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerr) +prettyPrintError (Hint.WontCompile ghcerrs) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerrs) prettyPrintError (Hint.UnknownError errStr) = "Unknown Error: " ++ errStr prettyPrintError (Hint.NotAllowed errStr) = "Not Allowed Action: " ++ errStr prettyPrintError (Hint.GhcException errStr) = errStr 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 @@ -7,12 +7,12 @@ module HPage.GUI.FreeTextWindow ( gui ) where --- import Control.Concurrent.Process -import Foreign.Ptr -import Foreign.Storable +import Prelude hiding (catch) +import Control.Exception +import Control.Concurrent.Process import System.FilePath import System.Directory -import System.IO.Error hiding (try) +import System.IO.Error hiding (try, catch) import Data.List import Data.Bits import Data.Char (toLower) @@ -21,11 +21,11 @@ import Control.Monad.Error import Control.Monad.Loops import Graphics.UI.WX -import Graphics.UI.WXCore +import Graphics.UI.WXCore hiding (kill, Process) import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Dialogs import Graphics.UI.WXCore.Events -import Graphics.UI.WXCore.WxcClasses +--import Graphics.UI.WXCore.WxcClasses hiding (Process, kill) import qualified HPage.Control as HP import qualified HPage.Server as HPS import HPage.GUI.Dialogs @@ -46,13 +46,11 @@ helpFile :: IO FilePath helpFile = getDataFileName "res/help/helpPage.hs" -data GUIResults = GUIRes { resPanel :: Panel (), - resButton :: Button (), +data GUIResults = GUIRes { resButton :: Button (), resLabel :: StaticText (), resValue :: TextCtrl (), res4Dots :: StaticText (), - resType :: TextCtrl (), - resKind :: TextCtrl () } + resType :: TextCtrl () } data GUIContext = GUICtx { guiWin :: Frame (), guiPages :: SingleListBox (), @@ -93,14 +91,13 @@ varModsSel <- varCreate $ -1 lstModules <- listCtrlEx pnlMs (wxLC_REPORT + wxLC_ALIGN_LEFT + wxLC_NO_HEADER + wxLC_SINGLE_SEL) [columns := [("Module", AlignLeft, 200), - ("Origin", AlignLeft, 0)]] + ("Origin", AlignLeft, 1)]] listCtrlSetImageList lstModules images wxIMAGE_LIST_SMALL -- Results panel pnlRes <- panel win [] txtValue <- textEntry pnlRes [style := wxTE_READONLY] txtType <- textEntry pnlRes [style := wxTE_READONLY] - txtKind <- textEntry pnlRes [style := wxTE_READONLY, visible := False] btnInterpret <- button pnlRes [text := "Interpret"] lblInterpret <- staticText pnlRes [text := "Value:"] lbl4Dots <- staticText pnlRes [text := " :: "] @@ -122,7 +119,7 @@ -- Search ... search <- findReplaceDataCreate wxFR_DOWN - let guiRes = GUIRes pnlRes btnInterpret lblInterpret txtValue lbl4Dots txtType txtKind + let guiRes = GUIRes btnInterpret lblInterpret txtValue lbl4Dots txtType let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status varTimer search let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx @@ -240,13 +237,12 @@ toolBarSetToolBitmapSize tbMain $ sz 32 32 -- Layout settings - let txtCodeL = fill $ widget txtCode - pagesTabL = tab "Pages" $ container pnlPs $ fill $ margin 5 $ widget lstPages + let pagesTabL = tab "Pages" $ container pnlPs $ fill $ margin 5 $ widget lstPages modsTabL = tab "Modules" $ container pnlMs $ fill $ margin 5 $ widget lstModules leftL = tabs ntbkL [modsTabL, pagesTabL] resultsL = hfill $ boxed "Expression" $ fill $ widget pnlRes - rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsL] - set win [layout := fill $ row 10 [leftL, rightL], + rightL = minsize (sz 485 100) $ fill $ widget txtCode + set win [layout := column 5 [fill $ row 10 [leftL, rightL], resultsL], clientSize := sz 800 600] -- ...and RUN! @@ -601,13 +597,11 @@ Right () -> refreshPage model guiCtx -interpret model guiCtx@GUICtx{guiResults = GUIRes{resPanel = pnlRes, - resLabel = lblInterpret, +interpret model guiCtx@GUICtx{guiResults = GUIRes{resLabel = lblInterpret, resButton = btnInterpret, resValue = txtValue, res4Dots = lbl4Dots, - resType = txtType, - resKind = txtKind}, + resType = txtType}, guiCode = txtCode, guiWin = win} = do sel <- textCtrlGetStringSelection txtCode @@ -615,41 +609,58 @@ "" -> tryIn sl -> runTxtHPSelection sl refreshExpr model guiCtx False - set btnInterpret [enabled := False] res <- runner model HP.interpret case res of - Left err -> - do - warningDialog win "Error" err - set btnInterpret [enabled := True] - Right interp -> - if HP.isIntType interp - then do - set btnInterpret [enabled := True] - set txtValue [visible := False] - set lbl4Dots [visible := False] - set txtType [visible := False] - set txtKind [visible := True, text := HP.intKind interp] - set lblInterpret [text := "Kind:"] - set pnlRes [layout := fill $ centre $ - row 5 [widget btnInterpret, - centre $ widget lblInterpret, - hfill $ widget txtKind]] - repaint win - else do - set btnInterpret [enabled := True] - set txtValue [visible := True, text := HP.intValue interp] - set lbl4Dots [visible := True, text := " :: "] - set txtType [visible := True, text := HP.intType interp] - set txtKind [visible := False] - set lblInterpret [text := "Value:"] - set pnlRes [layout := fill $ - row 5 [widget btnInterpret, - centre $ widget lblInterpret, - hfill $ widget txtValue, - centre $ widget lbl4Dots, - hfill $ widget txtType]] - repaint win + Left err -> + do + warningDialog win "Error" err + set btnInterpret [enabled := True] + Right interp -> + if HP.isIntType interp + then do + set txtValue [text := HP.intKind interp] + set lbl4Dots [visible := False] + set txtType [visible := False] + set lblInterpret [text := "Kind:"] + else do + set lbl4Dots [visible := True] + set txtType [visible := True, text := HP.intType interp] + set lblInterpret [text := "Value:"] + -- now we fill the textbox -- + set txtValue [text := ""] + prevOnCmd <- get btnInterpret $ on command + prevText <- get btnInterpret text + let prevAttrs = [on command := prevOnCmd, + text := prevText] + debugIO "++> Spawning the value filler..." + vfHandle <- spawn . valueFiller $ HP.intValue interp + debugIO "++> Value filler spawned" + set btnInterpret [text := "Cancel", + on command := kill vfHandle >> set btnInterpret prevAttrs] + where valueFiller :: String -> Process a () + valueFiller val = + do + let bottomString = "_|_" + bottomChar = "_i_" + liftDebugIO "++> starting loop..." + h <- liftIO $ try (case val of + [] -> return [] + (c:_) -> return [c]) + --liftDebugIO ("++> h =", h) + case h of + Left (ErrorCall desc) -> + liftIO $ debugIO ("++> Left", desc) >> addText bottomString >> return () + Right [] -> + liftIO $ debugIO "++> done" >> return () + Right t -> + do + liftIO $ catch (addText t) $ \(ErrorCall _desc) -> addText bottomChar + liftDebugIO "++> restarting" + valueFiller $ tail val + addText t = do + debugIO ("Adding", t) + orig <- get txtValue text + set txtValue [text := orig ++ t] runTxtHPSelection :: String -> HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError HP.Interpretation) -> IO (Either ErrorString HP.Interpretation) @@ -673,8 +684,7 @@ refreshExpr :: HPS.ServerHandle -> GUIContext -> Bool -> IO () refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue, - resType = txtType, - resKind = txtKind}, + resType = txtType}, guiCode = txtCode, guiWin = win} forceClear = do @@ -688,7 +698,7 @@ warningDialog win "Error" err Right changed -> if changed || forceClear - then mapM_ (flip set [text := ""]) [txtValue, txtType, txtKind] + then mapM_ (flip set [text := ""]) [txtValue, txtType] else debugIO "dummy refreshExpr" killTimer model guiCtx diff --git a/src/HPage/Server.hs b/src/HPage/Server.hs --- a/src/HPage/Server.hs +++ b/src/HPage/Server.hs @@ -5,35 +5,20 @@ import Control.Monad import Control.Monad.Trans -import Control.Monad.Loops import Control.Concurrent.Process import HPage.Control -import HPage.Utils.Log -newtype ServerHandle = SH {handle :: Handle (Either Stop (HPage ()))} - -data Stop = Stop +newtype ServerHandle = SH {handle :: Handle (HPage ())} start :: IO ServerHandle start = (spawn $ makeProcess evalHPage pageRunner) >>= return . SH - where pageRunner = iterateWhile id $ do - liftTraceIO "hps iterating..." - v <- recv - case v of - Left Stop -> - do - liftTraceIO "hps stop" - return False - Right acc -> - do - liftTraceIO "hps continue" - lift acc >> return True + where pageRunner = forever $ recv >>= lift runIn :: ServerHandle -> HPage a -> IO a runIn server action = runHere $ do me <- self - sendTo (handle server) $ Right $ action >>= sendTo me + sendTo (handle server) $ action >>= sendTo me recv stop :: ServerHandle -> IO () -stop server = sendTo (handle server) $ Left Stop +stop = kill . handle