Add automation for easily defining kernels

The module IHaskell.IPython.EasyKernel 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 in a file called Calc.hs.

Presently, there is no automation for creating the profile in the
.ipython directory. One should follow the IPython instructions for this.

ipython-kernel/examples/Calc.hs

+{-# 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 (easyKernel, KernelConfig(..))
+
+import System.Environment (getArgs)
+
+import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, runParser, (<?>))
+import qualified Text.Parsec.Token as P
+
+---------------------------------------------------------
+--  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 = "Hutton's Razor + extra"
+  , languageVersion = [0,1,0]
+  , 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 ["kernel", profileFile] <- getArgs
+          val <- newMVar 1
+          easyKernel profileFile (mkConfig val)

ipython-kernel/ipython-kernel.cabal

@@ -14,6 +14,10 @@ build-type:          Simple
 
 cabal-version:       >=1.16
 
+flag examples
+  description: Build example programs
+  default:     False
+
 library
   exposed-modules: IHaskell.IPython.Kernel
                    IHaskell.IPython.Types
@@ -22,6 +26,7 @@ library
                    IHaskell.IPython.Message.Writer
                    IHaskell.IPython.Message.Parser
                    IHaskell.IPython.Message.UUID
+                   IHaskell.IPython.EasyKernel
   -- other-modules:       
   other-extensions:    OverloadedStrings
   hs-source-dirs:      src
@@ -31,7 +36,23 @@ library
                        bytestring      >=0.10,
                        cereal          >=0.3,
                        containers      >=0.5,
+                       mtl             >=2.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,
+                  mtl            >=2.1,
+                  parsec         >=3.1,
+                  text           >= 0.11,
+                  transformers   >=0.3
+                  
+  if !flag(examples)
+    buildable: False

ipython-kernel/src/IHaskell/IPython/EasyKernel.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+-- | 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.
+--
+-- Presently, there is no automation for creating the profile in the
+-- .ipython directory. One should follow the IPython instructions for
+-- this.
+module IHaskell.IPython.EasyKernel (easyKernel, KernelConfig(..)) where
+
+import Data.Aeson (decode)
+
+import qualified Data.ByteString.Lazy as BL
+
+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.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
+  , languageVersion :: [Int] -- ^ The version of the language
+  , 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
+  }
+
+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 -> KernelConfig m output result -> 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 }