Commit 6c404483 authored by Andrew Gibiansky's avatar Andrew Gibiansky

Capture intermediate results and display them

parent de493373
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
"cell_type": "code", "cell_type": "code",
"collapsed": false, "collapsed": false,
"input": [ "input": [
"data Value = X Int\n", "data X = X Int\n",
" | Y String\n", " | Y String\n",
" | Z Float\n", " | Z Float\n",
" deriving Show\n", " deriving Show\n",
...@@ -95,12 +95,20 @@ ...@@ -95,12 +95,20 @@
"cell_type": "code", "cell_type": "code",
"collapsed": false, "collapsed": false,
"input": [ "input": [
"import Prel" "1"
], ],
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [], "outputs": [
"prompt_number": 1 {
"metadata": {},
"output_type": "display_data",
"text": [
"1"
]
}
],
"prompt_number": 4
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -111,7 +119,7 @@ ...@@ -111,7 +119,7 @@
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [], "outputs": [],
"prompt_number": 1 "prompt_number": 5
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -121,7 +129,20 @@ ...@@ -121,7 +129,20 @@
], ],
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [], "outputs": [
{
"html": [
"<span style='color: red; font-style: italic;'>Not in scope: `ma'<br/>Perhaps you meant one of these:<br/> `map' (imported from Prelude), `max' (imported from Prelude)</span>"
],
"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 "prompt_number": 6
}, },
{ {
...@@ -168,38 +189,30 @@ ...@@ -168,38 +189,30 @@
"outputs": [ "outputs": [
{ {
"html": [ "html": [
"<span style='color: red; font-style: italic;'>No instance for (Show X)<br/> arising from a use of `print'<br/>Possible fix:<br/> add an instance declaration for (Show X)</span>" "<span style='color: red; font-style: italic;'>No instance for (Num String)<br/> arising from the literal `3'<br/>Possible fix:<br/> add an instance declaration for (Num String)</span>"
], ],
"metadata": {}, "metadata": {},
"output_type": "display_data", "output_type": "display_data",
"text": [ "text": [
"No instance for (GHC.Show.Show :Interactive.X)\n", "No instance for (GHC.Num.Num GHC.Base.String)\n",
" arising from a use of `System.IO.print'\n", " arising from the literal `3'\n",
"Possible fix:\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", "cell_type": "code",
"collapsed": false, "collapsed": false,
"input": [ "input": [
"1+1" "data X = Y Int"
], ],
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [ "outputs": [],
{ "prompt_number": 14
"metadata": {},
"output_type": "display_data",
"text": [
"2"
]
}
],
"prompt_number": 10
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -210,7 +223,7 @@ ...@@ -210,7 +223,7 @@
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [], "outputs": [],
"prompt_number": 11 "prompt_number": 18
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -222,14 +235,20 @@ ...@@ -222,14 +235,20 @@
"metadata": {}, "metadata": {},
"outputs": [ "outputs": [
{ {
"html": [
"<span style='color: red; font-style: italic;'>No instance for (Num String)<br/> arising from the literal `3'<br/>Possible fix:<br/> add an instance declaration for (Num String)</span>"
],
"metadata": {}, "metadata": {},
"output_type": "display_data", "output_type": "display_data",
"text": [ "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", "cell_type": "code",
...@@ -240,7 +259,7 @@ ...@@ -240,7 +259,7 @@
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [], "outputs": [],
"prompt_number": 13 "prompt_number": 20
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -262,7 +281,7 @@ ...@@ -262,7 +281,7 @@
] ]
} }
], ],
"prompt_number": 14 "prompt_number": 21
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -284,7 +303,7 @@ ...@@ -284,7 +303,7 @@
] ]
} }
], ],
"prompt_number": 15 "prompt_number": 22
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -306,7 +325,7 @@ ...@@ -306,7 +325,7 @@
] ]
} }
], ],
"prompt_number": 16 "prompt_number": 23
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -317,7 +336,7 @@ ...@@ -317,7 +336,7 @@
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [], "outputs": [],
"prompt_number": 17 "prompt_number": 24
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -338,13 +357,13 @@ ...@@ -338,13 +357,13 @@
] ]
} }
], ],
"prompt_number": 18 "prompt_number": 25
}, },
{ {
"cell_type": "code", "cell_type": "code",
"collapsed": false, "collapsed": false,
"input": [ "input": [
"m" ":extension OverloadedStrings"
], ],
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
...@@ -408,79 +427,39 @@ ...@@ -408,79 +427,39 @@
"collapsed": false, "collapsed": false,
"input": [ "input": [
"forM_ [100, 200, 300, 400, 500, 600, 700, 800] $ \\size -> do\n", "forM_ [100, 200, 300, 400, 500, 600, 700, 800] $ \\size -> do\n",
" let s = show size\n", " let s = show size\n",
" img ! src \"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" ! width (toValue s)\n", " unsafePerformIO $ do\n",
":t y\n", " threadDelay 100000\n",
"y" " putStrLn $ \"Generating size: \" ++ s\n",
" return $ img ! src \"/static/base/images/ipynblogo.png\" ! width (toValue s)"
], ],
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [ "outputs": [
{ {
"html": [ "html": [
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"100\">\n", "<span style='color: red; font-style: italic;'>Not in scope: `unsafePerformIO'<br/>Not in scope: `threadDelay'</span>"
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"200\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"300\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"400\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"500\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"600\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"700\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"800\">\n"
], ],
"metadata": {}, "metadata": {},
"output_type": "display_data", "output_type": "display_data",
"text": [ "text": [
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"100\">\n", "Not in scope: `unsafePerformIO'\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"200\">\n", "Not in scope: `threadDelay'"
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"300\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"400\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"500\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"600\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"700\">\n",
"<img src=\"http://127.0.0.1:8693/static/base/images/ipynblogo.png\" width=\"800\">"
]
},
{
"html": [
"<span style='color: red; font-style: italic;'>Not in scope: `y'</span>"
],
"metadata": {},
"output_type": "display_data",
"text": [
"Not in scope: `y'"
] ]
} }
], ],
"prompt_number": 3 "prompt_number": 4
}, },
{ {
"cell_type": "code", "cell_type": "code",
"collapsed": false, "collapsed": false,
"input": [ "input": [
"let y = forM (map (* 10) [1..40]) $ \\size -> do\n", "import System.IO.Unsafe"
" 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"
], ],
"language": "python", "language": "python",
"metadata": {}, "metadata": {},
"outputs": [ "outputs": [],
{ "prompt_number": 8
"html": [
"<span style='color: red; font-style: italic;'>Couldn't match type `Text.Blaze.Internal.MarkupM ()'<br/> with `Text.Blaze.Internal.Attribute'<br/>Expected type: Text.Blaze.Internal.Attribute<br/> Actual type: Text.Blaze.Html.Html</span>"
],
"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
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -518,7 +497,7 @@ ...@@ -518,7 +497,7 @@
] ]
} }
], ],
"prompt_number": 58 "prompt_number": 8
}, },
{ {
"cell_type": "code", "cell_type": "code",
...@@ -575,6 +554,128 @@ ...@@ -575,6 +554,128 @@
], ],
"prompt_number": 61 "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": [
"<span style='color: red; font-style: italic;'>No instance for (Show Thing)<br/> arising from a use of `print'<br/>Possible fix:<br/> add an instance declaration for (Show Thing)</span>"
],
"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": [
"<span style='color: red; font-style: italic;'>No instance for (Show Thing)<br/> arising from a use of `print'<br/>Possible fix:<br/> add an instance declaration for (Show Thing)</span>"
],
"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", "cell_type": "code",
"collapsed": false, "collapsed": false,
......
...@@ -29,7 +29,7 @@ is string blockType = do ...@@ -29,7 +29,7 @@ is string blockType = do
eval string = do eval string = do
outputAccum <- newIORef [] outputAccum <- newIORef []
let publish displayDatas = liftIO $ modifyIORef outputAccum (displayDatas :) let publish _ displayDatas = modifyIORef outputAccum (displayDatas :)
getTemporaryDirectory >>= setCurrentDirectory getTemporaryDirectory >>= setCurrentDirectory
interpret $ evaluate 1 string publish interpret $ evaluate 1 string publish
out <- readIORef outputAccum out <- readIORef outputAccum
......
...@@ -56,6 +56,7 @@ extra-source-files: ...@@ -56,6 +56,7 @@ extra-source-files:
library library
build-depends: base ==4.6.*, build-depends: base ==4.6.*,
unix >= 2.6,
hspec, hspec,
zeromq3-haskell ==0.5.*, zeromq3-haskell ==0.5.*,
aeson ==0.6.*, aeson ==0.6.*,
...@@ -113,6 +114,7 @@ executable IHaskell ...@@ -113,6 +114,7 @@ executable IHaskell
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base ==4.6.*, build-depends: base ==4.6.*,
unix >= 2.6,
hspec, hspec,
zeromq3-haskell ==0.5.*, zeromq3-haskell ==0.5.*,
aeson ==0.6.*, aeson ==0.6.*,
...@@ -143,6 +145,7 @@ Test-Suite hspec ...@@ -143,6 +145,7 @@ Test-Suite hspec
Ghc-Options: -threaded Ghc-Options: -threaded
Main-Is: Hspec.hs Main-Is: Hspec.hs
build-depends: base ==4.6.*, build-depends: base ==4.6.*,
unix >= 2.6,
hspec, hspec,
zeromq3-haskell ==0.5.*, zeromq3-haskell ==0.5.*,
aeson ==0.6.*, aeson ==0.6.*,
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import Prelude import Prelude
import Data.List (find, isPrefixOf, nub, findIndex, intercalate) import Data.List (find, isPrefixOf, nub, findIndex, intercalate, elemIndex)
import GHC import GHC
import GhcMonad import GhcMonad
import PackageConfig import PackageConfig
...@@ -53,7 +53,7 @@ complete line pos = do ...@@ -53,7 +53,7 @@ complete line pos = do
let Just db = pkgDatabase flags let Just db = pkgDatabase flags
getNames = map moduleNameString . exposedModules getNames = map moduleNameString . exposedModules
moduleNames = nub $ concat $ map getNames db moduleNames = nub $ concatMap getNames db
let target = completionTarget line pos let target = completionTarget line pos
matchedText = intercalate "." target matchedText = intercalate "." target
...@@ -97,19 +97,17 @@ getTrueModuleName name = do ...@@ -97,19 +97,17 @@ getTrueModuleName name = do
completionType :: String -> [String] -> CompletionType completionType :: String -> [String] -> CompletionType
completionType line [] = Empty completionType line [] = Empty
completionType line target = completionType line target
if startswith "import" (strip line) && isModName | startswith "import" (strip line) && isModName =
then ModuleName dotted candidate ModuleName dotted candidate
else | isModName && (not . null . init) target =
if isModName && (not . null . init) target Qualified dotted candidate
then Qualified dotted candidate | otherwise = Identifier candidate
else Identifier candidate where dotted = dots target
where candidate = last target
dotted = dots target dots = intercalate "." . init
candidate = last target isModName = all isCapitalized (init target)
dots = intercalate "." . init isCapitalized = isUpper . head
isModName = all isCapitalized (init target)
isCapitalized = isUpper . head
-- | Get the word under a given cursor location. -- | Get the word under a given cursor location.
...@@ -132,7 +130,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete ...@@ -132,7 +130,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
splitAlongCursor [] = [] splitAlongCursor [] = []
splitAlongCursor (x:xs) = splitAlongCursor (x:xs) =
case findIndex (== cursor) $ map snd x of case elemIndex cursor $ map snd x of
Nothing -> x:splitAlongCursor xs Nothing -> x:splitAlongCursor xs
Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs
......
...@@ -9,6 +9,7 @@ module IHaskell.Eval.Evaluate ( ...@@ -9,6 +9,7 @@ module IHaskell.Eval.Evaluate (
) where ) where
import ClassyPrelude hiding (liftIO, hGetContents) import ClassyPrelude hiding (liftIO, hGetContents)
import Control.Concurrent (forkIO, threadDelay)
import Prelude (putChar, head, tail, last, init, (!!)) import Prelude (putChar, head, tail, last, init, (!!))
import Data.List.Utils import Data.List.Utils
import Data.List(findIndex) import Data.List(findIndex)
...@@ -19,9 +20,11 @@ import Data.Dynamic ...@@ -19,9 +20,11 @@ import Data.Dynamic
import Data.Typeable import Data.Typeable
import qualified Data.Serialize as Serialize import qualified Data.Serialize as Serialize
import System.Directory (removeFile, createDirectoryIfMissing, removeDirectoryRecursive) import System.Directory (removeFile, createDirectoryIfMissing, removeDirectoryRecursive)
import System.Posix.IO
import System.IO (hGetChar, hFlush)
import System.Random (getStdGen, randomRs)
import NameSet import NameSet
import DynFlags (defaultObjectTarget)
import Name import Name
import PprTyThing import PprTyThing
import InteractiveEval import InteractiveEval
...@@ -63,31 +66,6 @@ typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes) ...@@ -63,31 +66,6 @@ typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes)
fullPrefixes = map (++ ".") ignoreTypePrefixes fullPrefixes = map (++ ".") ignoreTypePrefixes
useStringType = replace "[Char]" "String" 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 :: GhcMonad m => String -> m ()
write x = when debug $ liftIO $ hPutStrLn stderr x write x = when debug $ liftIO $ hPutStrLn stderr x
...@@ -98,6 +76,8 @@ globalImports = ...@@ -98,6 +76,8 @@ globalImports =
[ "import IHaskell.Display" [ "import IHaskell.Display"
, "import Control.Applicative ((<$>))" , "import Control.Applicative ((<$>))"
, "import GHC.IO.Handle (hDuplicateTo, hDuplicate)" , "import GHC.IO.Handle (hDuplicateTo, hDuplicate)"
, "import System.Posix.IO"
, "import System.Posix.Files"
, "import System.IO" , "import System.IO"
] ]
...@@ -156,10 +136,14 @@ initializeItVariable = ...@@ -156,10 +136,14 @@ initializeItVariable =
-- statements - if it doesn't exist, the first statement will fail. -- statements - if it doesn't exist, the first statement will fail.
void $ runStmt "let it = ()" RunToCompletion 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 some IPython input code.
evaluate :: Int -- ^ The execution counter of this evaluation. evaluate :: Int -- ^ The execution counter of this evaluation.
-> String -- ^ Haskell code or other interpreter commands. -> String -- ^ Haskell code or other interpreter commands.
-> ([DisplayData] -> Interpreter ()) -- ^ Function used to publish data outputs. -> Publisher -- ^ Function used to publish data outputs.
-> Interpreter () -> Interpreter ()
evaluate execCount code output = do evaluate execCount code output = do
cmds <- parseString (strip code) cmds <- parseString (strip code)
...@@ -168,8 +152,8 @@ evaluate execCount code output = do ...@@ -168,8 +152,8 @@ evaluate execCount code output = do
runUntilFailure :: [CodeBlock] -> Interpreter () runUntilFailure :: [CodeBlock] -> Interpreter ()
runUntilFailure [] = return () runUntilFailure [] = return ()
runUntilFailure (cmd:rest) = do runUntilFailure (cmd:rest) = do
(success, result) <- evalCommand cmd (success, result) <- evalCommand output cmd
unless (null result) $ output result unless (null result) $ liftIO $ output True result
case success of case success of
Success -> runUntilFailure rest Success -> runUntilFailure rest
Failure -> return () Failure -> return ()
...@@ -185,8 +169,8 @@ wrapExecution exec = ghandle handler $ exec >>= \res -> ...@@ -185,8 +169,8 @@ wrapExecution exec = ghandle handler $ exec >>= \res ->
-- | Return the display data for this command, as well as whether it -- | Return the display data for this command, as well as whether it
-- resulted in an error. -- resulted in an error.
evalCommand :: CodeBlock -> Interpreter (ErrorOccurred, [DisplayData]) evalCommand :: Publisher -> CodeBlock -> Interpreter (ErrorOccurred, [DisplayData])
evalCommand (Import importStr) = wrapExecution $ do evalCommand _ (Import importStr) = wrapExecution $ do
write $ "Import: " ++ importStr write $ "Import: " ++ importStr
importDecl <- parseImportDecl importStr importDecl <- parseImportDecl importStr
context <- getContext context <- getContext
...@@ -202,7 +186,7 @@ evalCommand (Import importStr) = wrapExecution $ do ...@@ -202,7 +186,7 @@ evalCommand (Import importStr) = wrapExecution $ do
implicitImportOf _ (IIModule _) = False implicitImportOf _ (IIModule _) = False
implicitImportOf imp (IIDecl decl) = ideclImplicit decl && ((==) `on` (unLoc . ideclName)) decl imp 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 -- Write the module contents to a temporary file in our work directory
namePieces <- getModuleName contents namePieces <- getModuleName contents
let directory = "./" ++ intercalate "/" (init namePieces) ++ "/" let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"
...@@ -270,7 +254,7 @@ evalCommand (Module contents) = wrapExecution $ do ...@@ -270,7 +254,7 @@ evalCommand (Module contents) = wrapExecution $ do
Succeeded -> return [] Succeeded -> return []
Failed -> return $ displayError $ "Failed to load module " ++ modName 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) results <- mapM setExtension (words exts)
case catMaybes results of case catMaybes results of
[] -> return [] [] -> return []
...@@ -304,14 +288,14 @@ evalCommand (Directive SetExtension exts) = wrapExecution $ do ...@@ -304,14 +288,14 @@ evalCommand (Directive SetExtension exts) = wrapExecution $ do
-- In that case, we disable the extension. -- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name flagMatchesNo ext (name, _, _) = ext == "No" ++ name
evalCommand (Directive GetType expr) = wrapExecution $ do evalCommand _ (Directive GetType expr) = wrapExecution $ do
result <- exprType expr result <- exprType expr
flags <- getSessionDynFlags flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr result let typeStr = showSDocUnqual flags $ ppr result
return [plain typeStr, html $ formatGetType typeStr] return [plain typeStr, html $ formatGetType typeStr]
-- This is taken largely from GHCi's info section in InteractiveUI. -- 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" where out = plain $ intercalate "\n"
[":set is not implemented in IHaskell." [":set is not implemented in IHaskell."
," Use :extension <Extension> to enable a GHC extension." ," Use :extension <Extension> to enable a GHC extension."
...@@ -319,7 +303,7 @@ evalCommand (Directive HelpForSet _) = return (Success, [out]) ...@@ -319,7 +303,7 @@ evalCommand (Directive HelpForSet _) = return (Success, [out])
] ]
-- This is taken largely from GHCi's info section in InteractiveUI. -- 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" where out = plain $ intercalate "\n"
["The following commands are available:" ["The following commands are available:"
," :extension <Extension> - enable a GHC extension." ," :extension <Extension> - enable a GHC extension."
...@@ -332,7 +316,7 @@ evalCommand (Directive GetHelp _) = return (Success, [out]) ...@@ -332,7 +316,7 @@ evalCommand (Directive GetHelp _) = return (Success, [out])
] ]
-- This is taken largely from GHCi's info section in InteractiveUI. -- 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. -- Get all the info for all the names we're given.
names <- parseName str names <- parseName str
maybeInfos <- mapM getInfo names maybeInfos <- mapM getInfo names
...@@ -363,10 +347,11 @@ evalCommand (Directive GetInfo str) = wrapExecution $ do ...@@ -363,10 +347,11 @@ evalCommand (Directive GetInfo str) = wrapExecution $ do
let strings = map (showSDocForUser flags unqual) outs let strings = map (showSDocForUser flags unqual) outs
return [plain $ intercalate "\n" strings] return [plain $ intercalate "\n" strings]
evalCommand (Statement stmt) = do evalCommand output (Statement stmt) = do
write $ "Statement: " ++ stmt write $ "Statement: " ++ stmt
ghandle handler $ do ghandle handler $ do
(printed, result) <- capturedStatement stmt let outputter str = output False [plain str]
(printed, result) <- capturedStatement outputter stmt
case result of case result of
RunOk names -> do RunOk names -> do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
...@@ -383,16 +368,12 @@ evalCommand (Statement stmt) = do ...@@ -383,16 +368,12 @@ evalCommand (Statement stmt) = do
handler exception = do handler exception = do
write $ concat ["BreakCom: ", show exception, "\nfrom statement:\n", stmt] 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) return (Failure, displayError $ show exception)
evalCommand (Expression expr) = do evalCommand output (Expression expr) = do
-- Evaluate this expression as though it's just a statement. -- Evaluate this expression as though it's just a statement.
-- The output is bound to 'it', so we can then use it. -- 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 -- Try to use `display` to convert our type into the output
-- DisplayData. If typechecking fails and there is no appropriate -- DisplayData. If typechecking fails and there is no appropriate
...@@ -427,7 +408,7 @@ evalCommand (Expression expr) = do ...@@ -427,7 +408,7 @@ evalCommand (Expression expr) = do
startswith "No instance for (GHC.Show.Show " msg && startswith "No instance for (GHC.Show.Show " msg &&
isInfixOf " arising from a use of `System.IO.print'" msg isInfixOf " arising from a use of `System.IO.print'" msg
Nothing -> False Nothing -> False
where isPlain (Display mime _) = (mime == PlainText) where isPlain (Display mime _) = mime == PlainText
useDisplay displayExpr = wrapExecution $ do useDisplay displayExpr = wrapExecution $ do
-- If there are instance matches, convert the object into -- If there are instance matches, convert the object into
...@@ -449,27 +430,143 @@ evalCommand (Expression expr) = do ...@@ -449,27 +430,143 @@ evalCommand (Expression expr) = do
return displayData 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 return $ displayError $ formatParseError loc err
capturedStatement :: String -> Interpreter (String, RunResult) capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output.
capturedStatement stmt = do -> 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 -- Generate random variable names to use so that we cannot accidentally
-- override the variables by using the right names in the terminal. -- override the variables by using the right names in the terminal.
let (fileName, initStmts, postStmts) = makeWrapperStmts gen <- liftIO getStdGen
goStmt s = runStmt s RunToCompletion 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 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) return (printedOutput, result)
formatError :: ErrMsg -> String formatError :: ErrMsg -> String
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{- | Description : Inspect type and function information and documentation. {- | Description : Inspect type and function information and documentation.
-} -}
module IHaskell.Eval.Info ( module IHaskell.Eval.Info (
......
...@@ -81,6 +81,10 @@ instance ToJSON Message where ...@@ -81,6 +81,10 @@ instance ToJSON Message where
"restart" .= restart "restart" .= restart
] ]
toJSON ClearOutput{wait = wait} = object [
"wait" .= wait
]
toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
......
...@@ -108,6 +108,7 @@ data MessageType = KernelInfoReplyMessage ...@@ -108,6 +108,7 @@ data MessageType = KernelInfoReplyMessage
| ObjectInfoReplyMessage | ObjectInfoReplyMessage
| ShutdownRequestMessage | ShutdownRequestMessage
| ShutdownReplyMessage | ShutdownReplyMessage
| ClearOutputMessage
instance Show MessageType where instance Show MessageType where
show KernelInfoReplyMessage = "kernel_info_reply" show KernelInfoReplyMessage = "kernel_info_reply"
...@@ -125,6 +126,7 @@ instance Show MessageType where ...@@ -125,6 +126,7 @@ instance Show MessageType where
show ObjectInfoReplyMessage = "object_info_reply" show ObjectInfoReplyMessage = "object_info_reply"
show ShutdownRequestMessage = "shutdown_request" show ShutdownRequestMessage = "shutdown_request"
show ShutdownReplyMessage = "shutdown_reply" show ShutdownReplyMessage = "shutdown_reply"
show ClearOutputMessage = "clear_output"
instance FromJSON MessageType where instance FromJSON MessageType where
parseJSON (String s) = case s of parseJSON (String s) = case s of
...@@ -143,6 +145,7 @@ instance FromJSON MessageType where ...@@ -143,6 +145,7 @@ instance FromJSON MessageType where
"object_info_reply" -> return ObjectInfoReplyMessage "object_info_reply" -> return ObjectInfoReplyMessage
"shutdown_request" -> return ShutdownRequestMessage "shutdown_request" -> return ShutdownRequestMessage
"shutdown_reply" -> return ShutdownReplyMessage "shutdown_reply" -> return ShutdownReplyMessage
"clear_output" -> return ClearOutputMessage
_ -> fail ("Unknown message type: " ++ show s) _ -> fail ("Unknown message type: " ++ show s)
parseJSON _ = fail "Must be a string." parseJSON _ = fail "Must be a string."
...@@ -222,22 +225,7 @@ data Message ...@@ -222,22 +225,7 @@ data Message
completionText :: ByteString, completionText :: ByteString,
completionStatus :: Bool 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 { | ObjectInfoRequest {
header :: MessageHeader, header :: MessageHeader,
objectName :: ByteString, -- ^ Name of object being searched for. objectName :: ByteString, -- ^ Name of object being searched for.
...@@ -245,6 +233,7 @@ data Message ...@@ -245,6 +233,7 @@ data Message
-- 0 is equivalent to foo?, 1 is equivalent -- 0 is equivalent to foo?, 1 is equivalent
-- to foo??. -- to foo??.
} }
| ObjectInfoReply { | ObjectInfoReply {
header :: MessageHeader, header :: MessageHeader,
objectName :: ByteString, -- ^ Name of object which was searched for. objectName :: ByteString, -- ^ Name of object which was searched for.
...@@ -262,6 +251,11 @@ data Message ...@@ -262,6 +251,11 @@ data Message
restartPending :: Bool -- ^ Whether this shutdown precedes a restart. 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 deriving Show
-- | Possible statuses in the execution reply messages. -- | Possible statuses in the execution reply messages.
......
...@@ -96,7 +96,7 @@ initialKernelState = ...@@ -96,7 +96,7 @@ initialKernelState =
} }
-- | Duplicate a message header, giving it a new UUID and message type. -- | 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 dupHeader header messageType = do
uuid <- liftIO UUID.random uuid <- liftIO UUID.random
...@@ -145,20 +145,48 @@ replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -145,20 +145,48 @@ replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do
-- All the headers are copies of the reply header with a different -- All the headers are copies of the reply header with a different
-- message type, because this preserves the session ID, parent header, -- message type, because this preserves the session ID, parent header,
-- and other important information. -- and other important information.
busyHeader <- dupHeader replyHeader StatusMessage busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
send $ PublishStatus busyHeader Busy send $ PublishStatus busyHeader Busy
-- Construct a function for publishing output as this is going. -- Construct a function for publishing output as this is going.
let publish :: [DisplayData] -> Interpreter () -- This function accepts a boolean indicating whether this is the final
publish outputs = do -- 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 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. -- Run code and publish to the frontend as we go.
evaluate execCount (Chars.unpack code) publish evaluate execCount (Chars.unpack code) publish
-- Notify the frontend that we're done computing. -- Notify the frontend that we're done computing.
idleHeader <- dupHeader replyHeader StatusMessage idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
send $ PublishStatus idleHeader Idle send $ PublishStatus idleHeader Idle
-- Increment the execution counter in the kernel state. -- Increment the execution counter in the kernel state.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment