Commit 9d23edbb authored by Andrew Gibiansky's avatar Andrew Gibiansky

Switched to non-lazy IO for reading.

parent 692860f6
...@@ -74,4 +74,6 @@ executable IHaskell ...@@ -74,4 +74,6 @@ executable IHaskell
ghc-paths ==0.1.*, ghc-paths ==0.1.*,
knob ==0.1.*, knob ==0.1.*,
directory ==1.2.*, directory ==1.2.*,
deepseq ==1.3.* deepseq ==1.3.*,
random ==1.0.*,
strict ==0.3.*
...@@ -8,8 +8,10 @@ module IHaskell.Eval.Evaluate ( ...@@ -8,8 +8,10 @@ module IHaskell.Eval.Evaluate (
import ClassyPrelude hiding (liftIO, hGetContents) import ClassyPrelude hiding (liftIO, hGetContents)
import Prelude(putChar, tail, init) import Prelude(putChar, tail, init)
import Data.List.Utils import Data.List.Utils
import Data.List(findIndex)
import Data.String.Utils import Data.String.Utils
import Text.Printf import Text.Printf
import System.Random
import Language.Haskell.Exts.Parser import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty import Language.Haskell.Exts.Pretty
...@@ -22,10 +24,15 @@ import GHC hiding (Stmt) ...@@ -22,10 +24,15 @@ import GHC hiding (Stmt)
import GHC.Paths import GHC.Paths
import Exception hiding (evaluate) import Exception hiding (evaluate)
import qualified System.IO.Strict as StrictIO
import IHaskell.Types import IHaskell.Types
debug :: Bool
debug = False
write :: GhcMonad m => String -> m () write :: GhcMonad m => String -> m ()
write x = liftIO $ hPutStrLn stderr x write x = when debug $ liftIO $ hPutStrLn stderr x
type LineNumber = Int type LineNumber = Int
type ColumnNumber = Int type ColumnNumber = Int
...@@ -89,19 +96,27 @@ parseCommands code = concatMap makeCommands pieces ...@@ -89,19 +96,27 @@ parseCommands code = concatMap makeCommands pieces
-- Pieces can be declarations, statement lists, or directives. -- Pieces can be declarations, statement lists, or directives.
-- We distinguish declarations from statements via the first line an -- We distinguish declarations from statements via the first line an
-- indentation, and directives based on the first character. -- indentation, and directives based on the first character.
samePiece x y = not (isDirective x || isDirective y) && indentLevel x <= indentLevel y
indentLevel (' ':str) = 1 + indentLevel str indentLevel (' ':str) = 1 + indentLevel str
indentLevel _ = 0 :: Int indentLevel _ = 0 :: Int
pieces = groupBy samePiece $ lines code makePieces :: [String] -> [String]
makePieces [] = []
makePieces (first:rest)
| isDirective first = first : makePieces rest
| otherwise = unlines (first:take endOfBlock rest) : makePieces (drop endOfBlock rest)
where
endOfBlock = fromMaybe (length rest) $ findIndex (\x -> indentLevel x <= indentLevel first) rest
pieces = trace (show $ makePieces $ lines code ) $ makePieces $ lines code
makeCommands lines makeCommands lines
| any isDirective lines = map createDirective lines | isDirective lines = [createDirective lines]
| any isDeclaration lines = | isDeclaration lines =
case parseDecl $ unlines lines of case parseDecl $ trace ("Decl<" ++ lines ++ "<>>>") lines of
ParseOk declaration -> [Declaration $ prettyPrint declaration] ParseOk declaration -> [Declaration $ prettyPrint declaration]
ParseFailed srcLoc errMsg -> [ParseError (srcLine srcLoc) (srcColumn srcLoc) errMsg] ParseFailed srcLoc errMsg -> [ParseError (srcLine srcLoc) (srcColumn srcLoc) errMsg]
| otherwise = | otherwise =
case parseStmts $ trace (show $ unlines lines) $ unlines lines of case parseStmts $ trace ("STMT<" ++ lines ++ "<s>>") lines of
Left (srcLine, srcColumn, errMsg) -> [ParseError srcLine srcColumn errMsg] Left (srcLine, srcColumn, errMsg) -> [ParseError srcLine srcColumn errMsg]
Right stmts -> map (Statement . prettyPrint) $ init stmts Right stmts -> map (Statement . prettyPrint) $ init stmts
isDeclaration line = any (`isInfixOf` line) ["type", "newtype", "data"] isDeclaration line = any (`isInfixOf` line) ["type", "newtype", "data"]
...@@ -127,7 +142,6 @@ evalCommand (Directive directive) = do ...@@ -127,7 +142,6 @@ evalCommand (Directive directive) = do
evalCommand (Statement stmt) = do evalCommand (Statement stmt) = do
write $ "Statement: " ++ stmt write $ "Statement: " ++ stmt
ghandle handler $ do ghandle handler $ do
(printed, result) <- capturedStatement stmt (printed, result) <- capturedStatement stmt
case result of case result of
RunOk _ -> RunOk _ ->
...@@ -156,10 +170,13 @@ evalCommand (ParseError line col err) = ...@@ -156,10 +170,13 @@ evalCommand (ParseError line col err) =
return [Display MimeHtml $ makeError $ printf "Error (line %d, column %d): %s" line col err] return [Display MimeHtml $ makeError $ printf "Error (line %d, column %d): %s" line col err]
capturedStatement :: String -> Interpreter (String, RunResult) capturedStatement :: String -> Interpreter (String, RunResult)
capturedStatement stmt = capturedStatement stmt = do
let fileVariable = "ridiculous" :: String -- Generate random variable names to use so that we cannot accidentally
fileName = ".capture" :: String -- override the variables by using the right names in the terminal.
oldVariable = fileVariable ++ "'" :: String randStr <- liftIO $ show . abs <$> (randomIO :: IO Int)
let fileVariable = "file_var_" ++ randStr :: String
fileName = ".ihaskell_capture" :: String
oldVariable = fileVariable ++ "_old" :: String
initStmts :: [String] initStmts :: [String]
initStmts = [ initStmts = [
printf "%s <- openFile \"%s\" WriteMode" fileVariable fileName, printf "%s <- openFile \"%s\" WriteMode" fileVariable fileName,
...@@ -167,19 +184,21 @@ capturedStatement stmt = ...@@ -167,19 +184,21 @@ capturedStatement stmt =
printf "hDuplicateTo %s stdout" fileVariable] printf "hDuplicateTo %s stdout" fileVariable]
postStmts :: [String] postStmts :: [String]
postStmts = [ postStmts = [
"hFlush stdout", "hFlush stdout",
printf "hDuplicateTo %s stdout" oldVariable, printf "hDuplicateTo %s stdout" oldVariable,
printf "hClose %s" fileVariable] printf "hClose %s" fileVariable]
goStmt s = runStmt s RunToCompletion in do goStmt s = runStmt s RunToCompletion
forM_ initStmts goStmt forM_ initStmts goStmt
result <- goStmt stmt result <- goStmt stmt
forM_ postStmts goStmt forM_ postStmts goStmt
printedOutput <- liftIO $ readFile $ fpFromString fileName -- We must use strict IO, because we write to that file again if we
liftIO $ print printedOutput -- 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
return (printedOutput, result) return (printedOutput, result)
parseStmts :: String -> Either (LineNumber, ColumnNumber, String) [Stmt] parseStmts :: String -> Either (LineNumber, ColumnNumber, String) [Stmt]
parseStmts code = parseStmts code =
......
-- | The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, -- | The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython,
-- | replacing it instead with a Haskell Channel based interface. The `serveProfile` function -- replacing it instead with a Haskell Channel based interface. The `serveProfile` function
-- | takes a IPython profile specification and returns the channel interface to use. -- takes a IPython profile specification and returns the channel interface to use.
module IHaskell.ZeroMQ ( module IHaskell.ZeroMQ (
ZeroMQInterface (..), ZeroMQInterface (..),
serveProfile serveProfile
...@@ -17,7 +17,7 @@ import IHaskell.Types ...@@ -17,7 +17,7 @@ import IHaskell.Types
import IHaskell.Message.Parser import IHaskell.Message.Parser
import IHaskell.Message.Writer import IHaskell.Message.Writer
-- The channel interface to the ZeroMQ sockets. All communication is done via -- | The channel interface to the ZeroMQ sockets. All communication is done via
-- Messages, which are encoded and decoded into a lower level form before being -- Messages, which are encoded and decoded into a lower level form before being
-- transmitted to IPython. These channels should functionally serve as -- transmitted to IPython. These channels should functionally serve as
-- high-level sockets which speak Messages instead of ByteStrings. -- high-level sockets which speak Messages instead of ByteStrings.
......
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