packages feed

ipython-kernel 0.1.0.0 → 0.3.0.0

raw patch · 18 files changed

+1709/−1058 lines, 18 filesdep +directorydep +filepathdep +ipython-kerneldep ~aesondep ~basedep ~cerealnew-component:exe:simple-calc-examplebinary-added

Dependencies added: directory, filepath, ipython-kernel, mtl, parsec, tar, transformers

Dependency ranges changed: aeson, base, cereal

Files

+ example-data/calc_profile.tar view

binary file changed (absent → 168448 bytes)

+ examples/Calc.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, MultiWayIf #-}+module Main where++import Control.Applicative+import Control.Arrow++import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay)+import Control.Monad (guard)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.State.Strict (StateT, get, modify, runStateT)++import Data.Char (isDigit)+import Data.List (isPrefixOf)+import Data.Monoid ((<>))+import qualified Data.Text as T++import IHaskell.IPython.Kernel+import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..))++import System.Environment (getArgs)+import System.FilePath ((</>))++import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, runParser, (<?>))+import qualified Text.Parsec.Token as P++import qualified Paths_ipython_kernel as Paths++---------------------------------------------------------+--  Hutton's Razor, plus time delays, plus a global state+---------------------------------------------------------++-- | This language is Hutton's Razor with two added operations that+-- are needed to demonstrate the kernel features: a global state,+-- accessed and modified using Count, and a sleep operation.+data Razor = I Integer+           | Plus Razor Razor+           | SleepThen Double Razor+           | Count+  deriving (Read, Show, Eq)+++---------+-- Parser+---------++razorDef :: Monad m => P.GenLanguageDef String a m+razorDef = P.LanguageDef+  { P.commentStart    = "(*"+  , P.commentEnd      = "*)"+  , P.commentLine     = "//"+  , P.nestedComments  = True+  , P.identStart      = letter <|> char '_'+  , P.identLetter     = alphaNum <|> char '_'+  , P.opStart         = oneOf "+"+  , P.opLetter        = oneOf "+"+  , P.reservedNames   = ["sleep", "then", "end", "count"]+  , P.reservedOpNames = []+  , P.caseSensitive   = True+  }++lexer :: Monad m => P.GenTokenParser String a m+lexer = P.makeTokenParser razorDef++parens :: Parsec String a b -> Parsec String a b+parens = P.parens lexer++reserved :: String -> Parsec String a ()+reserved = P.reserved lexer++integer :: Parsec String a Integer+integer = P.integer lexer++float :: Parsec String a Double+float = P.float lexer++operator :: Parsec String a String+operator = P.operator lexer++keyword :: String -> Parsec String a ()+keyword kwd = reserved kwd <?> "the keyword \"" ++ kwd ++ "\""++literal :: Parsec String a Razor+literal = I <$> integer++sleepThen :: Parsec String a Razor+sleepThen = do keyword "sleep"+               delay <- float <?> "seconds"+               keyword "then"+               body <- expr+               keyword "end" <?> ""+               return $ SleepThen delay body++count :: Parsec String a Razor+count = keyword "count" >> return Count++expr :: Parsec String a Razor+expr = do one <- parens expr <|> literal <|> sleepThen <|> count+          rest <- optionMaybe (do op <- operator+                                  guard (op == "+")+                                  expr)+          case rest of+            Nothing -> return one+            Just other -> return $ Plus one other++parse :: String -> Either ParseError Razor+parse = runParser expr () "(input)"+++----------------------+-- Language operations+----------------------++-- | Completion+langCompletion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)+langCompletion _code line col =+  let (before, _) = T.splitAt col line+  in fmap (\word -> (map T.pack . matchesFor $ T.unpack word, word, word))+          (lastMaybe (T.words before))+  where+    lastMaybe :: [a] -> Maybe a+    lastMaybe [] = Nothing+    lastMaybe [x] = Just x+    lastMaybe (_:xs) = lastMaybe xs+    matchesFor :: String -> [String]+    matchesFor input = filter (isPrefixOf input) available+    available = ["sleep", "then", "end", "count"] ++ map show [(-1000::Int)..1000]++-- | Documentation lookup+langInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)+langInfo obj =+  if | any (T.isPrefixOf obj) ["sleep", "then", "end"] ->+       Just (obj, sleepDocs, sleepType)+     | T.isPrefixOf obj "count" ->+       Just (obj, countDocs, countType)+     | obj == "+" -> Just (obj, plusDocs, plusType)+     | T.all isDigit obj -> Just (obj, intDocs obj, intType)+     | [x, y] <- T.splitOn "." obj,+       T.all isDigit x,+       T.all isDigit y -> Just (obj, floatDocs obj, floatType)+     | otherwise -> Nothing+  where+    sleepDocs    = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE"+    sleepType    = "sleep FLOAT then INT end"+    plusDocs     = "Perform addition"+    plusType     = "INT + INT"+    intDocs i    = "The integer " <> i+    intType      = "INT"+    floatDocs f  = "The floating point value " <> f+    floatType    = "FLOAT"+    countDocs    = "Increment and return the current counter"+    countType    = "INT"++-- | Messages sent to the frontend during evaluation will be lists of trace elements+data IntermediateEvalRes = Got Razor Integer+                         | Waiting Double+  deriving Show++-- | Cons for lists of trace elements - in this case, "sleeping"+-- messages should replace old ones to create a countdown effect.+consRes :: IntermediateEvalRes -> [IntermediateEvalRes] -> [IntermediateEvalRes]+consRes r@(Waiting _) (Waiting _ : s) = r:s+consRes r s = r:s++-- | Execute an expression.+execRazor :: MVar Integer -- ^ The global counter state+          -> Razor -- ^ The term to execute+          -> IO () -- ^ Callback to clear output so far+          -> ([IntermediateEvalRes] -> IO ()) -- ^ Callback for intermediate results+          -> StateT ([IntermediateEvalRes], T.Text) IO Integer+execRazor _ x@(I i) _ _ =+  modify (second (<> (T.pack (show x)))) >> return i+execRazor val tm@(Plus x y) clear send =+   do modify (second (<> (T.pack (show tm))))+      x' <- execRazor val x clear send+      modify (first $ consRes (Got x x'))+      sendState+      y' <- execRazor val y clear send+      modify (first $ consRes (Got y y'))+      sendState+      let res = x' + y'+      modify (first $ consRes (Got tm res))+      sendState+      return res+  where sendState = liftIO clear >> fst <$> get >>= liftIO . send+execRazor val (SleepThen delay body) clear send+  | delay <= 0.0 = execRazor val body clear send+  | delay >  0.1 = do modify (first $ consRes (Waiting delay))+                      sendState+                      liftIO $ threadDelay 100000+                      execRazor val (SleepThen (delay - 0.1) body) clear send+  | otherwise = do modify (first $ consRes (Waiting 0))+                   sendState+                   liftIO $ threadDelay (floor (delay * 1000000))+                   execRazor val body clear send+  where sendState = liftIO clear >> fst <$> get >>= liftIO . send+execRazor val Count clear send = do+  i <- liftIO $ takeMVar val+  modify (first $ consRes (Got Count i))+  sendState+  liftIO $ putMVar val (i+1)+  return i++  where sendState = liftIO clear >> fst <$> get >>= liftIO . send++-- | Generate a language configuration for some initial state+mkConfig :: MVar Integer -- ^ The internal state of the execution+         -> KernelConfig IO [IntermediateEvalRes] (Either ParseError Integer)+mkConfig var = KernelConfig+  { languageName     = "expanded_huttons_razor"+  , languageVersion  = [0,1,0]+  , profileSource    = Just . (</> "calc_profile.tar") <$> Paths.getDataDir+  , displayResult    = displayRes+  , displayOutput    = displayOut+  , completion       = langCompletion+  , objectInfo       = langInfo+  , run              = parseAndRun+  , debug            = False+  }+  where+    displayRes (Left err) =+      [ DisplayData MimeHtml . T.pack $ "<em>" ++ show err ++ "</em>"+      , DisplayData PlainText . T.pack $ show err+      ]+    displayRes (Right x) =+      return . DisplayData MimeHtml . T.pack $+        "Answer: <strong>" ++ show x ++ "</strong>"+    displayOut out =+      let outLines = reverse (map (T.pack . show) out)+      in return (DisplayData PlainText (T.unlines outLines))+    parseAndRun code clear send =+      case parse (T.unpack code) of+        Left err -> return (Left err, Err, "")+        Right tm -> do+          (res, (_, pager)) <- runStateT (execRazor var tm clear send) ([], "")+          return (Right res, Ok, T.unpack pager)++main :: IO ()+main = do args <- getArgs+          val <- newMVar 1+          case args of+            ["kernel", profileFile] ->+              easyKernel profileFile (mkConfig val)+            ["setup"] -> do+              putStrLn "Installing profile..."+              installProfile (mkConfig val)+            _ -> do+              putStrLn "Usage:"+              putStrLn "simple-calc-example setup        -- set up the profile"+              putStrLn "simple-calc-example kernel FILE  -- run a kernel with FILE for communication with the frontend"
ipython-kernel.cabal view
@@ -1,5 +1,5 @@ name:                ipython-kernel-version:             0.1.0.0+version:             0.3.0.0 synopsis:            A library for creating kernels for IPython frontends  description:         ipython-kernel is a library for communicating with frontends for the interactive IPython framework. It is used extensively in IHaskell, the interactive Haskell environment.@@ -14,24 +14,55 @@  cabal-version:       >=1.16 +data-dir:            example-data+data-files:          calc_profile.tar+++flag examples+  description: Build example programs+  default:     False++ library-  exposed-modules:     IPython.Kernel-                       IPython.Types-                       IPython.ZeroMQ-                       IPython.Stdin-                       IPython.Message.Writer-                       IPython.Message.Parser-                       IPython.Message.UUID+  exposed-modules: IHaskell.IPython.Kernel+                   IHaskell.IPython.Types+                   IHaskell.IPython.ZeroMQ+                   IHaskell.IPython.Stdin+                   IHaskell.IPython.Message.Writer+                   IHaskell.IPython.Message.Parser+                   IHaskell.IPython.Message.UUID+                   IHaskell.IPython.EasyKernel   -- other-modules:          other-extensions:    OverloadedStrings   hs-source-dirs:      src   default-language:    Haskell2010-  build-depends:       base            >=4.6 && <4.7,-                       aeson           >=0.6 && <0.7,+  build-depends:       base            >=4.6 && < 4.8,+                       aeson           >=0.6 && < 0.9,                        bytestring      >=0.10,-                       cereal          ==0.3.*,+                       cereal          >=0.3,                        containers      >=0.5,+                       directory       >=1.1,+                       filepath        >=1.2,+                       mtl             >=2.1,+                       tar             >=0.4.0.1,                        text            >=0.11,+                       transformers    >=0.3,                        unix            >=2.6,                        uuid            >=1.3,                        zeromq4-haskell >=0.1+++-- Example program+executable simple-calc-example+  hs-source-dirs: examples+  main-is:        Calc.hs+  build-depends:  ipython-kernel,+                  base           >=4.6 && <4.8,+                  filepath       >=1.2,+                  mtl            >=2.1,+                  parsec         >=3.1,+                  text           >=0.11,+                  transformers   >=0.3+                  +  if !flag(examples)+    buildable: False
+ src/IHaskell/IPython/EasyKernel.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Description : Easy IPython kernels+-- = Overview+-- This module provides automation for writing simple IPython+-- kernels. In particular, it provides a record type that defines+-- configurations and a function that interprets a configuration as an+-- action in some monad that can do IO.+--+-- The configuration consists primarily of functions that implement+-- the various features of a kernel, such as running code, looking up+-- documentation, and performing completion. An example for a simple+-- language that nevertheless has side effects, global state, and+-- timing effects is included in the examples directory.+--+-- = Profiles+-- To run your kernel, you will need an IPython profile that causes+-- the frontend to run it. To generate a fresh profile, run the command+--+-- > ipython profile create NAME+--+-- This will create a fresh IPython profile in @~\/.ipython\/profile_NAME@.+-- This profile must be modified in two ways:+--+-- 1. It needs to run your kernel instead of the default ipython+-- 2. It must have message signing turned off, because 'easyKernel' doesn't support it+--+-- == Setting the executable+-- To set the executable, modify the configuration object's+-- @KernelManager.kernel_cmd@ property. For example:+--+-- > c.KernelManager.kernel_cmd = ['my_kernel', '{connection_file}']+--+-- Your own main should arrange to parse command line arguments such+-- that the connection file is passed to easyKernel.+--+-- == Message signing+-- To turn off message signing, use the following snippet:+--+-- > c.Session.key = b''+-- > c.Session.keyfile = b''+--+-- == Further profile improvements+-- Consult the IPython documentation along with the generated profile+-- source code for further configuration of the frontend, including+-- syntax highlighting, logos, help text, and so forth.++module IHaskell.IPython.EasyKernel (easyKernel, installProfile, KernelConfig(..)) where++import Data.Aeson (decode)++import qualified Data.ByteString.Lazy as BL++import qualified Codec.Archive.Tar as Tar++import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (forever, when)++import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T++import IHaskell.IPython.Kernel+import IHaskell.IPython.Message.UUID as UUID++import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory)+import System.FilePath ((</>))+import System.Exit (exitSuccess)+import System.IO (openFile, IOMode(ReadMode))++-- | The kernel configuration specifies the behavior that is specific+-- to your language. The type parameters provide the monad in which+-- your kernel will run, the type of intermediate outputs from running+-- cells, and the type of final results of cells, respectively.+data KernelConfig m output result = KernelConfig+  { languageName :: String+     -- ^ The name of the language. This field is used to calculate+     -- the name of the profile, so it should contain characters that+     -- are reasonable to have in file names.+  , languageVersion :: [Int] -- ^ The version of the language+  , profileSource ::  IO (Maybe FilePath)+    -- ^ Determine the source of a profile to install using+    -- 'installProfile'. The source should be a tarball whose contents+    -- will be unpacked directly into the profile directory. For+    -- example, the file whose name is @ipython_config.py@ in the+    -- tar file for a language named @lang@ will end up in+    -- @~/.ipython/profile_lang/ipython_config.py@.+  , displayOutput :: output -> [DisplayData] -- ^ How to render intermediate output+  , displayResult :: result -> [DisplayData] -- ^ How to render final cell results+  , completion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text) +  -- ^ Perform completion. The returned tuple consists of the matches,+  -- the matched text, and the completion text. The arguments are the+  -- code in the cell, the current line as text, and the column at+  -- which the cursor is placed.+  , objectInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)+  -- ^ Return the information or documentation for its argument. The+  -- returned tuple consists of the name, the documentation, and the+  -- type, respectively.+  , run :: T.Text -> IO () -> (output -> IO ()) -> m (result, ExecuteReplyStatus, String)+  -- ^ Execute a cell. The arguments are the contents of the cell, an+  -- IO action that will clear the current intermediate output, and an+  -- IO action that will add a new item to the intermediate+  -- output. The result consists of the actual result, the status to+  -- be sent to IPython, and the contents of the pager. Return the+  -- empty string to indicate that there is no pager output. Errors+  -- should be handled by defining an appropriate error constructor in+  -- your result type.+  , debug :: Bool -- ^ Whether to print extra debugging information to+                  -- the console+  }++-- | Attempt to install the IPython profile from the .tar file+-- indicated by the 'profileSource' field of the configuration, if it+-- is not already installed.+installProfile :: MonadIO m => KernelConfig m output result -> m ()+installProfile config = do+  installed <- isInstalled+  when (not installed) $ do+    profSrc <- liftIO $ profileSource config+    case profSrc of+      Nothing -> liftIO (putStrLn "No IPython profile is installed or specified")+      Just tar -> do+        profExists <- liftIO $ doesFileExist tar+        profTgt <- profDir+        if profExists+           then do liftIO $ createDirectoryIfMissing True profTgt+                   liftIO $ Tar.extract profTgt tar+           else liftIO . putStrLn $+                  "The supplied profile source '" ++ tar ++ "' does not exist"++  where+    profDir = do+      home <- liftIO getHomeDirectory+      return $ home </> ".ipython" </> ("profile_" ++ languageName config)+    isInstalled = do+      prof <- profDir+      dirThere <- liftIO $ doesDirectoryExist prof+      isProf <- liftIO . doesFileExist $ prof </> "ipython_config.py"+      return $ dirThere && isProf++getProfile :: FilePath -> IO Profile+getProfile fn = do+  profData <- openFile fn ReadMode >>= BL.hGetContents+  case decode profData of+    Just prof -> return prof+    Nothing   -> error "Invalid profile data"++createReplyHeader :: MonadIO m => MessageHeader -> m MessageHeader+createReplyHeader parent = do+  -- Generate a new message UUID.+  newMessageId <- liftIO UUID.random+  let repType = fromMaybe err (replyType $ msgType parent)+      err = error $ "No reply for message " ++ show (msgType parent)++  return MessageHeader {+    identifiers = identifiers parent,+    parentHeader = Just parent,+    metadata = Map.fromList [],+    messageId = newMessageId,+    sessionId = sessionId parent,+    username = username parent,+    msgType = repType+  }++++-- | Execute an IPython kernel for a config. Your 'main' action should+-- call this as the last thing it does.+easyKernel :: (MonadIO m)+           => FilePath -- ^ The connection file provided by the IPython frontend+           -> KernelConfig m output result -- ^ The kernel configuration specifying how to react to messages+           -> m ()+easyKernel profileFile config = do+  prof <- liftIO $ getProfile profileFile+  zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan) <-+    liftIO $ serveProfile prof+  execCount <- liftIO $ newMVar 0+  forever $ do+    req <- liftIO $ readChan shellReqChan+    repHeader <- createReplyHeader (header req)+    when (debug config) . liftIO $ print req+    reply <- replyTo config execCount zmq req repHeader+    liftIO $ writeChan shellRepChan reply+++replyTo :: MonadIO m+        => KernelConfig m output result+        -> MVar Integer+        -> ZeroMQInterface+        -> Message+        -> MessageHeader+        -> m Message+replyTo config _ _ KernelInfoRequest{} replyHeader =+  return KernelInfoReply+           { header = replyHeader+           , language = languageName config+           , versionList = languageVersion config+           }+replyTo config _ interface ShutdownRequest{restartPending=pending} replyHeader = do+  liftIO $ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending+  liftIO exitSuccess++replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHeader = do+  let send msg = writeChan (iopubChannel interface) msg++  busyHeader <- dupHeader replyHeader StatusMessage+  liftIO . send $ PublishStatus busyHeader Busy++  outputHeader <- dupHeader replyHeader DisplayDataMessage+  (res, replyStatus, pagerOut) <-+    let clearOutput = do+          clearHeader <- dupHeader replyHeader ClearOutputMessage+          send $ ClearOutput clearHeader False+        sendOutput x =+          send $ PublishDisplayData outputHeader (languageName config)+                   (displayOutput config x)+    in run config code clearOutput sendOutput+  liftIO . send $ PublishDisplayData outputHeader (languageName config) (displayResult config res)+++  idleHeader <- dupHeader replyHeader StatusMessage+  liftIO . send $ PublishStatus idleHeader Idle++  liftIO $ modifyMVar_ execCount (return . (+1))+  counter <- liftIO $ readMVar execCount++  return ExecuteReply+           { header = replyHeader+           , pagerOutput = pagerOut+           , executionCounter = fromIntegral counter+           , status = replyStatus+           }++replyTo config _ _ req@CompleteRequest{} replyHeader = do+  let code = getCode req+      line = getCodeLine req+      col = getCursorPos req++  return $ case completion config code line col of+             Nothing ->+               CompleteReply+                 { header = replyHeader+                 , completionMatches = []+                 , completionMatchedText = ""+                 , completionText = ""+                 , completionStatus = False+                 }+             Just (matches, matchedText, cmplText) ->+               CompleteReply+                 { header = replyHeader+                 , completionMatches = matches+                 , completionMatchedText = matchedText+                 , completionText = cmplText+                 , completionStatus = True+                 }++replyTo config _ _ ObjectInfoRequest { objectName = obj } replyHeader =+  return $ case objectInfo config obj of+             Just (name, docs, ty) -> ObjectInfoReply+               { header = replyHeader+               , objectName = obj+               , objectFound = True+               , objectTypeString = ty+               , objectDocString = docs+               }+             Nothing -> ObjectInfoReply+               { header = replyHeader+               , objectName = obj+               , objectFound = False+               , objectTypeString = ""+               , objectDocString = ""+               }++replyTo _ _ _ msg _ = do+  liftIO $ putStrLn "Unknown message: "+  liftIO $ print msg+  return msg+++dupHeader :: MonadIO m => MessageHeader -> MessageType -> m MessageHeader+dupHeader hdr mtype =+  do uuid <- liftIO UUID.random+     return hdr { messageId = uuid , msgType = mtype }
+ src/IHaskell/IPython/Kernel.hs view
@@ -0,0 +1,16 @@+-- | This module exports all the types and functions necessary to create an+-- IPython language kernel that supports the @ipython console@ and @ipython+-- notebook@ frontends. +module IHaskell.IPython.Kernel (+  module IHaskell.IPython.Types,+  module IHaskell.IPython.Message.Writer,+  module IHaskell.IPython.Message.Parser,+  module IHaskell.IPython.Message.UUID,+  module IHaskell.IPython.ZeroMQ,+  ) where++import IHaskell.IPython.Types+import IHaskell.IPython.Message.Writer+import IHaskell.IPython.Message.Parser+import IHaskell.IPython.Message.UUID+import IHaskell.IPython.ZeroMQ
+ src/IHaskell/IPython/Message/Parser.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Description : Parsing messages received from IPython+--+-- This module is responsible for converting from low-level ByteStrings+-- obtained from the 0MQ sockets into Messages. The only exposed function is+-- `parseMessage`, which should only be used in the low-level 0MQ interface.+module IHaskell.IPython.Message.Parser (parseMessage) where++import            Data.Aeson            ((.:), decode, Result(..), Object)+import            Control.Applicative   ((<|>))+import            Data.Aeson.Types      (parse)+import            Data.ByteString+import            Data.Map              (Map)+import            Data.Text             (Text)++import qualified  Data.ByteString.Lazy as Lazy++import IHaskell.IPython.Types++type LByteString = Lazy.ByteString++----- External interface -----++-- | Parse a message from its ByteString components into a Message.+parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message.+              -> ByteString   -- ^ The header data.+              -> ByteString   -- ^ The parent header, which is just "{}" if there is no header.+              -> ByteString   -- ^ The metadata map, also "{}" for an empty map.+              -> ByteString   -- ^ The message content.+              -> Message      -- ^ A parsed message.+parseMessage idents headerData parentHeader metadata content = +  let header = parseHeader idents headerData parentHeader metadata+      messageType = msgType header+      messageWithoutHeader = parser messageType $ Lazy.fromStrict content in+    messageWithoutHeader { header = header }++----- Module internals -----++-- | Parse a header from its ByteString components into a MessageHeader.+parseHeader :: [ByteString]  -- ^ The list of identifiers.+            -> ByteString    -- ^ The header data.+            -> ByteString    -- ^ The parent header, or "{}" for Nothing.+            -> ByteString    -- ^ The metadata, or "{}" for an empty map.+            -> MessageHeader -- The resulting message header.+parseHeader idents headerData parentHeader metadata = MessageHeader {+  identifiers = idents,+  parentHeader = parentResult,+  metadata = metadataMap,+  messageId = messageUUID,+  sessionId = sessionUUID,+  username = username,+  msgType = messageType+  } where+      -- Decode the header data and the parent header data into JSON objects.+      -- If the parent header data is absent, just have Nothing instead.+      Just result = decode $ Lazy.fromStrict headerData :: Maybe Object+      parentResult = if parentHeader == "{}"+                     then Nothing+                     else Just $ parseHeader idents parentHeader "{}" metadata++      -- Get the basic fields from the header.+      Success (messageType, username, messageUUID, sessionUUID) = flip parse result $ \obj -> do +        messType <- obj .: "msg_type"+        username <- obj .: "username"+        message <- obj .: "msg_id"+        session <- obj .: "session"+        return (messType, username, message, session)++      -- Get metadata as a simple map.+      Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map Text Text)++noHeader :: MessageHeader+noHeader = error "No header created"++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 KernelInfoRequestMessage  = kernelInfoRequestParser+parser ExecuteRequestMessage     = executeRequestParser+parser CompleteRequestMessage    = completeRequestParser+parser ObjectInfoRequestMessage  = objectInfoRequestParser+parser ShutdownRequestMessage    = shutdownRequestParser+parser InputReplyMessage         = inputReplyParser+parser CommOpenMessage           = commOpenParser+parser CommDataMessage           = commDataParser+parser CommCloseMessage          = commCloseParser+parser other = error $ "Unknown message type " ++ show other++-- | Parse a kernel info request.+-- A kernel info request has no auxiliary information, so ignore the body.+kernelInfoRequestParser :: LByteString -> Message+kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader }++-- | Parse an execute request.+-- Fields used are:+--  1. "code": the code to execute.+--  2. "silent": whether to execute silently.+--  3. "store_history": whether to include this in history.+--  4. "allow_stdin": whether to allow reading from stdin for this code.+executeRequestParser :: LByteString -> Message+executeRequestParser content = +  let parser obj = do+        code <- obj .: "code"+        silent <- obj .: "silent"+        storeHistory <- obj .: "store_history"+        allowStdin <- obj .: "allow_stdin"++        return (code, silent, storeHistory, allowStdin)+      Just decoded = decode content+      Success (code, silent, storeHistory, allowStdin) = parse parser decoded in+    ExecuteRequest {+      header = noHeader,+      getCode = code,+      getSilent = silent,+      getAllowStdin = allowStdin,+      getStoreHistory = storeHistory,+      getUserVariables = [],+      getUserExpressions = []+    }++completeRequestParser :: LByteString -> Message+completeRequestParser content = parsed+  where+  Success parsed = flip parse decoded $ \ obj -> do+        code     <- obj .: "block" <|> return ""+        codeLine <- obj .: "line"+        pos      <- obj .: "cursor_pos"+        return $ CompleteRequest noHeader code codeLine pos++  Just decoded = decode content++objectInfoRequestParser :: LByteString -> Message+objectInfoRequestParser content = parsed+  where+    Success parsed = flip parse decoded $ \obj -> do+      oname <- obj .: "oname"+      dlevel <- obj .: "detail_level"+      return $ ObjectInfoRequest noHeader oname dlevel++    Just decoded = decode content+++shutdownRequestParser :: LByteString -> Message+shutdownRequestParser content = parsed+  where+  Success parsed = flip parse decoded $ \ obj -> do+        code     <- obj .: "restart"+        return $ ShutdownRequest noHeader code++  Just decoded = decode content++inputReplyParser :: LByteString -> Message+inputReplyParser content = parsed+  where+  Success parsed = flip parse decoded $ \ obj -> do+        value <- obj .: "value"+        return $ InputReply noHeader value++  Just decoded = decode content++commOpenParser :: LByteString -> Message+commOpenParser content = parsed+  where+  Success parsed = flip parse decoded $ \ obj -> do+        uuid <- obj .: "comm_id"+        name <- obj .: "target_name"+        value <- obj .: "data"+        return $ CommOpen noHeader name uuid value++  Just decoded = decode content++commDataParser :: LByteString -> Message+commDataParser content = parsed+  where+  Success parsed = flip parse decoded $ \ obj -> do+        uuid <- obj .: "comm_id"+        value <- obj .: "data"+        return $ CommData noHeader uuid value++  Just decoded = decode content++commCloseParser :: LByteString -> Message+commCloseParser content = parsed+  where+  Success parsed = flip parse decoded $ \ obj -> do+        uuid <- obj .: "comm_id"+        value <- obj .: "data"+        return $ CommClose noHeader uuid value++  Just decoded = decode content
+ src/IHaskell/IPython/Message/UUID.hs view
@@ -0,0 +1,43 @@+-- | Description : UUID generator and data structure+--+-- Generate, parse, and pretty print UUIDs for use with IPython.+module IHaskell.IPython.Message.UUID (+  UUID,+  random, randoms,+  ) where++import Control.Monad (mzero, replicateM)+import Control.Applicative ((<$>))+import Data.Text (pack)+import Data.Aeson+import Data.UUID.V4 (nextRandom)++-- We use an internal string representation because for the purposes of+-- IPython, it matters whether the letters are uppercase or lowercase and+-- whether the dashes are present in the correct locations. For the+-- purposes of new UUIDs, it does not matter, but IPython expects UUIDs+-- passed to kernels to be returned unchanged, so we cannot actually parse+-- them.++-- | A UUID (universally unique identifier).+data UUID = UUID String deriving (Show, Read, Eq, Ord)++-- | Generate a list of random UUIDs.+randoms :: Int      -- ^ Number of UUIDs to generate.+        -> IO [UUID]+randoms n = replicateM n random++-- | Generate a single random UUID.+random :: IO UUID+random = UUID <$> show <$> nextRandom++-- Allows reading and writing UUIDs as Strings in JSON. +instance FromJSON UUID where+  parseJSON val@(String _) = UUID <$> parseJSON val++  -- UUIDs must be Strings.+  parseJSON _ = mzero++instance ToJSON UUID where+  -- Extract the string from the UUID.+  toJSON (UUID str) = String $ pack str
+ src/IHaskell/IPython/Message/Writer.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Description : @ToJSON@ for Messages+--+-- This module contains the @ToJSON@ instance for @Message@.+module IHaskell.IPython.Message.Writer (+  ToJSON(..)+)  where++import Data.Aeson+import Data.Map     (Map)+import Data.Text    (Text, pack)+import Data.Monoid  (mempty)++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import Data.Text.Encoding++import IHaskell.IPython.Types++-- Convert message bodies into JSON.+instance ToJSON Message where+  toJSON KernelInfoReply{ versionList = vers, language = language } = object [+                             "protocol_version" .= ints [4, 0], -- current protocol version, major and minor+                             "language_version" .= vers,+                             "language" .= language+                           ]++  toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [+                             "status" .= show status,+                             "execution_count" .= counter,+                             "payload" .= +                               if null pager+                               then []+                               else [object [+                                    "source" .= string "page",+                                    "text" .= pager+                                ]],+                             "user_variables" .= emptyMap,+                             "user_expressions" .= emptyMap+                           ]+  toJSON PublishStatus{ executionState = executionState } = object [+                             "execution_state" .= executionState+                           ]+  toJSON PublishStream{ streamType = streamType, streamContent = content } = object [+                             "data" .= content,+                             "name" .= streamType+                           ]+  toJSON PublishDisplayData{ source = src, displayData = datas } = object [+                             "source" .= src,+                             "metadata" .= object [],+                             "data" .= object  (map displayDataToJson datas)+                           ]++  toJSON PublishOutput{ executionCount = execCount, reprText = reprText } = object [+                             "data" .= object ["text/plain" .= reprText],+                             "execution_count" .= execCount,+                             "metadata" .= object []+                           ]+  toJSON PublishInput{ executionCount = execCount, inCode = code } = object [+                             "execution_count" .= execCount,+                             "code" .= code+                           ]+  toJSON (CompleteReply _ m mt t s) = object [+                             "matches" .= m,+                             "matched_text" .= mt,+                             "text" .= t,+                             "status" .= if s then string "ok" else "error"+                           ]+  toJSON o@ObjectInfoReply{} = object [+                            "oname" .= objectName o,+                            "found" .= objectFound o,+                            "ismagic" .= False,+                            "isalias" .= False,+                            "type_name" .= objectTypeString o,+                            "docstring" .= objectDocString o+                           ]++  toJSON ShutdownReply{restartPending = restart} = object [+                            "restart" .= restart+                           ]++  toJSON ClearOutput{wait = wait} = object [+                            "wait" .= wait+                           ]++  toJSON RequestInput{inputPrompt = prompt} = object [+                            "prompt" .= prompt+                           ]++  toJSON req@CommOpen{} = object [+                            "comm_id" .= commUuid req,+                            "target_name" .= commTargetName req,+                            "data" .= commData req+                           ]++  toJSON req@CommData{} = object [+                            "comm_id" .= commUuid req,+                            "data" .= commData req+                           ]++  toJSON req@CommClose{} = object [+                            "comm_id" .= commUuid req,+                            "data" .= commData req+                           ]++  toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body+++-- | Print an execution state as "busy", "idle", or "starting".+instance ToJSON ExecutionState where+    toJSON Busy = String "busy"+    toJSON Idle = String "idle"+    toJSON Starting = String "starting"++-- | Print a stream as "stdin" or "stdout" strings.+instance ToJSON StreamType where+    toJSON Stdin = String "stdin"+    toJSON Stdout = String "stdout"++-- | Convert a MIME type and value into a JSON dictionary pair.+displayDataToJson :: DisplayData -> (Text, Value) +displayDataToJson (DisplayData mimeType dataStr) =+    pack (show mimeType) .= String dataStr++----- Constants -----++emptyMap :: Map String String+emptyMap = mempty++emptyList :: [Int]+emptyList = []++ints :: [Int] -> [Int]+ints = id++string :: String -> String+string = id
+ src/IHaskell/IPython/Stdin.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}+-- | This module provides a way in which the Haskell standard input may be+-- forwarded to the IPython frontend and thus allows the notebook to use+-- the standard input.+--+-- This relies on the implementation of file handles in GHC, and is+-- generally unsafe and terrible. However, it is difficult to find another+-- way to do it, as file handles are generally meant to point to streams+-- and files, and not networked communication protocols.+--+-- In order to use this module, it must first be initialized with two+-- things. First of all, in order to know how to communicate with the+-- IPython frontend, it must know the kernel profile used for+-- communication. For this, use @recordKernelProfile@ once the profile is+-- known. Both this and @recordParentHeader@ take a directory name where+-- they can store this data.+--+-- Finally, the module must know what @execute_request@ message is+-- currently being replied to (which will request the input). Thus, every+-- time the language kernel receives an @execute_request@ message, it+-- should inform this module via @recordParentHeader@, so that the module+-- may generate messages with an appropriate parent header set. If this is+-- not done, the IPython frontends will not recognize the target of the+-- communication.+--+-- Finally, in order to activate this module, @fixStdin@ must be called+-- once. It must be passed the same directory name as @recordParentHeader@+-- and @recordKernelProfile@. Note that if this is being used from within+-- the GHC API, @fixStdin@ /must/ be called from within the GHC session+-- not from the host code.+module IHaskell.IPython.Stdin (+  fixStdin,+  recordParentHeader,+  recordKernelProfile+  ) where++import            Control.Concurrent          +import            Control.Applicative         ((<$>))+import            Control.Concurrent.Chan+import            Control.Monad+import            GHC.IO.Handle+import            GHC.IO.Handle.Types+import            System.IO+import            System.Posix.IO+import            System.IO.Unsafe+import qualified  Data.Map                    as Map++import            IHaskell.IPython.Types+import            IHaskell.IPython.ZeroMQ+import            IHaskell.IPython.Message.UUID       as UUID++stdinInterface :: MVar ZeroMQStdin+{-# NOINLINE stdinInterface #-}+stdinInterface = unsafePerformIO newEmptyMVar++-- | Manipulate standard input so that it is sourced from the IPython+-- frontend. This function is build on layers of deep magical hackery, so+-- be careful modifying it.+fixStdin :: String -> IO ()+fixStdin dir = do+  -- Initialize the stdin interface.+  profile <- read <$> readFile (dir ++ "/.kernel-profile")+  interface <- serveStdin profile+  putMVar stdinInterface interface+  void $ forkIO $ stdinOnce dir++stdinOnce :: String -> IO ()+stdinOnce dir = do+  -- Create a pipe using and turn it into handles.+  (readEnd, writeEnd) <- createPipe+  newStdin <- fdToHandle readEnd+  stdinInput <- fdToHandle writeEnd+  hSetBuffering newStdin NoBuffering+  hSetBuffering stdinInput NoBuffering++  -- Store old stdin and swap in new stdin.+  oldStdin <- hDuplicate stdin+  hDuplicateTo newStdin stdin++  loop stdinInput oldStdin newStdin+  where+    loop stdinInput oldStdin newStdin = do+      let FileHandle _ mvar = stdin+      threadDelay $ 150 * 1000+      empty <- isEmptyMVar mvar+      if not empty+      then loop stdinInput oldStdin newStdin+      else do+        line <- getInputLine dir+        hPutStr stdinInput $ line ++ "\n"+        loop stdinInput oldStdin newStdin++-- | Get a line of input from the IPython frontend.+getInputLine :: String -> IO String+getInputLine dir = do+  StdinChannel req rep <- readMVar stdinInterface++  -- Send a request for input.+  uuid <- UUID.random+  parentHeader <- read <$> readFile (dir ++ "/.last-req-header")+  let header = MessageHeader {+      username = username parentHeader,+      identifiers = identifiers parentHeader,+      parentHeader = Just parentHeader,+      messageId = uuid,+      sessionId = sessionId parentHeader,+      metadata = Map.fromList [],+      msgType = InputRequestMessage+    }+  let msg = RequestInput header ""+  writeChan req msg++  -- Get the reply.+  InputReply _ value <- readChan rep+  return value++recordParentHeader :: String -> MessageHeader -> IO ()+recordParentHeader dir header =+  writeFile (dir ++ "/.last-req-header") $ show header++recordKernelProfile :: String -> Profile -> IO ()+recordKernelProfile dir profile =+  writeFile (dir ++ "/.kernel-profile") $ show profile
+ src/IHaskell/IPython/Types.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}+-- | This module contains all types used to create an IPython language+-- kernel.+module IHaskell.IPython.Types (+  -- * IPython kernel profile+  Profile(..),+  Transport(..),+  Port(..),+  IP(..),++  -- * IPython messaging protocol+  Message(..),+  MessageHeader(..),+  Username(..),+  Metadata(..),+  MessageType(..),+  Width(..), Height(..),+  StreamType(..),+  ExecutionState(..),+  ExecuteReplyStatus(..),+  replyType,++  -- ** IPython display data message+  DisplayData(..),+  MimeType(..),+  extractPlain+                     +  ) where++import            Data.Aeson+import            Control.Applicative         ((<$>), (<*>))+import            Data.ByteString             (ByteString)+import qualified  Data.Text                   as Text+import qualified  Data.Text.Encoding          as Text+import            Data.Text                   (Text)+import            Data.Serialize+import            IHaskell.IPython.Message.UUID+import            GHC.Generics                (Generic)+import            Data.Typeable+import            Data.List                   (find)+import            Data.Map                    (Map)++-------------------- IPython Kernel Profile Types ----------------------+-- | A TCP port.+type Port = Int++-- | An IP address.+type IP = String++-- | The transport mechanism used to communicate with the IPython frontend.+data Transport+     = TCP                 -- ^ Default transport mechanism via TCP.+     deriving (Show, Read)++-- | A kernel profile, specifying how the kernel communicates.+data Profile = Profile {+  ip :: IP,               -- ^ The IP on which to listen.+  transport :: Transport, -- ^ The transport mechanism.+  stdinPort :: Port,      -- ^ The stdin channel port. +  controlPort :: Port,    -- ^ The control channel port.+  hbPort :: Port,         -- ^ The heartbeat channel port.+  shellPort :: Port,      -- ^ The shell command port.+  iopubPort :: Port,      -- ^ The IOPub port.+  key :: Text             -- ^ The HMAC encryption key.+  } deriving (Show, Read)++-- Convert the kernel profile to and from JSON.+instance FromJSON Profile where+  parseJSON (Object v) = +    Profile <$> v .: "ip"+            <*> v .: "transport"+            <*> v .: "stdin_port"+            <*> v .: "control_port"+            <*> v .: "hb_port"+            <*> v .: "shell_port"+            <*> v .: "iopub_port"+            <*> v .: "key"+  parseJSON _ = fail "Expecting JSON object."++instance ToJSON Profile where+  toJSON profile = object [+                    "ip"          .= ip profile,+                    "transport"   .= transport profile,+                    "stdin_port"  .= stdinPort profile,+                    "control_port".= controlPort profile,+                    "hb_port"     .= hbPort profile,+                    "shell_port"  .= shellPort profile,+                    "iopub_port"  .= iopubPort profile,+                    "key"         .= key profile+                   ]++instance FromJSON Transport where+  parseJSON (String mech) =+    case mech of+      "tcp" -> return TCP+      _ -> fail $ "Unknown transport mechanism " ++ Text.unpack mech+  parseJSON _ = fail "Expected JSON string as transport."++instance ToJSON Transport where+  toJSON TCP = String "tcp"+++-------------------- IPython Message Types ----------------------++-- | A message header with some metadata.  +data MessageHeader = MessageHeader {+  identifiers :: [ByteString],         -- ^ The identifiers sent with the message.+  parentHeader :: Maybe MessageHeader, -- ^ The parent header, if present.+  metadata :: Metadata,                -- ^ A dict of metadata.+  messageId :: UUID,                   -- ^ A unique message UUID.+  sessionId :: UUID,                   -- ^ A unique session UUID.+  username :: Username,                -- ^ The user who sent this message.+  msgType :: MessageType               -- ^ The message type.+  } deriving (Show, Read)++-- Convert a message header into the JSON field for the header.+-- This field does not actually have all the record fields.+instance ToJSON MessageHeader where+  toJSON header = object [+                    "msg_id"  .= messageId header,+                    "session" .= sessionId header,+                    "username" .= username header,+                    "msg_type" .= showMessageType (msgType header)+                  ]++-- | A username for the source of a message.+type Username = Text++-- | A metadata dictionary.+type Metadata = Map Text Text++-- | The type of a message, corresponding to IPython message types.+data MessageType = KernelInfoReplyMessage+                 | KernelInfoRequestMessage+                 | ExecuteReplyMessage+                 | ExecuteRequestMessage+                 | StatusMessage+                 | StreamMessage+                 | DisplayDataMessage+                 | OutputMessage+                 | InputMessage+                 | CompleteRequestMessage+                 | CompleteReplyMessage+                 | ObjectInfoRequestMessage+                 | ObjectInfoReplyMessage+                 | ShutdownRequestMessage+                 | ShutdownReplyMessage+                 | ClearOutputMessage+                 | InputRequestMessage+                 | InputReplyMessage+                 | CommOpenMessage+                 | CommDataMessage+                 | CommCloseMessage+                 deriving (Show, Read, Eq)++showMessageType :: MessageType -> String+showMessageType KernelInfoReplyMessage     = "kernel_info_reply"+showMessageType KernelInfoRequestMessage   = "kernel_info_request"+showMessageType ExecuteReplyMessage        = "execute_reply"+showMessageType ExecuteRequestMessage      = "execute_request"+showMessageType StatusMessage              = "status"+showMessageType StreamMessage              = "stream"+showMessageType DisplayDataMessage         = "display_data"+showMessageType OutputMessage              = "pyout"+showMessageType InputMessage               = "pyin"+showMessageType CompleteRequestMessage     = "complete_request"+showMessageType CompleteReplyMessage       = "complete_reply"+showMessageType ObjectInfoRequestMessage   = "object_info_request"+showMessageType ObjectInfoReplyMessage     = "object_info_reply"+showMessageType ShutdownRequestMessage     = "shutdown_request"+showMessageType ShutdownReplyMessage       = "shutdown_reply"+showMessageType ClearOutputMessage         = "clear_output"+showMessageType InputRequestMessage        = "input_request"+showMessageType InputReplyMessage          = "input_reply"+showMessageType CommOpenMessage            = "comm_open"           +showMessageType CommDataMessage            = "comm_msg"            +showMessageType CommCloseMessage           = "comm_close"          ++instance FromJSON MessageType where+  parseJSON (String s) = case s of+    "kernel_info_reply"   -> return KernelInfoReplyMessage+    "kernel_info_request" -> return KernelInfoRequestMessage+    "execute_reply"       -> return ExecuteReplyMessage+    "execute_request"     -> return ExecuteRequestMessage+    "status"              -> return StatusMessage+    "stream"              -> return StreamMessage+    "display_data"        -> return DisplayDataMessage+    "pyout"               -> return OutputMessage+    "pyin"                -> return InputMessage+    "complete_request"    -> return CompleteRequestMessage+    "complete_reply"      -> return CompleteReplyMessage+    "object_info_request" -> return ObjectInfoRequestMessage+    "object_info_reply"   -> return ObjectInfoReplyMessage+    "shutdown_request"    -> return ShutdownRequestMessage+    "shutdown_reply"      -> return ShutdownReplyMessage+    "clear_output"        -> return ClearOutputMessage+    "input_request"       -> return InputRequestMessage+    "input_reply"         -> return InputReplyMessage+    "comm_open"           -> return CommOpenMessage+    "comm_msg"            -> return CommDataMessage+    "comm_close"          -> return CommCloseMessage++    _                     -> fail ("Unknown message type: " ++ show s)+  parseJSON _ = fail "Must be a string."+++-- | A message used to communicate with the IPython frontend.+data Message +  -- | A request from a frontend for information about the kernel.+  = KernelInfoRequest { header :: MessageHeader }+  -- | A response to a KernelInfoRequest.+  | KernelInfoReply { +      header :: MessageHeader,+      versionList :: [Int],     -- ^ The version of the language, e.g. [7, 6, 3] for GHC 7.6.3+      language :: String        -- ^ The language name, e.g. "haskell"+     }+               +  -- | A request from a frontend to execute some code.+  | ExecuteRequest {+      header :: MessageHeader,+      getCode :: Text,             -- ^ The code string.+      getSilent :: Bool,                 -- ^ Whether this should be silently executed.+      getStoreHistory :: Bool,           -- ^ Whether to store this in history.+      getAllowStdin :: Bool,             -- ^ Whether this code can use stdin.++      getUserVariables :: [Text],  -- ^ Unused.+      getUserExpressions :: [Text] -- ^ Unused.+    }++  -- | A reply to an execute request.+  | ExecuteReply {+      header :: MessageHeader,+      status :: ExecuteReplyStatus,         -- ^ The status of the output.+      pagerOutput :: String,                -- ^ The help string to show in the pager.+      executionCounter :: Int               -- ^ The execution count, i.e. which output this is.+    }++  | PublishStatus {+      header :: MessageHeader,+      executionState :: ExecutionState      -- ^ The execution state of the kernel.+    }++  | PublishStream {+      header :: MessageHeader,+      streamType :: StreamType,             -- ^ Which stream to publish to.+      streamContent :: String               -- ^ What to publish.+    }++  | PublishDisplayData {+      header :: MessageHeader,+      source :: String,                     -- ^ The name of the data source.+      displayData :: [DisplayData]          -- ^ A list of data representations.+    }++  | PublishOutput {+      header :: MessageHeader,+      reprText :: String,                   -- ^ Printed output text.+      executionCount :: Int                 -- ^ Which output this is for.+    }++  | PublishInput {+      header :: MessageHeader,+      inCode :: String,                     -- ^ Submitted input code.+      executionCount :: Int                 -- ^ Which input this is.+    }++  | CompleteRequest {+      header :: MessageHeader,+      getCode :: Text, {- ^+            The entire block of text where the line is.  This may be useful in the+            case of multiline completions where more context may be needed.  Note: if+            in practice this field proves unnecessary, remove it to lighten the+            messages. json field @block@  -}+      getCodeLine :: Text, -- ^ just the line with the cursor. json field @line@+      getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@++    }++  | CompleteReply {+     header :: MessageHeader,+     completionMatches :: [Text],+     completionMatchedText :: Text,+     completionText :: Text,+     completionStatus :: Bool+  }++  | ObjectInfoRequest {+      header :: MessageHeader, +      objectName :: Text,  -- ^ Name of object being searched for.+      detailLevel :: Int         -- ^ Level of detail desired (defaults to 0).+                                -- 0 is equivalent to foo?, 1 is equivalent+                                -- to foo??.+    }++  | ObjectInfoReply {+      header :: MessageHeader, +      objectName :: Text,          -- ^ Name of object which was searched for.+      objectFound :: Bool,         -- ^ Whether the object was found.+      objectTypeString :: Text,    -- ^ Object type.+      objectDocString  :: Text +    }++  | ShutdownRequest {+      header :: MessageHeader,+      restartPending :: Bool    -- ^ Whether this shutdown precedes a restart.+    }+  | ShutdownReply {+      header :: MessageHeader,+      restartPending :: Bool    -- ^ Whether this shutdown precedes a restart.+    }++  | ClearOutput {+      header :: MessageHeader,+      wait :: Bool -- ^ Whether to wait to redraw until there is more output.+  }++  | RequestInput {+      header :: MessageHeader,+      inputPrompt :: String      +  }++  | InputReply {+      header :: MessageHeader,+      inputValue :: String      +  }++  | CommOpen {+      header :: MessageHeader,+      commTargetName :: String,+      commUuid :: UUID,+      commData :: Value+  }++  | CommData {+      header :: MessageHeader,+      commUuid :: UUID,+      commData :: Value+  }++  | CommClose {+      header :: MessageHeader,+      commUuid :: UUID,+      commData :: Value+  }++  | SendNothing -- Dummy message; nothing is sent.+    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++-- | Input and output streams.+data StreamType = Stdin | Stdout deriving Show++-- | Get the reply message type for a request message type.+replyType :: MessageType -> Maybe MessageType+replyType KernelInfoRequestMessage  = Just KernelInfoReplyMessage+replyType ExecuteRequestMessage     = Just ExecuteReplyMessage+replyType CompleteRequestMessage    = Just CompleteReplyMessage+replyType ObjectInfoRequestMessage  = Just ObjectInfoReplyMessage+replyType ShutdownRequestMessage    = Just ShutdownReplyMessage+replyType _ = Nothing++-- | Data for display: a string with associated MIME type.+data DisplayData = DisplayData MimeType Text deriving (Typeable, Generic)++-- We can't print the actual data, otherwise this will be printed every+-- time it gets computed because of the way the evaluator is structured.+-- See how `displayExpr` is computed.+instance Show DisplayData where+  show _ = "DisplayData"++-- Allow DisplayData serialization+instance Serialize Text where+    put str = put (Text.encodeUtf8 str)+    get = Text.decodeUtf8 <$> get+instance Serialize DisplayData+instance Serialize MimeType++-- | Possible MIME types for the display data.+type Width = Int+type Height = Int+data MimeType = PlainText+              | MimeHtml+              | MimePng Width Height+              | MimeJpg Width Height+              | MimeSvg+              | MimeLatex+              | MimeJavascript+              deriving (Eq, Typeable, Generic)++-- Extract the plain text from a list of displays.+extractPlain :: [DisplayData] -> String+extractPlain disps =+  case find isPlain disps of+    Nothing -> ""+    Just (DisplayData PlainText bytestr) -> Text.unpack bytestr+  where+    isPlain (DisplayData mime _) = mime == PlainText++instance Show MimeType where+  show PlainText = "text/plain"+  show MimeHtml  = "text/html"+  show (MimePng _ _)   = "image/png" +  show (MimeJpg _ _)   = "image/jpeg"+  show MimeSvg   = "image/svg+xml"+  show MimeLatex = "text/latex"+  show MimeJavascript = "application/javascript"
+ src/IHaskell/IPython/ZeroMQ.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}+-- | Description : Low-level ZeroMQ communication wrapper.+--+-- 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+-- takes a IPython profile specification and returns the channel interface to use.+module IHaskell.IPython.ZeroMQ (+  ZeroMQInterface (..),+  ZeroMQStdin(..),+  serveProfile,+  serveStdin,+  ) where++import qualified  Data.ByteString.Lazy  as ByteString+import            Data.ByteString       (ByteString)+import            Control.Concurrent+import            Control.Monad +import            System.IO.Unsafe+import            Data.Aeson            (encode)+import            System.ZMQ4           hiding (stdin)++import IHaskell.IPython.Types+import IHaskell.IPython.Message.Parser+import IHaskell.IPython.Message.Writer++-- | 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+-- transmitted to IPython. These channels should functionally serve as+-- high-level sockets which speak Messages instead of ByteStrings.+data ZeroMQInterface = Channels {+  shellRequestChannel :: Chan Message,    -- ^ A channel populated with requests from the frontend.+  shellReplyChannel :: Chan Message,      -- ^ Writing to this channel causes a reply to be sent to the frontend.+  controlRequestChannel :: Chan Message,  -- ^ This channel is a duplicate of the shell request channel,+                                         -- ^ though using a different backend socket.+  controlReplyChannel :: Chan Message,    -- ^ This channel is a duplicate of the shell reply channel,+                                         -- ^ though using a different backend socket.+  iopubChannel :: Chan Message           -- ^ Writing to this channel sends an iopub message to the frontend.+  }++data ZeroMQStdin = StdinChannel {+  stdinRequestChannel :: Chan Message,+  stdinReplyChannel :: Chan Message+  }++-- | Start responding on all ZeroMQ channels used to communicate with IPython+-- | via the provided profile. Return a set of channels which can be used to+-- | communicate with IPython in a more structured manner. +serveProfile :: Profile            -- ^ The profile specifying which ports and transport mechanisms to use.+             -> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets.+serveProfile profile = do+  -- Create all channels which will be used for higher level communication.+  shellReqChan <- newChan+  shellRepChan <- newChan+  controlReqChan <- dupChan shellReqChan+  controlRepChan <- dupChan shellRepChan+  iopubChan <- newChan+  let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan++  -- Create the context in a separate thread that never finishes. If+  -- withContext or withSocket complete, the context or socket become invalid.+  forkIO $ withContext $ \context -> do+    -- Serve on all sockets.+    forkIO $ serveSocket context Rep    (hbPort profile)      $ heartbeat channels+    forkIO $ serveSocket context Router (controlPort profile) $ control   channels+    forkIO $ serveSocket context Router (shellPort profile)   $ shell     channels++    -- The context is reference counted in this thread only. Thus, the last+    -- serveSocket cannot be asynchronous, because otherwise context would+    -- be garbage collectable - since it would only be used in other+    -- threads. Thus, keep the last serveSocket in this thread.+    serveSocket context Pub    (iopubPort profile)   $ iopub     channels++  return channels++serveStdin :: Profile -> IO ZeroMQStdin +serveStdin profile = do+  reqChannel <- newChan+  repChannel <- newChan+  +  -- Create the context in a separate thread that never finishes. If+  -- withContext or withSocket complete, the context or socket become invalid.+  forkIO $ withContext $ \context ->+    -- Serve on all sockets.+    serveSocket context Router (stdinPort profile) $ \socket -> do+      -- Read the request from the interface channel and send it.+      readChan reqChannel >>= sendMessage socket++      -- Receive a response and write it to the interface channel.+      receiveMessage socket >>= writeChan repChannel++  return $ StdinChannel reqChannel repChannel++-- | Serve on a given socket in a separate thread. Bind the socket in the+-- | given context and then loop the provided action, which should listen+-- | on the socket and respond to any events.+serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO ()+serveSocket context socketType port action = void $+  withSocket context socketType $ \socket -> do+    bind socket $ "tcp://127.0.0.1:" ++ show port+    forever $ action socket++-- | Listener on the heartbeat port. Echoes back any data it was sent.+heartbeat :: ZeroMQInterface -> Socket Rep -> IO ()+heartbeat _ socket = do+  -- Read some data.+  request <- receive socket++  -- Send it back.+  send socket [] request++-- | Listener on the shell port. Reads messages and writes them to+-- | the shell request channel. For each message, reads a response from the+-- | shell reply channel of the interface and sends it back to the frontend. +shell :: ZeroMQInterface -> Socket Router -> IO ()+shell channels socket = do+  -- Receive a message and write it to the interface channel.+  receiveMessage socket >>= writeChan requestChannel++  -- Read the reply from the interface channel and send it.+  readChan replyChannel >>= sendMessage socket++  where+    requestChannel = shellRequestChannel channels+    replyChannel = shellReplyChannel channels++-- | Listener on the shell port. Reads messages and writes them to+-- | the shell request channel. For each message, reads a response from the+-- | shell reply channel of the interface and sends it back to the frontend. +control :: ZeroMQInterface -> Socket Router -> IO ()+control channels socket = do+  -- Receive a message and write it to the interface channel.+  receiveMessage socket >>= writeChan requestChannel++  -- Read the reply from the interface channel and send it.+  readChan replyChannel >>= sendMessage socket++  where+    requestChannel = controlRequestChannel channels+    replyChannel =   controlReplyChannel channels++-- | Send messages via the iopub channel.+-- | This reads messages from the ZeroMQ iopub interface channel +-- | and then writes the messages to the socket.+iopub :: ZeroMQInterface -> Socket Pub -> IO ()+iopub channels socket =+  readChan (iopubChannel channels) >>= sendMessage socket++-- | Receive and parse a message from a socket.+receiveMessage :: Receiver a => Socket a -> IO Message+receiveMessage socket = do+  -- Read all identifiers until the identifier/message delimiter.+  idents <- readUntil "<IDS|MSG>"++  -- Ignore the signature for now.+  void next++  headerData <- next+  parentHeader <- next+  metadata <- next+  content <- next++  let message = parseMessage idents headerData parentHeader metadata content+  return message++  where+    -- Receive the next piece of data from the socket.+    next = receive socket++    -- Read data from the socket until we hit an ending string.+    -- Return all data as a list, which does not include the ending string.+    readUntil str = do+      line <- next+      if line /= str+      then do+        remaining <- readUntil str+        return $ line : remaining+      else return []+  +-- | Encode a message in the IPython ZeroMQ communication protocol +-- | and send it through the provided socket.+sendMessage :: Sender a => Socket a -> Message -> IO ()+sendMessage _ SendNothing = return ()+sendMessage socket message = do+  let head = header message+      parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head+      idents = identifiers head+      metadata = "{}"+      content = encodeStrict message+      headStr = encodeStrict head++  -- Send all pieces of the message.+  mapM_ sendPiece idents+  sendPiece "<IDS|MSG>"+  sendPiece ""+  sendPiece headStr+  sendPiece parentHeaderStr+  sendPiece metadata++  -- Conclude transmission with content.+  sendLast content++  where+    sendPiece = send socket [SendMore]+    sendLast = send socket []++    -- Encode to a strict bytestring.+    encodeStrict :: ToJSON a => a -> ByteString+    encodeStrict = ByteString.toStrict . encode
− src/IPython/Kernel.hs 
@@ -1,16 +0,0 @@--- | This module exports all the types and functions necessary to create an--- IPython language kernel that supports the @ipython console@ and @ipython--- notebook@ frontends. -module IPython.Kernel (-  module IPython.Types,-  module IPython.Message.Writer,-  module IPython.Message.Parser,-  module IPython.Message.UUID,-  module IPython.ZeroMQ,-  ) where--import IPython.Types-import IPython.Message.Writer-import IPython.Message.Parser-import IPython.Message.UUID-import IPython.ZeroMQ
− src/IPython/Message/Parser.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Description : Parsing messages received from IPython------ This module is responsible for converting from low-level ByteStrings--- obtained from the 0MQ sockets into Messages. The only exposed function is--- `parseMessage`, which should only be used in the low-level 0MQ interface.-module IPython.Message.Parser (parseMessage) where--import            Data.Aeson            ((.:), decode, Result(..), Object)-import            Control.Applicative   ((<|>))-import            Data.Aeson.Types      (parse)-import            Data.ByteString-import qualified  Data.ByteString.Lazy  as Lazy-import            Data.Map              (Map)--import IPython.Types--type LByteString = Lazy.ByteString------- External interface --------- | Parse a message from its ByteString components into a Message.-parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message.-              -> ByteString   -- ^ The header data.-              -> ByteString   -- ^ The parent header, which is just "{}" if there is no header.-              -> ByteString   -- ^ The metadata map, also "{}" for an empty map.-              -> ByteString   -- ^ The message content.-              -> Message      -- ^ A parsed message.-parseMessage idents headerData parentHeader metadata content = -  let header = parseHeader idents headerData parentHeader metadata-      messageType = msgType header-      messageWithoutHeader = parser messageType $ Lazy.fromStrict content in-    messageWithoutHeader { header = header }------- Module internals --------- | Parse a header from its ByteString components into a MessageHeader.-parseHeader :: [ByteString]  -- ^ The list of identifiers.-            -> ByteString    -- ^ The header data.-            -> ByteString    -- ^ The parent header, or "{}" for Nothing.-            -> ByteString    -- ^ The metadata, or "{}" for an empty map.-            -> MessageHeader -- The resulting message header.-parseHeader idents headerData parentHeader metadata = MessageHeader {-  identifiers = idents,-  parentHeader = parentResult,-  metadata = metadataMap,-  messageId = messageUUID,-  sessionId = sessionUUID,-  username = username,-  msgType = messageType-  } where-      -- Decode the header data and the parent header data into JSON objects.-      -- If the parent header data is absent, just have Nothing instead.-      Just result = decode $ Lazy.fromStrict headerData :: Maybe Object-      parentResult = if parentHeader == "{}"-                     then Nothing-                     else Just $ parseHeader idents parentHeader "{}" metadata--      -- Get the basic fields from the header.-      Success (messageType, username, messageUUID, sessionUUID) = flip parse result $ \obj -> do -        messType <- obj .: "msg_type"-        username <- obj .: "username"-        message <- obj .: "msg_id"-        session <- obj .: "session"-        return (messType, username, message, session)--      -- Get metadata as a simple map.-      Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map ByteString ByteString)--noHeader :: MessageHeader-noHeader = error "No header created"--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 KernelInfoRequestMessage  = kernelInfoRequestParser-parser ExecuteRequestMessage     = executeRequestParser-parser CompleteRequestMessage    = completeRequestParser-parser ObjectInfoRequestMessage  = objectInfoRequestParser-parser ShutdownRequestMessage    = shutdownRequestParser-parser InputReplyMessage         = inputReplyParser-parser other = error $ "Unknown message type " ++ show other---- | Parse a kernel info request.--- A kernel info request has no auxiliary information, so ignore the body.-kernelInfoRequestParser :: LByteString -> Message-kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader }---- | Parse an execute request.--- Fields used are:---  1. "code": the code to execute.---  2. "silent": whether to execute silently.---  3. "store_history": whether to include this in history.---  4. "allow_stdin": whether to allow reading from stdin for this code.-executeRequestParser :: LByteString -> Message-executeRequestParser content = -  let parser obj = do-        code <- obj .: "code"-        silent <- obj .: "silent"-        storeHistory <- obj .: "store_history"-        allowStdin <- obj .: "allow_stdin"--        return (code, silent, storeHistory, allowStdin)-      Just decoded = decode content-      Success (code, silent, storeHistory, allowStdin) = parse parser decoded in-    ExecuteRequest {-      header = noHeader,-      getCode = code,-      getSilent = silent,-      getAllowStdin = allowStdin,-      getStoreHistory = storeHistory,-      getUserVariables = [],-      getUserExpressions = []-    }--completeRequestParser :: LByteString -> Message-completeRequestParser content = parsed-  where-  Success parsed = flip parse decoded $ \ obj -> do-        code     <- obj .: "block" <|> return ""-        codeLine <- obj .: "line"-        pos      <- obj .: "cursor_pos"-        return $ CompleteRequest noHeader code codeLine pos--  Just decoded = decode content--objectInfoRequestParser :: LByteString -> Message-objectInfoRequestParser content = parsed-  where-    Success parsed = flip parse decoded $ \obj -> do-      oname <- obj .: "oname"-      dlevel <- obj .: "detail_level"-      return $ ObjectInfoRequest noHeader oname dlevel--    Just decoded = decode content---shutdownRequestParser :: LByteString -> Message-shutdownRequestParser content = parsed-  where-  Success parsed = flip parse decoded $ \ obj -> do-        code     <- obj .: "restart"-        return $ ShutdownRequest noHeader code--  Just decoded = decode content--inputReplyParser :: LByteString -> Message-inputReplyParser content = parsed-  where-  Success parsed = flip parse decoded $ \ obj -> do-        value <- obj .: "value"-        return $ InputReply noHeader value--  Just decoded = decode content
− src/IPython/Message/UUID.hs 
@@ -1,46 +0,0 @@--- | Description : UUID generator and data structure------ Generate, parse, and pretty print UUIDs for use with IPython.-module IPython.Message.UUID (-  UUID,-  random, randoms,-  ) where--import Control.Monad (mzero, replicateM)-import Control.Applicative ((<$>))-import Data.Text (pack)-import Data.Aeson-import Data.UUID.V4 (nextRandom)--import Text.Read as Read hiding (pfail, String)----- We use an internal string representation because for the purposes of--- IPython, it matters whether the letters are uppercase or lowercase and--- whether the dashes are present in the correct locations. For the--- purposes of new UUIDs, it does not matter, but IPython expects UUIDs--- passed to kernels to be returned unchanged, so we cannot actually parse--- them.---- | A UUID (universally unique identifier).-data UUID = UUID String deriving (Show, Read, Eq)---- | Generate a list of random UUIDs.-randoms :: Int      -- ^ Number of UUIDs to generate.-        -> IO [UUID]-randoms n = replicateM n random---- | Generate a single random UUID.-random :: IO UUID-random = UUID <$> show <$> nextRandom---- Allows reading and writing UUIDs as Strings in JSON. -instance FromJSON UUID where-  parseJSON val@(String _) = UUID <$> parseJSON val--  -- UUIDs must be Strings.-  parseJSON _ = mzero--instance ToJSON UUID where-  -- Extract the string from the UUID.-  toJSON (UUID str) = String $ pack str
− src/IPython/Message/Writer.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Description : @ToJSON@ for Messages------ This module contains the @ToJSON@ instance for @Message@.-module IPython.Message.Writer (-  ToJSON(..)-)  where--import Data.Aeson-import Data.Map     (Map)-import Data.Text    (Text, pack)-import Data.Monoid  (mempty)---import IPython.Types---- Convert message bodies into JSON.-instance ToJSON Message where-  toJSON KernelInfoReply{ versionList = vers, language = language } = object [-                             "protocol_version" .= ints [4, 0], -- current protocol version, major and minor-                             "language_version" .= vers,-                             "language" .= language-                           ]--  toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [-                             "status" .= show status,-                             "execution_count" .= counter,-                             "payload" .= -                               if null pager-                               then []-                               else [object [-                                    "source" .= string "page",-                                    "text" .= pager-                                ]],-                             "user_variables" .= emptyMap,-                             "user_expressions" .= emptyMap-                           ]-  toJSON PublishStatus{ executionState = executionState } = object [-                             "execution_state" .= executionState-                           ]-  toJSON PublishStream{ streamType = streamType, streamContent = content } = object [-                             "data" .= content,-                             "name" .= streamType-                           ]-  toJSON PublishDisplayData{ source = src, displayData = datas } = object [-                             "source" .= src,-                             "metadata" .= object [],-                             "data" .= object  (map displayDataToJson datas)-                           ]--  toJSON PublishOutput{ executionCount = execCount, reprText = reprText } = object [-                             "data" .= object ["text/plain" .= reprText],-                             "execution_count" .= execCount,-                             "metadata" .= object []-                           ]-  toJSON PublishInput{ executionCount = execCount, inCode = code } = object [-                             "execution_count" .= execCount,-                             "code" .= code-                           ]-  toJSON (CompleteReply _ m mt t s) = object [-                             "matches" .= m,-                             "matched_text" .= mt,-                             "text" .= t,-                             "status" .= if s then string "ok" else "error"-                           ]-  toJSON o@ObjectInfoReply{} = object [-                            "oname" .= objectName o,-                            "found" .= objectFound o,-                            "ismagic" .= False,-                            "isalias" .= False,-                            "type_name" .= objectTypeString o,-                            "docstring" .= objectDocString o-                           ]--  toJSON ShutdownReply{restartPending = restart} = object [-                            "restart" .= restart-                           ]--  toJSON ClearOutput{wait = wait} = object [-                            "wait" .= wait-                           ]--  toJSON RequestInput{inputPrompt = prompt} = object [-                            "prompt" .= prompt-                           ]---  toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body----- | Print an execution state as "busy", "idle", or "starting".-instance ToJSON ExecutionState where-    toJSON Busy = String "busy"-    toJSON Idle = String "idle"-    toJSON Starting = String "starting"---- | Print a stream as "stdin" or "stdout" strings.-instance ToJSON StreamType where-    toJSON Stdin = String "stdin"-    toJSON Stdout = String "stdout"---- | Convert a MIME type and value into a JSON dictionary pair.-displayDataToJson :: DisplayData -> (Text, Value) -displayDataToJson (DisplayData mimeType dataStr) = pack (show mimeType) .= dataStr------- Constants -------emptyMap :: Map String String-emptyMap = mempty--emptyList :: [Int]-emptyList = []--ints :: [Int] -> [Int]-ints = id--string :: String -> String-string = id
− src/IPython/Stdin.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}--- | This module provides a way in which the Haskell standard input may be--- forwarded to the IPython frontend and thus allows the notebook to use--- the standard input.------ This relies on the implementation of file handles in GHC, and is--- generally unsafe and terrible. However, it is difficult to find another--- way to do it, as file handles are generally meant to point to streams--- and files, and not networked communication protocols.------ In order to use this module, it must first be initialized with two--- things. First of all, in order to know how to communicate with the--- IPython frontend, it must know the kernel profile used for--- communication. For this, use @recordKernelProfile@ once the profile is--- known. Both this and @recordParentHeader@ take a directory name where--- they can store this data.------ Finally, the module must know what @execute_request@ message is--- currently being replied to (which will request the input). Thus, every--- time the language kernel receives an @execute_request@ message, it--- should inform this module via @recordParentHeader@, so that the module--- may generate messages with an appropriate parent header set. If this is--- not done, the IPython frontends will not recognize the target of the--- communication.------ Finally, in order to activate this module, @fixStdin@ must be called--- once. It must be passed the same directory name as @recordParentHeader@--- and @recordKernelProfile@. Note that if this is being used from within--- the GHC API, @fixStdin@ /must/ be called from within the GHC session--- not from the host code.-module IPython.Stdin (-  fixStdin,-  recordParentHeader,-  recordKernelProfile-  ) where--import            Control.Concurrent          -import            Control.Applicative         ((<$>))-import            Control.Concurrent.Chan-import            Control.Monad-import            GHC.IO.Handle-import            GHC.IO.Handle.Types-import            System.IO-import            System.Posix.IO-import            System.IO.Unsafe-import qualified  Data.Map                    as Map--import            IPython.Types-import            IPython.ZeroMQ-import            IPython.Message.UUID       as UUID--stdinInterface :: MVar ZeroMQStdin-{-# NOINLINE stdinInterface #-}-stdinInterface = unsafePerformIO newEmptyMVar---- | Manipulate standard input so that it is sourced from the IPython--- frontend. This function is build on layers of deep magical hackery, so--- be careful modifying it.-fixStdin :: String -> IO ()-fixStdin dir = do-  -- Initialize the stdin interface.-  profile <- read <$> readFile (dir ++ "/.kernel-profile")-  interface <- serveStdin profile-  putMVar stdinInterface interface-  void $ forkIO $ stdinOnce dir--stdinOnce :: String -> IO ()-stdinOnce dir = do-  -- Create a pipe using and turn it into handles.-  (readEnd, writeEnd) <- createPipe-  newStdin <- fdToHandle readEnd-  stdinInput <- fdToHandle writeEnd-  hSetBuffering newStdin NoBuffering-  hSetBuffering stdinInput NoBuffering--  -- Store old stdin and swap in new stdin.-  oldStdin <- hDuplicate stdin-  hDuplicateTo newStdin stdin--  loop stdinInput oldStdin newStdin-  where-    loop stdinInput oldStdin newStdin = do-      let FileHandle _ mvar = stdin-      threadDelay $ 150 * 1000-      empty <- isEmptyMVar mvar-      if not empty-      then loop stdinInput oldStdin newStdin-      else do-        line <- getInputLine dir-        hPutStr stdinInput $ line ++ "\n"-        loop stdinInput oldStdin newStdin---- | Get a line of input from the IPython frontend.-getInputLine :: String -> IO String-getInputLine dir = do-  StdinChannel req rep <- readMVar stdinInterface--  -- Send a request for input.-  uuid <- UUID.random-  parentHeader <- read <$> readFile (dir ++ "/.last-req-header")-  let header = MessageHeader {-      username = username parentHeader,-      identifiers = identifiers parentHeader,-      parentHeader = Just parentHeader,-      messageId = uuid,-      sessionId = sessionId parentHeader,-      metadata = Map.fromList [],-      msgType = InputRequestMessage-    }-  let msg = RequestInput header ""-  writeChan req msg--  -- Get the reply.-  InputReply _ value <- readChan rep-  return value--recordParentHeader :: String -> MessageHeader -> IO ()-recordParentHeader dir header =-  writeFile (dir ++ "/.last-req-header") $ show header--recordKernelProfile :: String -> Profile -> IO ()-recordKernelProfile dir profile =-  writeFile (dir ++ "/.kernel-profile") $ show profile
− src/IPython/Types.hs 
@@ -1,382 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}--- | This module contains all types used to create an IPython language--- kernel.-module IPython.Types (-  -- * IPython kernel profile-  Profile(..),-  Transport(..),-  Port(..),-  IP(..),--  -- * IPython messaging protocol-  Message(..),-  MessageHeader(..),-  Username(..),-  Metadata(..),-  MessageType(..),-  Width(..), Height(..),-  StreamType(..),-  ExecutionState(..),-  ExecuteReplyStatus(..),-  replyType,--  -- ** IPython display data message-  DisplayData(..),-  MimeType(..),-  extractPlain-                     -  ) where--import            Data.Aeson-import            Control.Applicative         ((<$>), (<*>))-import            Data.ByteString             (ByteString)-import qualified  Data.ByteString.Char8       as Char-import qualified  Data.Text                   as Text-import            Data.Serialize-import            IPython.Message.UUID-import            GHC.Generics                (Generic)-import            Data.Typeable-import            Data.List                   (find)-import            Data.Map                    (Map)---------------------- IPython Kernel Profile Types ------------------------- | A TCP port.-type Port = Int---- | An IP address.-type IP = String---- | The transport mechanism used to communicate with the IPython frontend.-data Transport-     = TCP                 -- ^ Default transport mechanism via TCP.-     deriving (Show, Read)---- | A kernel profile, specifying how the kernel communicates.-data Profile = Profile {-  ip :: IP,               -- ^ The IP on which to listen.-  transport :: Transport, -- ^ The transport mechanism.-  stdinPort :: Port,      -- ^ The stdin channel port. -  controlPort :: Port,    -- ^ The control channel port.-  hbPort :: Port,         -- ^ The heartbeat channel port.-  shellPort :: Port,      -- ^ The shell command port.-  iopubPort :: Port,      -- ^ The IOPub port.-  key :: ByteString       -- ^ The HMAC encryption key.-  } deriving (Show, Read)---- Convert the kernel profile to and from JSON.-instance FromJSON Profile where-  parseJSON (Object v) = -    Profile <$> v .: "ip"-            <*> v .: "transport"-            <*> v .: "stdin_port"-            <*> v .: "control_port"-            <*> v .: "hb_port"-            <*> v .: "shell_port"-            <*> v .: "iopub_port"-            <*> v .: "key"-  parseJSON _ = fail "Expecting JSON object."--instance ToJSON Profile where-  toJSON profile = object [-                    "ip"          .= ip profile,-                    "transport"   .= transport profile,-                    "stdin_port"  .= stdinPort profile,-                    "control_port".= controlPort profile,-                    "hb_port"     .= hbPort profile,-                    "shell_port"  .= shellPort profile,-                    "iopub_port"  .= iopubPort profile,-                    "key"         .= key profile-                   ]--instance FromJSON Transport where-  parseJSON (String str) = do-    let mech = Text.unpack str-    case mech of-      "tcp" -> return TCP-      _ -> fail $ "Unknown transport mechanism " ++ mech-  parseJSON _ = fail "Expected JSON string as transport."--instance ToJSON Transport where-  toJSON TCP = String "tcp"----------------------- IPython Message Types -------------------------- | A message header with some metadata.  -data MessageHeader = MessageHeader {-  identifiers :: [ByteString],         -- ^ The identifiers sent with the message.-  parentHeader :: Maybe MessageHeader, -- ^ The parent header, if present.-  metadata :: Metadata,                -- ^ A dict of metadata.-  messageId :: UUID,                   -- ^ A unique message UUID.-  sessionId :: UUID,                   -- ^ A unique session UUID.-  username :: Username,                -- ^ The user who sent this message.-  msgType :: MessageType               -- ^ The message type.-  } deriving (Show, Read)---- Convert a message header into the JSON field for the header.--- This field does not actually have all the record fields.-instance ToJSON MessageHeader where-  toJSON header = object [-                    "msg_id"  .= messageId header,-                    "session" .= sessionId header,-                    "username" .= username header,-                    "msg_type" .= showMessageType (msgType header)-                  ]---- | A username for the source of a message.-type Username = ByteString---- | A metadata dictionary.-type Metadata = Map ByteString ByteString---- | The type of a message, corresponding to IPython message types.-data MessageType = KernelInfoReplyMessage-                 | KernelInfoRequestMessage-                 | ExecuteReplyMessage-                 | ExecuteRequestMessage-                 | StatusMessage-                 | StreamMessage-                 | DisplayDataMessage-                 | OutputMessage-                 | InputMessage-                 | CompleteRequestMessage-                 | CompleteReplyMessage-                 | ObjectInfoRequestMessage-                 | ObjectInfoReplyMessage-                 | ShutdownRequestMessage-                 | ShutdownReplyMessage-                 | ClearOutputMessage-                 | InputRequestMessage-                 | InputReplyMessage-                 deriving (Show, Read)--showMessageType :: MessageType -> String-showMessageType KernelInfoReplyMessage     = "kernel_info_reply"-showMessageType KernelInfoRequestMessage   = "kernel_info_request"-showMessageType ExecuteReplyMessage        = "execute_reply"-showMessageType ExecuteRequestMessage      = "execute_request"-showMessageType StatusMessage              = "status"-showMessageType StreamMessage              = "stream"-showMessageType DisplayDataMessage         = "display_data"-showMessageType OutputMessage              = "pyout"-showMessageType InputMessage               = "pyin"-showMessageType CompleteRequestMessage     = "complete_request"-showMessageType CompleteReplyMessage       = "complete_reply"-showMessageType ObjectInfoRequestMessage   = "object_info_request"-showMessageType ObjectInfoReplyMessage     = "object_info_reply"-showMessageType ShutdownRequestMessage     = "shutdown_request"-showMessageType ShutdownReplyMessage       = "shutdown_reply"-showMessageType ClearOutputMessage         = "clear_output"-showMessageType InputRequestMessage        = "input_request"-showMessageType InputReplyMessage          = "input_reply"--instance FromJSON MessageType where-  parseJSON (String s) = case s of-    "kernel_info_reply"   -> return KernelInfoReplyMessage-    "kernel_info_request" -> return KernelInfoRequestMessage-    "execute_reply"       -> return ExecuteReplyMessage-    "execute_request"     -> return ExecuteRequestMessage-    "status"              -> return StatusMessage-    "stream"              -> return StreamMessage-    "display_data"        -> return DisplayDataMessage-    "pyout"               -> return OutputMessage-    "pyin"                -> return InputMessage-    "complete_request"    -> return CompleteRequestMessage-    "complete_reply"      -> return CompleteReplyMessage-    "object_info_request" -> return ObjectInfoRequestMessage-    "object_info_reply"   -> return ObjectInfoReplyMessage-    "shutdown_request"    -> return ShutdownRequestMessage-    "shutdown_reply"      -> return ShutdownReplyMessage-    "clear_output"        -> return ClearOutputMessage-    "input_request"       -> return InputRequestMessage-    "input_reply"         -> return InputReplyMessage--    _                     -> fail ("Unknown message type: " ++ show s)-  parseJSON _ = fail "Must be a string."----- | A message used to communicate with the IPython frontend.-data Message -  -- | A request from a frontend for information about the kernel.-  = KernelInfoRequest { header :: MessageHeader }-  -- | A response to a KernelInfoRequest.-  | KernelInfoReply { -      header :: MessageHeader,-      versionList :: [Int],     -- ^ The version of the language, e.g. [7, 6, 3] for GHC 7.6.3-      language :: String        -- ^ The language name, e.g. "haskell"-     }-               -  -- | A request from a frontend to execute some code.-  | ExecuteRequest {-      header :: MessageHeader,-      getCode :: ByteString,             -- ^ The code string.-      getSilent :: Bool,                 -- ^ Whether this should be silently executed.-      getStoreHistory :: Bool,           -- ^ Whether to store this in history.-      getAllowStdin :: Bool,             -- ^ Whether this code can use stdin.--      getUserVariables :: [ByteString],  -- ^ Unused.-      getUserExpressions :: [ByteString] -- ^ Unused.-    }--  -- | A reply to an execute request.-  | ExecuteReply {-      header :: MessageHeader,-      status :: ExecuteReplyStatus,         -- ^ The status of the output.-      pagerOutput :: String,                -- ^ The help string to show in the pager.-      executionCounter :: Int               -- ^ The execution count, i.e. which output this is.-    }--  | PublishStatus {-      header :: MessageHeader,-      executionState :: ExecutionState      -- ^ The execution state of the kernel.-    }--  | PublishStream {-      header :: MessageHeader,-      streamType :: StreamType,             -- ^ Which stream to publish to.-      streamContent :: String               -- ^ What to publish.-    }--  | PublishDisplayData {-      header :: MessageHeader,-      source :: String,                     -- ^ The name of the data source.-      displayData :: [DisplayData]          -- ^ A list of data representations.-    }--  | PublishOutput {-      header :: MessageHeader,-      reprText :: String,                   -- ^ Printed output text.-      executionCount :: Int                 -- ^ Which output this is for.-    }--  | PublishInput {-      header :: MessageHeader,-      inCode :: String,                     -- ^ Submitted input code.-      executionCount :: Int                 -- ^ Which input this is.-    }--  | CompleteRequest {-      header :: MessageHeader,-      getCode :: ByteString, {- ^-            The entire block of text where the line is.  This may be useful in the-            case of multiline completions where more context may be needed.  Note: if-            in practice this field proves unnecessary, remove it to lighten the-            messages. json field @block@  -}-      getCodeLine :: ByteString, -- ^ just the line with the cursor. json field @line@-      getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@--    }--  | CompleteReply {-     header :: MessageHeader,-     completionMatches :: [ByteString],-     completionMatchedText :: ByteString,-     completionText :: ByteString,-     completionStatus :: Bool-  }--  | ObjectInfoRequest {-      header :: MessageHeader, -      objectName :: ByteString,  -- ^ Name of object being searched for.-      detailLevel :: Int         -- ^ Level of detail desired (defaults to 0).-                                -- 0 is equivalent to foo?, 1 is equivalent-                                -- to foo??.-    }--  | ObjectInfoReply {-      header :: MessageHeader, -      objectName :: ByteString,       -- ^ Name of object which was searched for.-      objectFound :: Bool,            -- ^ Whether the object was found.-      objectTypeString :: ByteString, -- ^ Object type.-      objectDocString  :: ByteString-    }--  | ShutdownRequest {-      header :: MessageHeader,-      restartPending :: Bool    -- ^ Whether this shutdown precedes a restart.-    }-  | ShutdownReply {-      header :: MessageHeader,-      restartPending :: Bool    -- ^ Whether this shutdown precedes a restart.-    }--  | ClearOutput {-      header :: MessageHeader,-      wait :: Bool -- ^ Whether to wait to redraw until there is more output.-  }--  | RequestInput {-      header :: MessageHeader,-      inputPrompt :: String      -  }--  | InputReply {-      header :: MessageHeader,-      inputValue :: String      -  }--    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---- | Input and output streams.-data StreamType = Stdin | Stdout deriving Show---- | Get the reply message type for a request message type.-replyType :: MessageType -> Maybe MessageType-replyType KernelInfoRequestMessage  = Just KernelInfoReplyMessage-replyType ExecuteRequestMessage     = Just ExecuteReplyMessage-replyType CompleteRequestMessage    = Just CompleteReplyMessage-replyType ObjectInfoRequestMessage  = Just ObjectInfoReplyMessage-replyType ShutdownRequestMessage    = Just ShutdownReplyMessage-replyType _ = Nothing---- | Data for display: a string with associated MIME type.-data DisplayData = DisplayData MimeType ByteString deriving (Typeable, Generic)---- We can't print the actual data, otherwise this will be printed every--- time it gets computed because of the way the evaluator is structured.--- See how `displayExpr` is computed.-instance Show DisplayData where-  show _ = "DisplayData"---- Allow DisplayData serialization-instance Serialize DisplayData-instance Serialize MimeType---- | Possible MIME types for the display data.-type Width = Int-type Height = Int-data MimeType = PlainText-              | MimeHtml-              | MimePng Width Height-              | MimeJpg Width Height-              | MimeSvg-              | MimeLatex-              deriving (Eq, Typeable, Generic)---- Extract the plain text from a list of displays.-extractPlain :: [DisplayData] -> String-extractPlain disps =-  case find isPlain disps of-    Nothing -> ""-    Just (DisplayData PlainText bytestr) -> Char.unpack bytestr-  where-    isPlain (DisplayData mime _) = mime == PlainText--instance Show MimeType where-  show PlainText = "text/plain"-  show MimeHtml  = "text/html"-  show (MimePng _ _)   = "image/png" -  show (MimeJpg _ _)   = "image/jpeg"-  show MimeSvg   = "image/svg+xml"-  show MimeLatex = "text/latex"
− src/IPython/ZeroMQ.hs 
@@ -1,207 +0,0 @@-{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}--- | Description : Low-level ZeroMQ communication wrapper.------ 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--- takes a IPython profile specification and returns the channel interface to use.-module IPython.ZeroMQ (-  ZeroMQInterface (..),-  ZeroMQStdin(..),-  serveProfile,-  serveStdin,-  ) where--import qualified  Data.ByteString.Lazy  as ByteString-import            Data.ByteString       (ByteString)-import            Control.Concurrent-import            Control.Monad -import            System.IO.Unsafe-import            Data.Aeson            (encode)-import            System.ZMQ4           hiding (stdin)--import IPython.Types-import IPython.Message.Parser-import IPython.Message.Writer---- | 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--- transmitted to IPython. These channels should functionally serve as--- high-level sockets which speak Messages instead of ByteStrings.-data ZeroMQInterface = Channels {-  shellRequestChannel :: Chan Message,    -- ^ A channel populated with requests from the frontend.-  shellReplyChannel :: Chan Message,      -- ^ Writing to this channel causes a reply to be sent to the frontend.-  controlRequestChannel :: Chan Message,  -- ^ This channel is a duplicate of the shell request channel,-                                         -- ^ though using a different backend socket.-  controlReplyChannel :: Chan Message,    -- ^ This channel is a duplicate of the shell reply channel,-                                         -- ^ though using a different backend socket.-  iopubChannel :: Chan Message           -- ^ Writing to this channel sends an iopub message to the frontend.-  }--data ZeroMQStdin = StdinChannel {-  stdinRequestChannel :: Chan Message,-  stdinReplyChannel :: Chan Message-  }---- | Start responding on all ZeroMQ channels used to communicate with IPython--- | via the provided profile. Return a set of channels which can be used to--- | communicate with IPython in a more structured manner. -serveProfile :: Profile            -- ^ The profile specifying which ports and transport mechanisms to use.-             -> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets.-serveProfile profile = do-  -- Create all channels which will be used for higher level communication.-  shellReqChan <- newChan-  shellRepChan <- newChan-  controlReqChan <- dupChan shellReqChan-  controlRepChan <- dupChan shellRepChan-  iopubChan <- newChan-  let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan--  -- Create the context in a separate thread that never finishes. If-  -- withContext or withSocket complete, the context or socket become invalid.-  forkIO $ withContext $ \context -> do-    -- Serve on all sockets.-    forkIO $ serveSocket context Rep    (hbPort profile)      $ heartbeat channels-    forkIO $ serveSocket context Router (controlPort profile) $ control   channels-    forkIO $ serveSocket context Router (shellPort profile)   $ shell     channels--    -- The context is reference counted in this thread only. Thus, the last-    -- serveSocket cannot be asynchronous, because otherwise context would-    -- be garbage collectable - since it would only be used in other-    -- threads. Thus, keep the last serveSocket in this thread.-    serveSocket context Pub    (iopubPort profile)   $ iopub     channels--  return channels--serveStdin :: Profile -> IO ZeroMQStdin -serveStdin profile = do-  reqChannel <- newChan-  repChannel <- newChan-  -  -- Create the context in a separate thread that never finishes. If-  -- withContext or withSocket complete, the context or socket become invalid.-  forkIO $ withContext $ \context ->-    -- Serve on all sockets.-    serveSocket context Router (stdinPort profile) $ \socket -> do-      -- Read the request from the interface channel and send it.-      readChan reqChannel >>= sendMessage socket--      -- Receive a response and write it to the interface channel.-      receiveMessage socket >>= writeChan repChannel--  return $ StdinChannel reqChannel repChannel---- | Serve on a given socket in a separate thread. Bind the socket in the--- | given context and then loop the provided action, which should listen--- | on the socket and respond to any events.-serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO ()-serveSocket context socketType port action = void $-  withSocket context socketType $ \socket -> do-    bind socket $ "tcp://127.0.0.1:" ++ show port-    forever $ action socket---- | Listener on the heartbeat port. Echoes back any data it was sent.-heartbeat :: ZeroMQInterface -> Socket Rep -> IO ()-heartbeat _ socket = do-  -- Read some data.-  request <- receive socket--  -- Send it back.-  send socket [] request---- | Listener on the shell port. Reads messages and writes them to--- | the shell request channel. For each message, reads a response from the--- | shell reply channel of the interface and sends it back to the frontend. -shell :: ZeroMQInterface -> Socket Router -> IO ()-shell channels socket = do-  -- Receive a message and write it to the interface channel.-  receiveMessage socket >>= writeChan requestChannel--  -- Read the reply from the interface channel and send it.-  readChan replyChannel >>= sendMessage socket--  where-    requestChannel = shellRequestChannel channels-    replyChannel = shellReplyChannel channels---- | Listener on the shell port. Reads messages and writes them to--- | the shell request channel. For each message, reads a response from the--- | shell reply channel of the interface and sends it back to the frontend. -control :: ZeroMQInterface -> Socket Router -> IO ()-control channels socket = do-  -- Receive a message and write it to the interface channel.-  receiveMessage socket >>= writeChan requestChannel--  -- Read the reply from the interface channel and send it.-  readChan replyChannel >>= sendMessage socket--  where-    requestChannel = controlRequestChannel channels-    replyChannel =   controlReplyChannel channels---- | Send messages via the iopub channel.--- | This reads messages from the ZeroMQ iopub interface channel --- | and then writes the messages to the socket.-iopub :: ZeroMQInterface -> Socket Pub -> IO ()-iopub channels socket =-  readChan (iopubChannel channels) >>= sendMessage socket---- | Receive and parse a message from a socket.-receiveMessage :: Receiver a => Socket a -> IO Message-receiveMessage socket = do-  -- Read all identifiers until the identifier/message delimiter.-  idents <- readUntil "<IDS|MSG>"--  -- Ignore the signature for now.-  void next--  headerData <- next-  parentHeader <- next-  metadata <- next-  content <- next--  let message = parseMessage idents headerData parentHeader metadata content-  return message--  where-    -- Receive the next piece of data from the socket.-    next = receive socket--    -- Read data from the socket until we hit an ending string.-    -- Return all data as a list, which does not include the ending string.-    readUntil str = do-      line <- next-      if line /= str-      then do-        remaining <- readUntil str-        return $ line : remaining-      else return []-  --- | Encode a message in the IPython ZeroMQ communication protocol --- | and send it through the provided socket.-sendMessage :: Sender a => Socket a -> Message -> IO ()-sendMessage socket message = do-  let head = header message-      parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head-      idents = identifiers head-      metadata = "{}"-      content = encodeStrict message-      headStr = encodeStrict head--  -- Send all pieces of the message.-  mapM_ sendPiece idents-  sendPiece "<IDS|MSG>"-  sendPiece ""-  sendPiece headStr-  sendPiece parentHeaderStr-  sendPiece metadata--  -- Conclude transmission with content.-  sendLast content--  where-    sendPiece = send socket [SendMore]-    sendLast = send socket []--    -- Encode to a strict bytestring.-    encodeStrict :: ToJSON a => a -> ByteString-    encodeStrict = ByteString.toStrict . encode