diff --git a/IHaskell.cabal b/IHaskell.cabal index edf5285b..3d5f75b7 100644 --- a/IHaskell.cabal +++ b/IHaskell.cabal @@ -67,5 +67,7 @@ executable IHaskell bytestring ==0.10.*, transformers ==0.3.*, uuid ==1.2.*, - containers ==0.5.* + containers ==0.5.*, + process == 1.1.* + diff --git a/IHaskell/Eval/Evaluate.hs b/IHaskell/Eval/Evaluate.hs new file mode 100644 index 00000000..89950d4d --- /dev/null +++ b/IHaskell/Eval/Evaluate.hs @@ -0,0 +1,94 @@ +-- | This module exports all functions used for evaluation of IHaskell input. +module IHaskell.Eval.Evaluate ( + evaluate, Interpreter, makeInterpreter + ) where + +import ClassyPrelude +import Prelude(putChar) +import System.Process +import System.IO (hSetBuffering, BufferMode(..), hPutStr, hGetChar) +import Data.List.Utils +import Data.String.Utils +import Text.Printf + +import IHaskell.Types + +promptString :: String +promptString = "+++GHCI_IHASKELL+++>" + +data Interpreter = Interpreter { + inStream :: Handle, + outStream :: Handle, + errStream :: Handle, + ghciHandle :: ProcessHandle + } + +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 + + hSetBuffering input NoBuffering + hSetBuffering output NoBuffering + hSetBuffering errs NoBuffering + + 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 + +-- | 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 -> + concat <$> mapM (getResponse interpreter) (lines strippedCode) + +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 + + +parseOutput :: String -> [DisplayData] +parseOutput output + | startswith "" output = [Display MimeHtml $ makeError output] + | otherwise = [Display PlainText output] + +makeError :: String -> String +makeError output = + let _ : rest = words output in + printf "%s" $ unwords rest diff --git a/IHaskell/Message/Parser.hs b/IHaskell/Message/Parser.hs index e6766b21..524adaea 100644 --- a/IHaskell/Message/Parser.hs +++ b/IHaskell/Message/Parser.hs @@ -68,8 +68,8 @@ parser :: MessageType -- ^ The message type being parsed. -> LByteString -> Message -- The parser that converts the body into a message. -- This message should have an undefined -- header. -parser "kernel_info_request" = kernelInfoRequestParser -parser "execute_request" = executeRequestParser +parser KernelInfoRequestMessage = kernelInfoRequestParser +parser ExecuteRequestMessage = executeRequestParser parser other = error $ "Unknown message type " ++ show other -- | Parse a kernel info request. diff --git a/IHaskell/Message/Writer.hs b/IHaskell/Message/Writer.hs index 52a2b9f9..73a567f9 100644 --- a/IHaskell/Message/Writer.hs +++ b/IHaskell/Message/Writer.hs @@ -17,32 +17,31 @@ instance ToJSON Message where ] toJSON ExecuteReply{ status = status, executionCounter = counter} = object [ - "status" .= status, + "status" .= show status, "execution_count" .= counter, "payload" .= emptyList, "user_variables" .= emptyMap, "user_expressions" .= emptyMap ] - toJSON IopubStatus{ executionState = executionState } = object [ + toJSON PublishStatus{ executionState = executionState } = object [ "execution_state" .= executionState ] - toJSON IopubStream{ streamType = streamType, streamContent = content } = object [ + toJSON PublishStream{ streamType = streamType, streamContent = content } = object [ "data" .= content, "name" .= streamType ] - toJSON IopubDisplayData{ source = src, displayData = datas } = object [ + toJSON PublishDisplayData{ source = src, displayData = datas } = object [ "source" .= src, "metadata" .= object [], "data" .= object (map displayDataToJson datas) ] - toJSON IopubPythonOut{ executionCount = execCount, reprText = reprText } = object [ - "data" .= object ["text/plain" .= reprText, - "text/html" .= reprText], + toJSON PublishOutput{ executionCount = execCount, reprText = reprText } = object [ + "data" .= object ["text/plain" .= reprText], "execution_count" .= execCount, "metadata" .= object [] ] - toJSON IopubPythonIn{ executionCount = execCount, inCode = code } = object [ + toJSON PublishInput{ executionCount = execCount, inCode = code } = object [ "execution_count" .= execCount, "code" .= code ] diff --git a/IHaskell/Types.hs b/IHaskell/Types.hs index 04a5b10b..0847f09b 100644 --- a/IHaskell/Types.hs +++ b/IHaskell/Types.hs @@ -2,7 +2,7 @@ module IHaskell.Types ( Profile (..), Message (..), MessageHeader (..), - MessageType, + MessageType(..), Username, Metadata, Port, @@ -11,6 +11,7 @@ module IHaskell.Types ( StreamType(..), MimeType(..), DisplayData(..), + ExecuteReplyStatus(..), ) where import ClassyPrelude @@ -74,7 +75,7 @@ instance ToJSON MessageHeader where "msg_id" .= messageId header, "session" .= sessionId header, "username" .= username header, - "msg_type" .= msgType header + "msg_type" .= show (msgType header) ] -- | A username for the source of a message. @@ -83,8 +84,41 @@ type Username = ByteString -- | A metadata dictionary. type Metadata = Map ByteString ByteString --- | The type of a message, currently just a string. -type MessageType = ByteString +-- | The type of a message, corresponding to IPython message types. +data MessageType = KernelInfoReplyMessage + | KernelInfoRequestMessage + | ExecuteReplyMessage + | ExecuteRequestMessage + | StatusMessage + | StreamMessage + | DisplayDataMessage + | OutputMessage + | InputMessage + +instance Show MessageType where + show KernelInfoReplyMessage = "kernel_info_reply" + show KernelInfoRequestMessage = "kernel_info_request" + show ExecuteReplyMessage = "execute_reply" + show ExecuteRequestMessage = "execute_request" + show StatusMessage = "status" + show StreamMessage = "stream" + show DisplayDataMessage = "display_data" + show OutputMessage = "pyout" + show InputMessage = "pyin" + +instance FromJSON MessageType where + parseJSON (String s) = return $ case s of + "kernel_info_reply" -> KernelInfoReplyMessage + "kernel_info_request" -> KernelInfoRequestMessage + "execute_reply" -> ExecuteReplyMessage + "execute_request" -> ExecuteRequestMessage + "status" -> StatusMessage + "stream" -> StreamMessage + "display_data" -> DisplayDataMessage + "pyout" -> OutputMessage + "pyin" -> InputMessage + parseJSON _ = fail "Must be a string." + -- | A message used to communicate with the IPython frontend. data Message @@ -104,51 +138,61 @@ data Message getUserVariables :: [ByteString], -- ^ Unused. getUserExpressions :: [ByteString] -- ^ Unused. } + +-- | A reply to an execute request. | ExecuteReply { header :: MessageHeader, - status :: String, - executionCounter :: Int + status :: ExecuteReplyStatus, -- ^ The status of the output. + executionCounter :: Int -- ^ The execution count, i.e. which output this is. } - | IopubStatus { + | PublishStatus { header :: MessageHeader, - executionState :: ExecutionState + executionState :: ExecutionState -- ^ The execution state of the kernel. } - | IopubStream { + | PublishStream { header :: MessageHeader, - streamType :: StreamType, - streamContent :: String + streamType :: StreamType, -- ^ Which stream to publish to. + streamContent :: String -- ^ What to publish. } - | IopubDisplayData { + | PublishDisplayData { header :: MessageHeader, - source :: String, - displayData :: [DisplayData] + source :: String, -- ^ The name of the data source. + displayData :: [DisplayData] -- ^ A list of data representations. } - | IopubPythonOut { + | PublishOutput { header :: MessageHeader, - reprText :: String, - executionCount :: Int + reprText :: String, -- ^ Printed output text. + executionCount :: Int -- ^ Which output this is for. } - | IopubPythonIn { + | PublishInput { header :: MessageHeader, - inCode :: String, - executionCount :: Int + inCode :: String, -- ^ Submitted input code. + executionCount :: Int -- ^ Which input this is. } deriving Show +-- | Possible statuses in the execution reply messages. +data ExecuteReplyStatus = Ok | Err | Abort + +instance Show ExecuteReplyStatus where + show Ok = "ok" + show Err = "error" + show Abort = "abort" + -- | The execution state of the kernel. data ExecutionState = Busy | Idle | Starting deriving Show --- | Possible MIME types for the display data. -data MimeType = PlainText | MimeHtml - -- | Data for display: a string with associated MIME type. data DisplayData = Display MimeType String deriving Show +-- | Possible MIME types for the display data. +data MimeType = PlainText | MimeHtml deriving Eq + instance Show MimeType where show PlainText = "text/plain" show MimeHtml = "text/html" @@ -158,6 +202,6 @@ data StreamType = Stdin | Stdout deriving Show -- | Get the reply message type for a request message type. replyType :: MessageType -> MessageType -replyType "kernel_info_request" = "kernel_info_reply" -replyType "execute_request" = "execute_reply" -replyType messageType = error $ "Unknown message type " ++ show messageType +replyType KernelInfoRequestMessage = KernelInfoReplyMessage +replyType ExecuteRequestMessage = ExecuteReplyMessage +replyType messageType = error $ "No reply for message type " ++ show messageType diff --git a/Main.hs b/Main.hs index 2528eb85..454914c4 100644 --- a/Main.hs +++ b/Main.hs @@ -7,9 +7,12 @@ import qualified Data.Map as Map import IHaskell.Types import IHaskell.ZeroMQ import qualified IHaskell.Message.UUID as UUID +import IHaskell.Eval.Evaluate +import qualified Data.ByteString.Char8 as Chars data KernelState = KernelState { getExecutionCounter :: Int + , getInterpreter :: Interpreter } main :: IO () @@ -41,10 +44,21 @@ main = do -- Initial kernel state. initialKernelState :: IO (MVar KernelState) -initialKernelState = newMVar KernelState { - getExecutionCounter = 1 +initialKernelState = do + interpreter <- makeInterpreter + + newMVar KernelState { + getExecutionCounter = 1, + getInterpreter = interpreter } +-- | Duplicate a message header, giving it a new UUID and message type. +dupHeader :: MessageHeader -> MessageType -> IO MessageHeader +dupHeader header messageType = do + uuid <- UUID.random + + return header { messageId = uuid, msgType = messageType } + -- | Create a new message header, given a parent message header. createReplyHeader :: MessageHeader -> IO MessageHeader createReplyHeader parent = do @@ -64,60 +78,32 @@ createReplyHeader parent = do replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> IO (KernelState, Message) replyTo _ KernelInfoRequest{} replyHeader state = return (state, KernelInfoReply { header = replyHeader }) -replyTo interface ExecuteRequest{} replyHeader state = do - -- Queue up a response on the iopub socket - uuid1 : uuid2 : uuid3 : uuid4 : uuid5 : uuid6 : [] <- UUID.randoms 6 +replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do + let execCount = getExecutionCounter state + interpreter = getInterpreter state + send = writeChan $ iopubChannel interface - let header = MessageHeader { - identifiers = identifiers replyHeader, - parentHeader = parentHeader replyHeader, - metadata = Map.fromList [], - messageId = uuid1, - sessionId = sessionId replyHeader, - username = username replyHeader, - msgType = "status" - } - let busyHeader = header { messageId = uuid5 } - let statusMsg = IopubStatus { - header = header, - executionState = Idle - } - let busyMsg = IopubStatus { - header = busyHeader, - executionState = Busy - } - let streamHeader = MessageHeader { - identifiers = identifiers replyHeader, - parentHeader = parentHeader replyHeader, - metadata = Map.fromList [], - messageId = uuid2, - sessionId = sessionId replyHeader, - username = username replyHeader, - msgType = "stream" - } - let dispHeader = MessageHeader { - identifiers = identifiers replyHeader, - parentHeader = parentHeader replyHeader, - metadata = Map.fromList [], - messageId = uuid3, - sessionId = sessionId replyHeader, - username = username replyHeader, - msgType = "display_data" - } - let pyoutHeader = dispHeader { messageId = uuid4, msgType = "pyout" } - let pyinHeader = dispHeader { messageId = uuid6, msgType = "pyin" } + idleHeader <- dupHeader replyHeader StatusMessage + send $ PublishStatus idleHeader Idle - let things = "$a+b=c$" - let streamMsg = IopubStream streamHeader Stdout $ "Hello! " ++ show (getExecutionCounter state) - let displayMsg = IopubDisplayData dispHeader "haskell" [Display PlainText things, Display MimeHtml things] - pyoutMsg = IopubPythonOut pyoutHeader ("Iopub python out " ++ (show (getExecutionCounter state))) (getExecutionCounter state) - pyinMsg = IopubPythonIn pyinHeader "Who the fuck cares?!" (getExecutionCounter state) - mapM_ (writeChan $ iopubChannel interface) [pyinMsg, busyMsg, displayMsg, pyoutMsg, statusMsg] + busyHeader <- dupHeader replyHeader StatusMessage + send $ PublishStatus busyHeader Busy - let counter = getExecutionCounter state - newState = state { getExecutionCounter = getExecutionCounter state + 1 } + outputs <- evaluate interpreter $ Chars.unpack code + + let isPlain (Display mime _) = mime == PlainText + case find isPlain outputs of + Just (Display PlainText text) -> do + outHeader <- dupHeader replyHeader OutputMessage + send $ PublishOutput outHeader text execCount + Nothing -> return () + + displayHeader <- dupHeader replyHeader DisplayDataMessage + send $ PublishDisplayData displayHeader "haskell" $ filter (not . isPlain) outputs + + let newState = state { getExecutionCounter = execCount + 1 } return (newState, ExecuteReply { header = replyHeader, - executionCounter = counter, - status = "ok" + executionCounter = execCount, + status = Ok }) diff --git a/ghci.sh b/ghci.sh new file mode 100755 index 00000000..1e79fbe0 --- /dev/null +++ b/ghci.sh @@ -0,0 +1 @@ +ghci -ghci-script ihaskell.ghci 2>&1 diff --git a/ihaskell.ghci b/ihaskell.ghci new file mode 100644 index 00000000..5a2a54fe --- /dev/null +++ b/ihaskell.ghci @@ -0,0 +1 @@ +:set prompt "+++GHCI_IHASKELL+++>"