mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-15 19:06:06 +00:00
Everything works.
This commit is contained in:
Andrew Gibiansky
parent
e65dea7a69
commit
412f44b952
@ -69,6 +69,12 @@ executable IHaskell
|
||||
uuid ==1.2.*,
|
||||
containers ==0.5.*,
|
||||
process ==1.1.*,
|
||||
haskell-src-exts ==1.14.*
|
||||
haskell-src-exts ==1.14.*,
|
||||
ghc ==7.6.*,
|
||||
ghc-paths ==0.1.*,
|
||||
knob ==0.1.*,
|
||||
directory ==1.2.*,
|
||||
deepseq ==1.3.*
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,128 +1,163 @@
|
||||
-- | This module exports all functions used for evaluation of IHaskell input.
|
||||
module IHaskell.Eval.Evaluate (
|
||||
evaluate, Interpreter, makeInterpreter
|
||||
interpret, evaluate, Interpreter, liftIO
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude hiding (liftIO, hGetContents)
|
||||
import Prelude(putChar, tail, init)
|
||||
import System.Process
|
||||
import System.IO (hSetBuffering, BufferMode(..), hPutStr, hGetChar)
|
||||
import Data.List.Utils
|
||||
import Data.String.Utils
|
||||
import Text.Printf
|
||||
|
||||
import Language.Haskell.Exts.Parser
|
||||
import Language.Haskell.Exts.Pretty
|
||||
import Language.Haskell.Exts.Syntax
|
||||
import Language.Haskell.Exts.Syntax hiding (Name)
|
||||
|
||||
import InteractiveEval
|
||||
import HscTypes
|
||||
import Name
|
||||
import GhcMonad (liftIO)
|
||||
import GHC hiding (Stmt)
|
||||
import GHC.Paths
|
||||
import Exception hiding (evaluate)
|
||||
|
||||
import IHaskell.Types
|
||||
|
||||
write :: GhcMonad m => String -> m ()
|
||||
write x = liftIO $ hPutStrLn stderr x
|
||||
|
||||
type LineNumber = Int
|
||||
type ColumnNumber = Int
|
||||
type Interpreter = Ghc
|
||||
data Command
|
||||
= Directive String
|
||||
| Import String
|
||||
| Statement String
|
||||
| ParseError LineNumber ColumnNumber String
|
||||
deriving Show
|
||||
|
||||
promptString :: String
|
||||
promptString = "+++GHCI_IHASKELL+++>"
|
||||
globalImports :: [String]
|
||||
globalImports =
|
||||
[ "import Prelude"
|
||||
, "import Control.Applicative ((<$>))"
|
||||
, "import GHC.IO.Handle (hDuplicateTo, hDuplicate)"
|
||||
, "import System.IO"
|
||||
]
|
||||
|
||||
data Interpreter = Interpreter {
|
||||
inStream :: Handle,
|
||||
outStream :: Handle,
|
||||
errStream :: Handle,
|
||||
ghciHandle :: ProcessHandle
|
||||
}
|
||||
directiveChar :: Char
|
||||
directiveChar = ':'
|
||||
|
||||
makeInterpreter :: IO Interpreter
|
||||
makeInterpreter = do
|
||||
let processSpec = (proc "ghci.sh" ["-ghci-script", "ihaskell.ghci"]) {
|
||||
std_in = CreatePipe,
|
||||
std_out = CreatePipe,
|
||||
std_err = CreatePipe
|
||||
}
|
||||
(Just input, Just output, Just errs, processHandle) <- createProcess processSpec
|
||||
interpret :: Interpreter a -> IO a
|
||||
interpret action = runGhc (Just libdir) $ do
|
||||
-- Set the dynamic session flags
|
||||
dflags <- getSessionDynFlags
|
||||
setSessionDynFlags $ dflags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
|
||||
|
||||
hSetBuffering input NoBuffering
|
||||
hSetBuffering output NoBuffering
|
||||
hSetBuffering errs NoBuffering
|
||||
-- Import modules.
|
||||
imports <- mapM parseImportDecl globalImports
|
||||
setContext $ map IIDecl imports
|
||||
|
||||
let interpreter = Interpreter {
|
||||
inStream = input,
|
||||
outStream = output,
|
||||
errStream = errs,
|
||||
ghciHandle = processHandle
|
||||
}
|
||||
|
||||
initializeInterpreter interpreter
|
||||
return interpreter
|
||||
|
||||
ghciSend :: Interpreter -> String -> IO ()
|
||||
ghciSend interpreter = hPutStr (inStream interpreter)
|
||||
|
||||
ghciConsumePrompt :: Interpreter -> IO [String]
|
||||
ghciConsumePrompt interpreter = readChars []
|
||||
where readChars prev =
|
||||
if startswith (reverse promptString) prev
|
||||
then case lines prev of
|
||||
_ : rest -> return $ reverse $ map reverse rest
|
||||
[] -> error "No prompt present."
|
||||
else do
|
||||
nextChar <- hGetChar (outStream interpreter)
|
||||
when (nextChar == '\n') $ print $ reverse prev
|
||||
readChars (nextChar : prev)
|
||||
|
||||
initializeInterpreter :: Interpreter -> IO ()
|
||||
initializeInterpreter = void . ghciConsumePrompt
|
||||
-- Run the rest of the interpreter
|
||||
action
|
||||
|
||||
-- | Evaluate some IPython input code.
|
||||
evaluate :: Interpreter -- ^ Handle to the interpreter context.
|
||||
-> String -- ^ Haskell code or other interpreter commands.
|
||||
-> IO [DisplayData] -- ^ All of the output.
|
||||
evaluate interpreter code =
|
||||
case strip code of
|
||||
"" -> return []
|
||||
strippedCode ->
|
||||
let codePieces = map makeCodePiece $ groupBy sameCodePiece $ lines strippedCode in
|
||||
concat <$> mapM (evalCodePiece interpreter) codePieces
|
||||
evaluate :: String -- ^ Haskell code or other interpreter commands.
|
||||
-> Interpreter [DisplayData] -- ^ All of the output.
|
||||
evaluate code
|
||||
| strip code == "" = return []
|
||||
| otherwise = joinDisplays <$> mapM evalCommand (parseCommands $ strip code)
|
||||
|
||||
data CodePiece = GhciDirectives String | HaskellStmts String
|
||||
joinDisplays :: [[DisplayData]] -> [DisplayData]
|
||||
joinDisplays displays =
|
||||
let isPlain (Display mime _) = (mime == PlainText)
|
||||
allDisplays = concat displays
|
||||
plains = filter isPlain allDisplays
|
||||
other = filter (not . isPlain) allDisplays
|
||||
getText (Display PlainText text) = text
|
||||
joinedPlains = Display PlainText $ concat $ map getText plains in
|
||||
joinedPlains : other
|
||||
|
||||
makeCodePiece :: [String] -> CodePiece
|
||||
makeCodePiece lines =
|
||||
if any isDirective lines
|
||||
then GhciDirectives $ unlines lines
|
||||
else HaskellStmts $ unlines lines
|
||||
|
||||
isDirective :: String -> Bool
|
||||
isDirective line =
|
||||
let stripped = strip line in
|
||||
startswith ":" stripped || startswith "import" stripped
|
||||
|
||||
sameCodePiece :: String -> String -> Bool
|
||||
sameCodePiece = (==) `on` isDirective
|
||||
|
||||
evalCodePiece :: Interpreter -> CodePiece -> IO [DisplayData]
|
||||
evalCodePiece interpreter (HaskellStmts code) =
|
||||
case parseStmts code of
|
||||
Left (errLine, errCol, errMsg) -> return [Display MimeHtml $ makeError $ printf "error Error (line %d, column %d): %s" errLine errCol errMsg]
|
||||
Right statements -> do
|
||||
mapM_ (putStrLn . pack) $ map prettyPrint statements
|
||||
concat <$> mapM (getResponse interpreter . prettyPrint) (init statements)
|
||||
|
||||
evalCodePiece interpreter (GhciDirectives directives) = do
|
||||
mapM_ (getResponse interpreter) $ lines directives
|
||||
return []
|
||||
|
||||
stripDoBlock :: String -> String
|
||||
stripDoBlock =
|
||||
unlines . map dedent . init . lines
|
||||
parseCommands :: String -- ^ Code containing commands.
|
||||
-> [Command] -- ^ Commands contained in code string.
|
||||
parseCommands code = concatMap makeCommands pieces
|
||||
where
|
||||
dedent (' ':' ':rest) = rest
|
||||
pieces = groupBy ((==) `on` isDirective) $ lines code
|
||||
makeCommands lines
|
||||
| any isDirective lines = map createDirective lines
|
||||
| otherwise =
|
||||
case parseStmts $ unlines lines of
|
||||
Left (srcLine, srcColumn, errMsg) -> [ParseError srcLine srcColumn errMsg]
|
||||
Right stmts -> map (Statement . prettyPrint) $ init stmts
|
||||
isDirective line = startswith [directiveChar] stripped || startswith "import" stripped
|
||||
where stripped = strip line
|
||||
createDirective line =
|
||||
case strip line of
|
||||
':':_ -> Directive $ strip line
|
||||
_ -> Import $ strip line
|
||||
|
||||
getResponse :: Interpreter -> String -> IO [DisplayData]
|
||||
getResponse interpreter code = do
|
||||
mapM_ (ghciSend interpreter . (++ "\n")) $ lines code
|
||||
inlines <- ghciConsumePrompt interpreter
|
||||
case inlines of
|
||||
[] -> return []
|
||||
_ -> return $ parseOutput $ unlines inlines
|
||||
evalCommand :: Command -> Interpreter [DisplayData]
|
||||
evalCommand (Import importStr) = do
|
||||
write $ "Import: " ++ importStr
|
||||
importDecl <- parseImportDecl importStr
|
||||
context <- getContext
|
||||
setContext $ IIDecl importDecl : context
|
||||
return []
|
||||
|
||||
evalCommand (Directive directive) = do
|
||||
write $ "Directive: " ++ directive
|
||||
return [Display MimeHtml $ printf "<span style='font-weight: bold; color: green;'>%s</span>" directive]
|
||||
|
||||
evalCommand (Statement stmt) = do
|
||||
write $ "Statement: " ++ stmt
|
||||
ghandle handler $ do
|
||||
|
||||
(printed, result) <- capturedStatement stmt
|
||||
case result of
|
||||
RunOk names -> --concat <$> mapM showName names
|
||||
return [Display PlainText printed]
|
||||
RunException exception -> do
|
||||
write $ "RunException: " ++ show exception
|
||||
return [Display MimeHtml $ makeError $ show exception]
|
||||
RunBreak{} ->
|
||||
error "Should not break."
|
||||
where
|
||||
handler :: SomeException -> Interpreter [DisplayData]
|
||||
handler exception = do
|
||||
write $ concat ["Break: ", show exception, "\nfrom statement:\n", stmt]
|
||||
return [Display MimeHtml $ makeError $ show exception]
|
||||
|
||||
evalCommand (ParseError line col err) =
|
||||
return [Display MimeHtml $ makeError $ printf "error Error (line %d, column %d): %s" line col err]
|
||||
|
||||
capturedStatement :: String -> Interpreter (String, RunResult)
|
||||
capturedStatement stmt =
|
||||
let fileVariable = "ridiculous" :: String
|
||||
fileName = ".capture" :: String
|
||||
oldVariable = fileVariable ++ "'" :: String
|
||||
initStmts :: [String]
|
||||
initStmts = [
|
||||
printf "%s <- openFile \"%s\" WriteMode" fileVariable fileName,
|
||||
printf "%s <- hDuplicate stdout" oldVariable,
|
||||
printf "hDuplicateTo %s stdout" fileVariable]
|
||||
postStmts :: [String]
|
||||
postStmts = [
|
||||
"hFlush stdout",
|
||||
printf "hDuplicateTo %s stdout" oldVariable,
|
||||
printf "hClose %s" fileVariable]
|
||||
goStmt s = runStmt s RunToCompletion in do
|
||||
|
||||
forM_ initStmts goStmt
|
||||
result <- goStmt stmt
|
||||
forM_ postStmts goStmt
|
||||
|
||||
printedOutput <- liftIO $ readFile $ fpFromString fileName
|
||||
liftIO $ print printedOutput
|
||||
|
||||
return (printedOutput, result)
|
||||
|
||||
showName :: Name -> Interpreter [DisplayData]
|
||||
showName _ =
|
||||
return [Display PlainText "Hello!"]
|
||||
|
||||
parseStmts :: String -> Either (LineNumber, ColumnNumber, String) [Stmt]
|
||||
parseStmts code =
|
||||
@ -136,13 +171,5 @@ parseStmts code =
|
||||
indent = (" " ++)
|
||||
returnStmt = "return ()"
|
||||
|
||||
|
||||
parseOutput :: String -> [DisplayData]
|
||||
parseOutput output
|
||||
| startswith "<interactive>" output = [Display MimeHtml $ makeError output]
|
||||
| otherwise = [Display PlainText output]
|
||||
|
||||
makeError :: String -> String
|
||||
makeError output =
|
||||
let _ : rest = words output in
|
||||
printf "<span style='color: red; font-style: italic;'>%s</span>" $ unwords rest
|
||||
makeError = printf "<span style='color: red; font-style: italic;'>%s</span>"
|
||||
|
||||
33
Main.hs
33
Main.hs
@ -1,4 +1,4 @@
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude hiding (liftIO)
|
||||
import Control.Concurrent.Chan
|
||||
import Data.Aeson
|
||||
|
||||
@ -12,7 +12,6 @@ import qualified Data.ByteString.Char8 as Chars
|
||||
|
||||
data KernelState = KernelState
|
||||
{ getExecutionCounter :: Int
|
||||
, getInterpreter :: Interpreter
|
||||
}
|
||||
|
||||
main :: IO ()
|
||||
@ -29,33 +28,32 @@ main = do
|
||||
state <- initialKernelState
|
||||
|
||||
-- Receive and reply to all messages on the shell socket.
|
||||
forever $ do
|
||||
interpret $ forever $ do
|
||||
-- Read the request from the request channel.
|
||||
request <- readChan $ shellRequestChannel interface
|
||||
request <- liftIO $ readChan $ shellRequestChannel interface
|
||||
|
||||
-- Create a header for the reply.
|
||||
replyHeader <- createReplyHeader (header request)
|
||||
replyHeader <- liftIO $ createReplyHeader (header request)
|
||||
|
||||
-- Create the reply, possibly modifying kernel state.
|
||||
reply <- modifyMVar state $ replyTo interface request replyHeader
|
||||
oldState <- liftIO $ takeMVar state
|
||||
(newState, reply) <- replyTo interface request replyHeader oldState
|
||||
liftIO $ putMVar state newState
|
||||
|
||||
-- Write the reply to the reply channel.
|
||||
writeChan (shellReplyChannel interface) reply
|
||||
liftIO $ writeChan (shellReplyChannel interface) reply
|
||||
|
||||
-- Initial kernel state.
|
||||
initialKernelState :: IO (MVar KernelState)
|
||||
initialKernelState = do
|
||||
interpreter <- makeInterpreter
|
||||
|
||||
initialKernelState =
|
||||
newMVar KernelState {
|
||||
getExecutionCounter = 1,
|
||||
getInterpreter = interpreter
|
||||
getExecutionCounter = 1
|
||||
}
|
||||
|
||||
-- | Duplicate a message header, giving it a new UUID and message type.
|
||||
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
|
||||
dupHeader :: MessageHeader -> MessageType -> Interpreter MessageHeader
|
||||
dupHeader header messageType = do
|
||||
uuid <- UUID.random
|
||||
uuid <- liftIO UUID.random
|
||||
|
||||
return header { messageId = uuid, msgType = messageType }
|
||||
|
||||
@ -75,13 +73,12 @@ createReplyHeader parent = do
|
||||
msgType = replyType $ msgType parent
|
||||
}
|
||||
|
||||
replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> IO (KernelState, Message)
|
||||
replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
|
||||
replyTo _ KernelInfoRequest{} replyHeader state = return (state, KernelInfoReply { header = replyHeader })
|
||||
|
||||
replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do
|
||||
let execCount = getExecutionCounter state
|
||||
interpreter = getInterpreter state
|
||||
send = writeChan $ iopubChannel interface
|
||||
send msg = liftIO $ writeChan (iopubChannel interface) msg
|
||||
|
||||
idleHeader <- dupHeader replyHeader StatusMessage
|
||||
send $ PublishStatus idleHeader Idle
|
||||
@ -89,7 +86,7 @@ replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do
|
||||
busyHeader <- dupHeader replyHeader StatusMessage
|
||||
send $ PublishStatus busyHeader Busy
|
||||
|
||||
outputs <- evaluate interpreter $ Chars.unpack code
|
||||
outputs <- evaluate $ Chars.unpack code
|
||||
|
||||
let isPlain (Display mime _) = mime == PlainText
|
||||
case find isPlain outputs of
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user