From 6c404483bc74c80c4810f26d32c980352f3bfae3 Mon Sep 17 00:00:00 2001 From: Andrew Gibiansky Date: Sun, 22 Dec 2013 01:05:02 -0500 Subject: [PATCH] Capture intermediate results and display them --- Haskell-Notebook.ipynb | 271 +++++++++++++++++++++++++----------- Hspec.hs | 2 +- IHaskell.cabal | 3 + IHaskell/Eval/Completion.hs | 30 ++-- IHaskell/Eval/Evaluate.hs | 217 +++++++++++++++++++++-------- IHaskell/Eval/Info.hs | 2 - IHaskell/Message/Writer.hs | 4 + IHaskell/Types.hs | 24 ++-- Main.hs | 40 +++++- 9 files changed, 408 insertions(+), 185 deletions(-) diff --git a/Haskell-Notebook.ipynb b/Haskell-Notebook.ipynb index f4d609da..ccbdfb58 100644 --- a/Haskell-Notebook.ipynb +++ b/Haskell-Notebook.ipynb @@ -12,7 +12,7 @@ "cell_type": "code", "collapsed": false, "input": [ - "data Value = X Int\n", + "data X = X Int\n", " | Y String\n", " | Z Float\n", " deriving Show\n", @@ -95,12 +95,20 @@ "cell_type": "code", "collapsed": false, "input": [ - "import Prel" + "1" ], "language": "python", "metadata": {}, - "outputs": [], - "prompt_number": 1 + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "1" + ] + } + ], + "prompt_number": 4 }, { "cell_type": "code", @@ -111,7 +119,7 @@ "language": "python", "metadata": {}, "outputs": [], - "prompt_number": 1 + "prompt_number": 5 }, { "cell_type": "code", @@ -121,7 +129,20 @@ ], "language": "python", "metadata": {}, - "outputs": [], + "outputs": [ + { + "html": [ + "Not in scope: `ma'
Perhaps you meant one of these:
`map' (imported from Prelude), `max' (imported from Prelude)" + ], + "metadata": {}, + "output_type": "display_data", + "text": [ + "Not in scope: `ma'\n", + "Perhaps you meant one of these:\n", + " `map' (imported from Prelude), `max' (imported from Prelude)" + ] + } + ], "prompt_number": 6 }, { @@ -168,38 +189,30 @@ "outputs": [ { "html": [ - "No instance for (Show X)
arising from a use of `print'
Possible fix:
add an instance declaration for (Show X)" + "No instance for (Num String)
arising from the literal `3'
Possible fix:
add an instance declaration for (Num String)" ], "metadata": {}, "output_type": "display_data", "text": [ - "No instance for (GHC.Show.Show :Interactive.X)\n", - " arising from a use of `System.IO.print'\n", + "No instance for (GHC.Num.Num GHC.Base.String)\n", + " arising from the literal `3'\n", "Possible fix:\n", - " add an instance declaration for (GHC.Show.Show :Interactive.X)" + " add an instance declaration for (GHC.Num.Num GHC.Base.String)" ] } ], - "prompt_number": 9 + "prompt_number": 2 }, { "cell_type": "code", "collapsed": false, "input": [ - "1+1" + "data X = Y Int" ], "language": "python", "metadata": {}, - "outputs": [ - { - "metadata": {}, - "output_type": "display_data", - "text": [ - "2" - ] - } - ], - "prompt_number": 10 + "outputs": [], + "prompt_number": 14 }, { "cell_type": "code", @@ -210,7 +223,7 @@ "language": "python", "metadata": {}, "outputs": [], - "prompt_number": 11 + "prompt_number": 18 }, { "cell_type": "code", @@ -222,14 +235,20 @@ "metadata": {}, "outputs": [ { + "html": [ + "No instance for (Num String)
arising from the literal `3'
Possible fix:
add an instance declaration for (Num String)" + ], "metadata": {}, "output_type": "display_data", "text": [ - "Y 3" + "No instance for (GHC.Num.Num GHC.Base.String)\n", + " arising from the literal `3'\n", + "Possible fix:\n", + " add an instance declaration for (GHC.Num.Num GHC.Base.String)" ] } ], - "prompt_number": 12 + "prompt_number": 19 }, { "cell_type": "code", @@ -240,7 +259,7 @@ "language": "python", "metadata": {}, "outputs": [], - "prompt_number": 13 + "prompt_number": 20 }, { "cell_type": "code", @@ -262,7 +281,7 @@ ] } ], - "prompt_number": 14 + "prompt_number": 21 }, { "cell_type": "code", @@ -284,7 +303,7 @@ ] } ], - "prompt_number": 15 + "prompt_number": 22 }, { "cell_type": "code", @@ -306,7 +325,7 @@ ] } ], - "prompt_number": 16 + "prompt_number": 23 }, { "cell_type": "code", @@ -317,7 +336,7 @@ "language": "python", "metadata": {}, "outputs": [], - "prompt_number": 17 + "prompt_number": 24 }, { "cell_type": "code", @@ -338,13 +357,13 @@ ] } ], - "prompt_number": 18 + "prompt_number": 25 }, { "cell_type": "code", "collapsed": false, "input": [ - "m" + ":extension OverloadedStrings" ], "language": "python", "metadata": {}, @@ -408,79 +427,39 @@ "collapsed": false, "input": [ "forM_ [100, 200, 300, 400, 500, 600, 700, 800] $ \\size -> do\n", - " let s = show size\n", - " img ! src \"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" ! width (toValue s)\n", - ":t y\n", - "y" + " let s = show size\n", + " unsafePerformIO $ do\n", + " threadDelay 100000\n", + " putStrLn $ \"Generating size: \" ++ s\n", + " return $ img ! src \"/static/base/images/ipynblogo.png\" ! width (toValue s)" ], "language": "python", "metadata": {}, "outputs": [ { "html": [ - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n" + "Not in scope: `unsafePerformIO'
Not in scope: `threadDelay'" ], "metadata": {}, "output_type": "display_data", "text": [ - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "" - ] - }, - { - "html": [ - "Not in scope: `y'" - ], - "metadata": {}, - "output_type": "display_data", - "text": [ - "Not in scope: `y'" + "Not in scope: `unsafePerformIO'\n", + "Not in scope: `threadDelay'" ] } ], - "prompt_number": 3 + "prompt_number": 4 }, { "cell_type": "code", "collapsed": false, "input": [ - "let y = forM (map (* 10) [1..40]) $ \\size -> do\n", - " let s = show size\n", - " Text.Blaze.Html4.Strict.div ! Text.Blaze.Html4.Strict.style \"bar\" $ \"Hello.\"\n", - " img ! src \"http://127.0.0.1:8800/static/base/images/ipynblogo.png\" ! width (toValue s)\n", - "y" + "import System.IO.Unsafe" ], "language": "python", "metadata": {}, - "outputs": [ - { - "html": [ - "Couldn't match type `Text.Blaze.Internal.MarkupM ()'
with `Text.Blaze.Internal.Attribute'
Expected type: Text.Blaze.Internal.Attribute
Actual type: Text.Blaze.Html.Html" - ], - "metadata": {}, - "output_type": "display_data", - "text": [ - "Couldn't match type `Text.Blaze.Internal.MarkupM ()'\n", - " with `Text.Blaze.Internal.Attribute'\n", - "Expected type: Text.Blaze.Internal.Attribute\n", - " Actual type: Text.Blaze.Html.Html" - ] - } - ], - "prompt_number": 25 + "outputs": [], + "prompt_number": 8 }, { "cell_type": "code", @@ -518,7 +497,7 @@ ] } ], - "prompt_number": 58 + "prompt_number": 8 }, { "cell_type": "code", @@ -575,6 +554,128 @@ ], "prompt_number": 61 }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "import Control.Concurrent\n", + "import Control.Monad\n", + "\n", + "forM_ [1..10] $ \\x -> do \n", + " print x\n", + " threadDelay 100000" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "1\n", + "2\n", + "3\n", + "4\n", + "5\n", + "6\n", + "7\n", + "8\n", + "9\n", + "10" + ] + } + ], + "prompt_number": 5 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "3" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "3" + ] + } + ], + "prompt_number": 6 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "data Thing = One Int | Two String deriving Show\n", + "One 3" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "html": [ + "No instance for (Show Thing)
arising from a use of `print'
Possible fix:
add an instance declaration for (Show Thing)" + ], + "metadata": {}, + "output_type": "display_data", + "text": [ + "No instance for (GHC.Show.Show :Interactive.Thing)\n", + " arising from a use of `System.IO.print'\n", + "Possible fix:\n", + " add an instance declaration for (GHC.Show.Show :Interactive.Thing)" + ] + } + ], + "prompt_number": 4 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "Two \"hello\"" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "Two \"hello\"" + ] + } + ], + "prompt_number": 5 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "One 3" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "html": [ + "No instance for (Show Thing)
arising from a use of `print'
Possible fix:
add an instance declaration for (Show Thing)" + ], + "metadata": {}, + "output_type": "display_data", + "text": [ + "No instance for (GHC.Show.Show :Interactive.Thing)\n", + " arising from a use of `System.IO.print'\n", + "Possible fix:\n", + " add an instance declaration for (GHC.Show.Show :Interactive.Thing)" + ] + } + ], + "prompt_number": 6 + }, { "cell_type": "code", "collapsed": false, diff --git a/Hspec.hs b/Hspec.hs index eb741815..c4a85653 100644 --- a/Hspec.hs +++ b/Hspec.hs @@ -29,7 +29,7 @@ is string blockType = do eval string = do outputAccum <- newIORef [] - let publish displayDatas = liftIO $ modifyIORef outputAccum (displayDatas :) + let publish _ displayDatas = modifyIORef outputAccum (displayDatas :) getTemporaryDirectory >>= setCurrentDirectory interpret $ evaluate 1 string publish out <- readIORef outputAccum diff --git a/IHaskell.cabal b/IHaskell.cabal index ba5547e4..f3be0a63 100644 --- a/IHaskell.cabal +++ b/IHaskell.cabal @@ -56,6 +56,7 @@ extra-source-files: library build-depends: base ==4.6.*, + unix >= 2.6, hspec, zeromq3-haskell ==0.5.*, aeson ==0.6.*, @@ -113,6 +114,7 @@ executable IHaskell -- Other library packages from which modules are imported. build-depends: base ==4.6.*, + unix >= 2.6, hspec, zeromq3-haskell ==0.5.*, aeson ==0.6.*, @@ -143,6 +145,7 @@ Test-Suite hspec Ghc-Options: -threaded Main-Is: Hspec.hs build-depends: base ==4.6.*, + unix >= 2.6, hspec, zeromq3-haskell ==0.5.*, aeson ==0.6.*, diff --git a/IHaskell/Eval/Completion.hs b/IHaskell/Eval/Completion.hs index 3c3dc1a6..f64ebc89 100644 --- a/IHaskell/Eval/Completion.hs +++ b/IHaskell/Eval/Completion.hs @@ -18,7 +18,7 @@ module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where import Prelude -import Data.List (find, isPrefixOf, nub, findIndex, intercalate) +import Data.List (find, isPrefixOf, nub, findIndex, intercalate, elemIndex) import GHC import GhcMonad import PackageConfig @@ -53,7 +53,7 @@ complete line pos = do let Just db = pkgDatabase flags getNames = map moduleNameString . exposedModules - moduleNames = nub $ concat $ map getNames db + moduleNames = nub $ concatMap getNames db let target = completionTarget line pos matchedText = intercalate "." target @@ -97,19 +97,17 @@ getTrueModuleName name = do completionType :: String -> [String] -> CompletionType completionType line [] = Empty -completionType line target = - if startswith "import" (strip line) && isModName - then ModuleName dotted candidate - else - if isModName && (not . null . init) target - then Qualified dotted candidate - else Identifier candidate - where - dotted = dots target - candidate = last target - dots = intercalate "." . init - isModName = all isCapitalized (init target) - isCapitalized = isUpper . head +completionType line target + | startswith "import" (strip line) && isModName = + ModuleName dotted candidate + | isModName && (not . null . init) target = + Qualified dotted candidate + | otherwise = Identifier candidate + where dotted = dots target + candidate = last target + dots = intercalate "." . init + isModName = all isCapitalized (init target) + isCapitalized = isUpper . head -- | Get the word under a given cursor location. @@ -132,7 +130,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] splitAlongCursor [] = [] splitAlongCursor (x:xs) = - case findIndex (== cursor) $ map snd x of + case elemIndex cursor $ map snd x of Nothing -> x:splitAlongCursor xs Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs diff --git a/IHaskell/Eval/Evaluate.hs b/IHaskell/Eval/Evaluate.hs index 471ab48c..77e94a7c 100644 --- a/IHaskell/Eval/Evaluate.hs +++ b/IHaskell/Eval/Evaluate.hs @@ -9,6 +9,7 @@ module IHaskell.Eval.Evaluate ( ) where import ClassyPrelude hiding (liftIO, hGetContents) +import Control.Concurrent (forkIO, threadDelay) import Prelude (putChar, head, tail, last, init, (!!)) import Data.List.Utils import Data.List(findIndex) @@ -19,9 +20,11 @@ import Data.Dynamic import Data.Typeable import qualified Data.Serialize as Serialize import System.Directory (removeFile, createDirectoryIfMissing, removeDirectoryRecursive) +import System.Posix.IO +import System.IO (hGetChar, hFlush) +import System.Random (getStdGen, randomRs) import NameSet -import DynFlags (defaultObjectTarget) import Name import PprTyThing import InteractiveEval @@ -63,31 +66,6 @@ typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes) fullPrefixes = map (++ ".") ignoreTypePrefixes useStringType = replace "[Char]" "String" -makeWrapperStmts :: (String, [String], [String]) -makeWrapperStmts = (fileName, initStmts, postStmts) - where - randStr = "1345964344725219474" :: String - fileVariable = "file_var_" ++ randStr - oldVariable = fileVariable ++ "_old" - itVariable = "it_var_" ++ randStr - fileName = ".ihaskell_capture" - - initStmts :: [String] - initStmts = [ - printf "let %s = it" itVariable, - printf "%s <- openFile \"%s\" WriteMode" fileVariable fileName, - printf "%s <- hDuplicate stdout" oldVariable, - printf "hDuplicateTo %s stdout" fileVariable, - printf "let it = %s" itVariable] - - postStmts :: [String] - postStmts = [ - printf "let %s = it" itVariable, - "hFlush stdout", - printf "hDuplicateTo %s stdout" oldVariable, - printf "hClose %s" fileVariable, - printf "let it = %s" itVariable] - write :: GhcMonad m => String -> m () write x = when debug $ liftIO $ hPutStrLn stderr x @@ -98,6 +76,8 @@ globalImports = [ "import IHaskell.Display" , "import Control.Applicative ((<$>))" , "import GHC.IO.Handle (hDuplicateTo, hDuplicate)" + , "import System.Posix.IO" + , "import System.Posix.Files" , "import System.IO" ] @@ -156,10 +136,14 @@ initializeItVariable = -- statements - if it doesn't exist, the first statement will fail. void $ runStmt "let it = ()" RunToCompletion +-- | Publisher for IHaskell outputs. The first argument indicates whether +-- this output is final (true) or intermediate (false). +type Publisher = (Bool -> [DisplayData] -> IO ()) + -- | Evaluate some IPython input code. -evaluate :: Int -- ^ The execution counter of this evaluation. - -> String -- ^ Haskell code or other interpreter commands. - -> ([DisplayData] -> Interpreter ()) -- ^ Function used to publish data outputs. +evaluate :: Int -- ^ The execution counter of this evaluation. + -> String -- ^ Haskell code or other interpreter commands. + -> Publisher -- ^ Function used to publish data outputs. -> Interpreter () evaluate execCount code output = do cmds <- parseString (strip code) @@ -168,8 +152,8 @@ evaluate execCount code output = do runUntilFailure :: [CodeBlock] -> Interpreter () runUntilFailure [] = return () runUntilFailure (cmd:rest) = do - (success, result) <- evalCommand cmd - unless (null result) $ output result + (success, result) <- evalCommand output cmd + unless (null result) $ liftIO $ output True result case success of Success -> runUntilFailure rest Failure -> return () @@ -185,8 +169,8 @@ wrapExecution exec = ghandle handler $ exec >>= \res -> -- | Return the display data for this command, as well as whether it -- resulted in an error. -evalCommand :: CodeBlock -> Interpreter (ErrorOccurred, [DisplayData]) -evalCommand (Import importStr) = wrapExecution $ do +evalCommand :: Publisher -> CodeBlock -> Interpreter (ErrorOccurred, [DisplayData]) +evalCommand _ (Import importStr) = wrapExecution $ do write $ "Import: " ++ importStr importDecl <- parseImportDecl importStr context <- getContext @@ -202,7 +186,7 @@ evalCommand (Import importStr) = wrapExecution $ do implicitImportOf _ (IIModule _) = False implicitImportOf imp (IIDecl decl) = ideclImplicit decl && ((==) `on` (unLoc . ideclName)) decl imp -evalCommand (Module contents) = wrapExecution $ do +evalCommand _ (Module contents) = wrapExecution $ do -- Write the module contents to a temporary file in our work directory namePieces <- getModuleName contents let directory = "./" ++ intercalate "/" (init namePieces) ++ "/" @@ -270,7 +254,7 @@ evalCommand (Module contents) = wrapExecution $ do Succeeded -> return [] Failed -> return $ displayError $ "Failed to load module " ++ modName -evalCommand (Directive SetExtension exts) = wrapExecution $ do +evalCommand _ (Directive SetExtension exts) = wrapExecution $ do results <- mapM setExtension (words exts) case catMaybes results of [] -> return [] @@ -304,14 +288,14 @@ evalCommand (Directive SetExtension exts) = wrapExecution $ do -- In that case, we disable the extension. flagMatchesNo ext (name, _, _) = ext == "No" ++ name -evalCommand (Directive GetType expr) = wrapExecution $ do +evalCommand _ (Directive GetType expr) = wrapExecution $ do result <- exprType expr flags <- getSessionDynFlags let typeStr = showSDocUnqual flags $ ppr result return [plain typeStr, html $ formatGetType typeStr] -- This is taken largely from GHCi's info section in InteractiveUI. -evalCommand (Directive HelpForSet _) = return (Success, [out]) +evalCommand _ (Directive HelpForSet _) = return (Success, [out]) where out = plain $ intercalate "\n" [":set is not implemented in IHaskell." ," Use :extension to enable a GHC extension." @@ -319,7 +303,7 @@ evalCommand (Directive HelpForSet _) = return (Success, [out]) ] -- This is taken largely from GHCi's info section in InteractiveUI. -evalCommand (Directive GetHelp _) = return (Success, [out]) +evalCommand _ (Directive GetHelp _) = return (Success, [out]) where out = plain $ intercalate "\n" ["The following commands are available:" ," :extension - enable a GHC extension." @@ -332,7 +316,7 @@ evalCommand (Directive GetHelp _) = return (Success, [out]) ] -- This is taken largely from GHCi's info section in InteractiveUI. -evalCommand (Directive GetInfo str) = wrapExecution $ do +evalCommand _ (Directive GetInfo str) = wrapExecution $ do -- Get all the info for all the names we're given. names <- parseName str maybeInfos <- mapM getInfo names @@ -363,10 +347,11 @@ evalCommand (Directive GetInfo str) = wrapExecution $ do let strings = map (showSDocForUser flags unqual) outs return [plain $ intercalate "\n" strings] -evalCommand (Statement stmt) = do +evalCommand output (Statement stmt) = do write $ "Statement: " ++ stmt ghandle handler $ do - (printed, result) <- capturedStatement stmt + let outputter str = output False [plain str] + (printed, result) <- capturedStatement outputter stmt case result of RunOk names -> do dflags <- getSessionDynFlags @@ -383,16 +368,12 @@ evalCommand (Statement stmt) = do handler exception = do write $ concat ["BreakCom: ", show exception, "\nfrom statement:\n", stmt] - -- Close the file handle we opened for writing stdout and other cleanup. - let (_, _, postStmts) = makeWrapperStmts - forM_ postStmts $ \s -> runStmt s RunToCompletion - return (Failure, displayError $ show exception) -evalCommand (Expression expr) = do +evalCommand output (Expression expr) = do -- Evaluate this expression as though it's just a statement. -- The output is bound to 'it', so we can then use it. - (success, out) <- evalCommand (Statement expr) + (success, out) <- evalCommand output (Statement expr) -- Try to use `display` to convert our type into the output -- DisplayData. If typechecking fails and there is no appropriate @@ -427,7 +408,7 @@ evalCommand (Expression expr) = do startswith "No instance for (GHC.Show.Show " msg && isInfixOf " arising from a use of `System.IO.print'" msg Nothing -> False - where isPlain (Display mime _) = (mime == PlainText) + where isPlain (Display mime _) = mime == PlainText useDisplay displayExpr = wrapExecution $ do -- If there are instance matches, convert the object into @@ -449,27 +430,143 @@ evalCommand (Expression expr) = do return displayData -evalCommand (Declaration decl) = wrapExecution $ runDecls decl >> return [] +evalCommand _ (Declaration decl) = wrapExecution $ runDecls decl >> return [] -evalCommand (ParseError loc err) = wrapExecution $ +evalCommand _ (ParseError loc err) = wrapExecution $ return $ displayError $ formatParseError loc err -capturedStatement :: String -> Interpreter (String, RunResult) -capturedStatement stmt = do +capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output. + -> String -- ^ Statement to evaluate. + -> Interpreter (String, RunResult) -- ^ Return the output and result. +capturedStatement output stmt = do -- Generate random variable names to use so that we cannot accidentally -- override the variables by using the right names in the terminal. - let (fileName, initStmts, postStmts) = makeWrapperStmts - goStmt s = runStmt s RunToCompletion + gen <- liftIO getStdGen + let + -- Variable names generation. + rand = take 20 $ randomRs ('0', '9') gen + var name = name ++ rand + + -- Variables for the pipe input and outputs. + readVariable = var "file_read_var_" + writeVariable = var "file_write_var_" + -- Variable where to store old stdout. + oldVariable = var "old_var_" + + -- Variable used to store true `it` value. + itVariable = var "it_var_" + + voidpf str = printf $ str ++ " >> return ()" + + -- Statements run before the thing we're evaluating. + initStmts = + [ printf "let %s = it" itVariable + , printf "(%s, %s) <- createPipe" readVariable writeVariable + , printf "%s <- dup stdOutput" oldVariable + , voidpf "dupTo %s stdOutput" writeVariable + , voidpf "hSetBuffering stdout NoBuffering" + , printf "let it = %s" itVariable + ] + + -- Statements run after evaluation. + postStmts = + [ printf "let %s = it" itVariable + , voidpf "hFlush stdout" + , voidpf "dupTo %s stdOutput" oldVariable + , voidpf "closeFd %s" writeVariable + , printf "let it = %s" itVariable + ] + + goStmt s = runStmt s RunToCompletion + + -- Initialize evaluation context. forM_ initStmts goStmt - result <- goStmt stmt - forM_ postStmts goStmt - -- We must use strict IO, because we write to that file again if we - -- execute more statements. If we read lazily, we may cause errors when - -- trying to open the file for writing later. - printedOutput <- liftIO $ StrictIO.readFile fileName + -- Get the pipe to read printed output from. + dynPipe <- dynCompileExpr readVariable + pipe <- case fromDynamic dynPipe of + Nothing -> error "Expecting lazy Bytestring" + Just fd -> liftIO $ fdToHandle fd + -- Read from a file handle until we hit a delimieter or until we've read + -- as many characters as requested + let + readChars :: Handle -> String -> Int -> IO String + + -- If we're done reading, return nothing. + readChars handle delims 0 = return [] + + readChars handle delims nchars = do + -- Try reading a single character. It will throw an exception if the + -- handle is already closed. + tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) + case tryRead of + Right char -> + -- If this is a delimiter, stop reading. + if char `elem` delims + then return [char] + else do + next <- readChars handle delims (nchars - 1) + return $ char:next + -- An error occurs at the end of the stream, so just stop reading. + Left _ -> return [] + + -- Keep track of whether execution has completed. + completed <- liftIO $ newMVar False + finishedReading <- liftIO newEmptyMVar + outputAccum <- liftIO $ newMVar "" + + -- Start a loop to publish intermediate results. + let + -- Compute how long to wait between reading pieces of the output. + -- `threadDelay` takes an argument of microseconds. + ms = 1000 + delay = 100 * ms + + -- How much to read each time. + chunkSize = 100 + + -- Maximum size of the output (after which we truncate). + maxSize = 100 * 1000 + + loop = do + -- Wait and then check if the computation is done. + threadDelay delay + computationDone <- readMVar completed + + if not computationDone + then do + -- Read next chunk and append to accumulator. + nextChunk <- readChars pipe "\n" 100 + modifyMVar_ outputAccum (return . (++ nextChunk)) + + -- Write to frontend and repeat. + readMVar outputAccum >>= output + loop + else do + -- Read remainder of output and accumulate it. + nextChunk <- readChars pipe "" maxSize + modifyMVar_ outputAccum (return . (++ nextChunk)) + + -- We're done reading. + putMVar finishedReading True + + liftIO $ forkIO loop + + result <- gfinally (goStmt stmt) $ do + -- Execution is done. + liftIO $ modifyMVar_ completed (const $ return True) + + -- Finalize evaluation context. + forM_ postStmts goStmt + + -- Once context is finalized, reading can finish. + -- Wait for reading to finish to that the output accumulator is + -- completely filled. + liftIO $ takeMVar finishedReading + + printedOutput <- liftIO $ readMVar outputAccum return (printedOutput, result) formatError :: ErrMsg -> String diff --git a/IHaskell/Eval/Info.hs b/IHaskell/Eval/Info.hs index 44b42b5d..e18bafbe 100644 --- a/IHaskell/Eval/Info.hs +++ b/IHaskell/Eval/Info.hs @@ -1,6 +1,4 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} {- | Description : Inspect type and function information and documentation. -} module IHaskell.Eval.Info ( diff --git a/IHaskell/Message/Writer.hs b/IHaskell/Message/Writer.hs index 0f667bbc..9b9982c8 100644 --- a/IHaskell/Message/Writer.hs +++ b/IHaskell/Message/Writer.hs @@ -81,6 +81,10 @@ instance ToJSON Message where "restart" .= restart ] + toJSON ClearOutput{wait = wait} = object [ + "wait" .= wait + ] + toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body diff --git a/IHaskell/Types.hs b/IHaskell/Types.hs index a7a49264..b07fd205 100644 --- a/IHaskell/Types.hs +++ b/IHaskell/Types.hs @@ -108,6 +108,7 @@ data MessageType = KernelInfoReplyMessage | ObjectInfoReplyMessage | ShutdownRequestMessage | ShutdownReplyMessage + | ClearOutputMessage instance Show MessageType where show KernelInfoReplyMessage = "kernel_info_reply" @@ -125,6 +126,7 @@ instance Show MessageType where show ObjectInfoReplyMessage = "object_info_reply" show ShutdownRequestMessage = "shutdown_request" show ShutdownReplyMessage = "shutdown_reply" + show ClearOutputMessage = "clear_output" instance FromJSON MessageType where parseJSON (String s) = case s of @@ -143,6 +145,7 @@ instance FromJSON MessageType where "object_info_reply" -> return ObjectInfoReplyMessage "shutdown_request" -> return ShutdownRequestMessage "shutdown_reply" -> return ShutdownReplyMessage + "clear_output" -> return ClearOutputMessage _ -> fail ("Unknown message type: " ++ show s) parseJSON _ = fail "Must be a string." @@ -222,22 +225,7 @@ data Message completionText :: ByteString, completionStatus :: Bool } - {- ^ -# The list of all matches to the completion request, such as -# ['a.isalnum', 'a.isalpha'] for the above example. -'matches' : list, -# the substring of the matched text -# this is typically the common prefix of the matches, -# and the text that is already in the block that would be replaced by the full completion. -# This would be 'a.is' in the above example. -'text' : str, - -# status should be 'ok' unless an exception was raised during the request, -# in which case it should be 'error', along with the usual error message content -# in other messages. -'status' : 'ok' -} -} | ObjectInfoRequest { header :: MessageHeader, objectName :: ByteString, -- ^ Name of object being searched for. @@ -245,6 +233,7 @@ data Message -- 0 is equivalent to foo?, 1 is equivalent -- to foo??. } + | ObjectInfoReply { header :: MessageHeader, objectName :: ByteString, -- ^ Name of object which was searched for. @@ -262,6 +251,11 @@ data Message restartPending :: Bool -- ^ Whether this shutdown precedes a restart. } + | ClearOutput { + header :: MessageHeader, + wait :: Bool -- ^ Whether to wait to redraw until there is more output. + } + deriving Show -- | Possible statuses in the execution reply messages. diff --git a/Main.hs b/Main.hs index 856f20b0..75ca336a 100644 --- a/Main.hs +++ b/Main.hs @@ -96,7 +96,7 @@ initialKernelState = } -- | Duplicate a message header, giving it a new UUID and message type. -dupHeader :: MessageHeader -> MessageType -> Interpreter MessageHeader +dupHeader :: MessageHeader -> MessageType -> IO MessageHeader dupHeader header messageType = do uuid <- liftIO UUID.random @@ -145,20 +145,48 @@ replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do -- All the headers are copies of the reply header with a different -- message type, because this preserves the session ID, parent header, -- and other important information. - busyHeader <- dupHeader replyHeader StatusMessage + busyHeader <- liftIO $ dupHeader replyHeader StatusMessage send $ PublishStatus busyHeader Busy -- Construct a function for publishing output as this is going. - let publish :: [DisplayData] -> Interpreter () - publish outputs = do + -- This function accepts a boolean indicating whether this is the final + -- output and the thing to display. Store the final outputs in a list so + -- that when we receive an updated non-final output, we can clear the + -- entire output and re-display with the updated output. + displayed <- liftIO $ newMVar [] + updateNeeded <- liftIO $ newMVar False + let clearOutput = do + header <- dupHeader replyHeader ClearOutputMessage + send $ ClearOutput header True + + sendOutput outs = do header <- dupHeader replyHeader DisplayDataMessage - send $ PublishDisplayData header "haskell" outputs + send $ PublishDisplayData header "haskell" outs + + publish :: Bool -> [DisplayData] -> IO () + publish final outputs = do + -- If necessary, clear all previous output and redraw. + clear <- readMVar updateNeeded + when clear $ do + clearOutput + disps <- readMVar displayed + mapM_ sendOutput $ reverse disps + + -- Draw this message. + sendOutput outputs + + -- If this is the final message, add it to the list of completed + -- messages. If it isn't, make sure we clear it later by marking + -- update needed as true. + modifyMVar_ updateNeeded (const $ return $ not final) + when final $ + modifyMVar_ displayed (return . (outputs:)) -- Run code and publish to the frontend as we go. evaluate execCount (Chars.unpack code) publish -- Notify the frontend that we're done computing. - idleHeader <- dupHeader replyHeader StatusMessage + idleHeader <- liftIO $ dupHeader replyHeader StatusMessage send $ PublishStatus idleHeader Idle -- Increment the execution counter in the kernel state.