Can now run Haskell code!

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.*
+
   

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 "<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

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.

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
                            ]

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

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
   })

ghci.sh

@@ -0,0 +1 @@
+ghci -ghci-script ihaskell.ghci 2>&1

ihaskell.ghci

@@ -0,0 +1 @@
+:set prompt "+++GHCI_IHASKELL+++>"