diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.4.2 +version: 0.4.3 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -11,7 +11,7 @@ package-url: http://code.haskell.org/hpage bug-reports: http://github.com/elbrujohalcon/hPage/issues synopsis: A scrapbook for Haskell developers -description: hPage is targeted at those haskell developers which also like to work with dynamic GUIs and wish to have something like Smalltalk's Workspace or jPage for Java. Using hPage developers can write haskell expressions, evaluate and test them, load, unload and (of course) reload modules and then, re-evaluate the same expressions (ghci anyone?). Developed over wxWidgets, hPage is multi-platform by nature and works in every scenario where ghc and wxWidgets work. +description: λPage is targeted at those haskell developers which also like to work with dynamic GUIs and wish to have something like Smalltalk's Workspace or jPage for Java. Using λPage developers can write haskell expressions, evaluate and test them, load, unload and (of course) reload modules and then, re-evaluate the same expressions. Developed over wxWidgets, λPage is multi-platform by nature and works in every scenario where ghc and wxWidgets work. category: Development, IDE, Editor author: Fernando "Brujo" Benavides tested-with: GHC ==6.10.3, GHC ==6.10.4 @@ -42,7 +42,7 @@ wx >=0.11.1, wx < 0.12, filepath >=1.1.0, filepath < 1.2, Cabal >= 1.6, Cabal < 1.7, - hint >=0.3.1, hint < 0.4, + hint >= 0.3.2, hint < 0.4, eprocess >= 1.0.0, eprocess < 2, hint-server >= 1.0.0, hint-server < 2 main-is: Main.hs diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -39,7 +39,6 @@ getSourceDirs, setSourceDirs, getGhcOpts, setGhcOpts, loadPackage, - valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', loadModules', reloadModules', getLoadedModules', importModules', getImportedModules', getModuleExports', @@ -466,7 +465,7 @@ confirmRunning syncRun $ do mns <- Hint.getLoadedModules - let mis = map (>0) [1..] + mis <- mapM Hint.isModuleInterpreted mns return $ zipWith ModDesc mns mis getImportedModules :: HPage [Hint.ModuleName] @@ -577,16 +576,6 @@ liftErrorIO $ ("Error resetting", e) return res -valueOf', kindOf', typeOf' :: HPage (MVar (Either Hint.InterpreterError String)) -valueOf' = getPage >>= valueOfNth' . currentExpr -kindOf' = getPage >>= kindOfNth' . currentExpr -typeOf' = getPage >>= typeOfNth' . currentExpr - -valueOfNth', kindOfNth', typeOfNth' :: Int -> HPage (MVar (Either Hint.InterpreterError String)) -valueOfNth' = runInExprNthWithLets' Hint.eval -kindOfNth' = runInExprNth' Hint.kindOf -typeOfNth' = runInExprNthWithLets' Hint.typeOf - loadModules' :: [String] -> HPage (MVar (Either Hint.InterpreterError ())) loadModules' ms = do let action = do @@ -622,7 +611,7 @@ confirmRunning asyncRun $ do mns <- Hint.getLoadedModules - let mis = map (>0) [1..] + mis <- mapM Hint.isModuleInterpreted mns return $ zipWith ModDesc mns mis getImportedModules' :: HPage (MVar [Hint.ModuleName]) @@ -731,16 +720,6 @@ then return "" else action expr -runInExprNth' :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (MVar (Either Hint.InterpreterError String)) -runInExprNth' action i = do - page <- getPage - let exprs = expressions page - flip (withIndex i) exprs $ do - let expr = exprText $ exprs !! i - asyncRun $ if "" == expr - then return "" - else action expr - runInExprNthWithLets :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String) runInExprNthWithLets action i = do page <- getPage @@ -751,15 +730,6 @@ in syncRun $ if "" == exprText item then return "" else action expr - -runInExprNthWithLets' :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (MVar (Either Hint.InterpreterError String)) -runInExprNthWithLets' action i = do - page <- getPage - let exprs = expressions page - flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs - lets = filter isNamedExpr $ b ++ a - expr = letsToString lets ++ exprText item - in asyncRun $ action expr syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a) syncRun action = do 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,8 +7,6 @@ module HPage.GUI.FreeTextWindow ( gui ) where -import Control.Concurrent.Process -import Control.Concurrent.MVar import System.FilePath import System.Directory import System.IO.Error hiding (try) @@ -359,13 +357,13 @@ objectDelete contextMenu getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} = - runTxtHP HP.valueOf' model guiCtx grrValue + runTxtHP HP.valueOf model guiCtx grrValue getType model guiCtx@GUICtx{guiResults = GUIRes{resType = grrType}} = - runTxtHP HP.typeOf' model guiCtx grrType + runTxtHP HP.typeOf model guiCtx grrType getKind model guiCtx@GUICtx{guiResults = GUIRes{resKind = grrKind}} = - runTxtHP HP.kindOf' model guiCtx grrKind + runTxtHP HP.kindOf model guiCtx grrKind pageChange model guiCtx@GUICtx{guiPages = lstPages} = do @@ -616,9 +614,9 @@ Right () -> refreshPage model guiCtx -runTxtHP, runTxtHPPointer :: HP.HPage (MVar (Either HP.InterpreterError String)) -> +runTxtHP, runTxtHPPointer :: HP.HPage (Either HP.InterpreterError String) -> HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO () -runTxtHPSelection :: String -> HP.HPage (MVar (Either HP.InterpreterError String)) -> +runTxtHPSelection :: String -> HP.HPage (Either HP.InterpreterError String) -> HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO () runTxtHP hpacc model guiCtx@GUICtx{guiCode = txtCode} guiRow = do @@ -636,47 +634,21 @@ refreshExpr model guiCtx False debugIO ("evaluating selection", s) piRes <- tryIn' model HP.getPageIndex - let cpi = case piRes of - Left err -> 0 - Right cp -> cp - newacc = do - HP.addPage - HP.setPageText s $ length s - hpacc - res <- tryIn' model newacc - tryIn' model $ HP.closePage >> HP.setPageIndex cpi - case res of - Left err -> warningDialog win "Error" err - Right var -> do - cancelled <- varCreate False - prevOnCmd <- get btn $ on command - prevText <- get btn text - let prevAttrs = [text := prevText, - on command := prevOnCmd] - revert = do - varSet cancelled True - tryIn' model HP.cancel - set txtBox [enabled := True] - set btn prevAttrs - set status [text := "cancelled"] - set btn [text := "Cancel", on command := revert] - set txtBox [enabled := False] - set status [text := "processing..."] - spawn . liftIO $ do - val <- readMVar var - wasCancelled <- varGet cancelled - if wasCancelled - then - return () - else - do - set status [text := "ready"] - case val of - Left err -> warningDialog win "Error" $ HP.prettyPrintError err - Right txt -> set txtBox [text := txt] - set txtBox [enabled := True] - set btn prevAttrs - return () + added <- tryIn' model $ HP.addPage + case added of + Left err -> + warningDialog win "Error" err + Right _ -> + do + let cpi = case piRes of + Left err -> 0 + Right cp -> cp + newacc = HP.setPageText s (length s) >> hpacc + res <- tryIn model newacc + tryIn' model $ HP.closePage >> HP.setPageIndex cpi + case res of + Left err -> warningDialog win "Error" err + Right val -> set txtBox [text := val] runTxtHPPointer hpacc model guiCtx@GUICtx{guiWin = win, guiStatus = status} @@ -684,39 +656,10 @@ grrText = txtBox} = do refreshExpr model guiCtx False - res <- tryIn' model hpacc + res <- tryIn model hpacc case res of Left err -> warningDialog win "Error" err - Right var -> do - cancelled <- varCreate False - prevOnCmd <- get btn $ on command - prevText <- get btn text - let prevAttrs = [text := prevText, - on command := prevOnCmd] - revert = do - varSet cancelled True - tryIn' model HP.cancel - set txtBox [enabled := True] - set btn prevAttrs - set status [text := "cancelled"] - set btn [text := "Cancel", on command := revert] - set txtBox [enabled := False] - set status [text := "processing..."] - spawn . liftIO $ do - val <- readMVar var - wasCancelled <- varGet cancelled - if wasCancelled - then - return () - else - do - set status [text := "ready"] - case val of - Left err -> warningDialog win "Error" $ HP.prettyPrintError err - Right txt -> set txtBox [text := txt] - set txtBox [enabled := True] - set btn prevAttrs - return () + Right val -> set txtBox [text := val] refreshExpr :: HPS.ServerHandle -> GUIContext -> Bool -> IO () refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue, diff --git a/src/HPage/Test/Server.hs b/src/HPage/Test/Server.hs --- a/src/HPage/Test/Server.hs +++ b/src/HPage/Test/Server.hs @@ -225,6 +225,7 @@ where match ((HP.MEFun fn _), (Hint.Fun fn2)) = fn == fn2 match ((HP.MEClass cn cfs), (Hint.Class cn2 cfs2)) = cn == cn2 && all match (zip cfs (map Hint.Fun cfs2)) match ((HP.MEData dn dcs), (Hint.Data dn2 dcs2)) = dn == dn2 && all match (zip dcs (map Hint.Fun dcs2)) + match _ = False prop_load_module :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Property prop_load_module hps hs mn =