diff --git a/ipython-kernel/examples/Calc.hs b/ipython-kernel/examples/Calc.hs
new file mode 100644
index 0000000000000000000000000000000000000000..ba4cf1f8ba09c28725194849066607fc495a71bb
--- /dev/null
+++ b/ipython-kernel/examples/Calc.hs
@@ -0,0 +1,236 @@
+{-# 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)
diff --git a/ipython-kernel/ipython-kernel.cabal b/ipython-kernel/ipython-kernel.cabal
index 95c1335925339d1084ce3870123fdfe207f31bb8..7ca7ccfb2b840c024aa00155341485673a865acc 100644
--- a/ipython-kernel/ipython-kernel.cabal
+++ b/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
diff --git a/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs b/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5da049a2e5440dedcd39cd1aa9d1a445ae90eb8d
--- /dev/null
+++ b/ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
@@ -0,0 +1,208 @@
+{-# 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 }