mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-16 11:26:08 +00:00
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.
This commit is contained in:
David Raymond Christiansen
parent
0fa0b2105e
commit
93a4bf0092
236
ipython-kernel/examples/Calc.hs
Normal file
236
ipython-kernel/examples/Calc.hs
Normal file
@ -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)
|
||||
@ -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
|
||||
|
||||
208
ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
Normal file
208
ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
Normal file
@ -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 }
|
||||
Loading…
x
Reference in New Issue
Block a user