mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-16 11:26:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merging jupyter branch into master

Browse Source
This commit is contained in:
Andrew Gibiansky 2015-03-06 12:52:38 -08:00
commit 8eaf1aa65d
35 changed files with 4053 additions and 2633 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Hspec.hs
View File

@ -504,11 +504,7 @@ parseStringTests = describe "Parser" $ do
it "breaks without data kinds" $
parses "data X = 3" `like` [
#if MIN_VERSION_ghc(7, 8, 0)
ParseError (Loc 1 10) "Illegal literal in type (use DataKinds to enable): 3"
#else
ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3"
#endif
]
it "parses statements after imports" $ do

25
Setup.hs
View File

@ -1,25 +1,2 @@
import Distribution.Simple
import Control.Applicative ((<$>))
import Data.List (isInfixOf)
import Codec.Archive.Tar (create)
import System.Directory (getDirectoryContents)
-- This is currently *not used*. build-type is Simple.
-- This is because it breaks installing from Hackage.
main = defaultMainWithHooks simpleUserHooks {
preBuild = makeProfileTar
}
makeProfileTar args flags = do
putStrLn "Building profile.tar."
let profileDir = "profile"
tarFile = profileDir ++ "/profile.tar"
files <- filter realFile <$> filter notProfileTar <$> getDirectoryContents profileDir
print files
create tarFile profileDir files
preBuild simpleUserHooks args flags
where
notProfileTar str = not $ "profile.tar" `isInfixOf` str
realFile str = str /= "." && str /= ".."
main = defaultMain

10
build.sh
View File

@ -13,14 +13,8 @@ fi
# What to install.
INSTALLS=""
# Make the profile
cd profile
rm -f profile.tar
tar -cvf profile.tar * .profile_version
cd ..
# Remove my profile
rm -rf ~/.ipython/profile_haskell
# Remove my kernelspec
rm -rf ~/.ipython/kernels/haskell
# Compile dependencies.
if [ $# -gt 0 ]; then

0
profile/static/custom/custom.css → html/custom.css
View File

87
html/kernel.js Normal file
View File

@ -0,0 +1,87 @@
define(['require',
'codemirror/lib/codemirror',
'codemirror/addon/mode/loadmode',
'base/js/namespace',
'base/js/events',
'base/js/utils'],
function(require, CodeMirror, CodemirrorLoadmode, IPython, events, utils){
var onload = function(){
console.log('Kernel haskell kernel.js is loading.');
// add here logic that shoudl be run once per **page load**
// like adding specific UI, or changing the default value
// of codecell highlight.
// Set tooltips to be triggered after 800ms
IPython.tooltip.time_before_tooltip = 800;
// IPython keycodes.
var space = 32;
var downArrow = 40;
IPython.keyboard.keycodes.down = downArrow; // space
IPython.CodeCell.options_default['cm_config']['mode'] = 'haskell';
utils.requireCodeMirrorMode('haskell', function(){
// Create a multiplexing mode that uses Haskell highlighting by default but
// doesn't highlight command-line directives.
CodeMirror.defineMode("ihaskell", function(config) {
return CodeMirror.multiplexingMode(
CodeMirror.getMode(config, "haskell"),
{
open: /:(?=!)/, // Matches : followed by !, but doesn't consume !
close: /^(?!!)/, // Matches start of line not followed by !, doesn't consume character
mode: CodeMirror.getMode(config, "text/plain"),
delimStyle: "delimit"
}
);
});
cells = IPython.notebook.get_cells();
for(var i in cells){
c = cells[i];
if (c.cell_type === 'code') {
// Force the mode to be Haskell
// This is necessary, otherwise sometimes highlighting just doesn't happen.
// This may be an IPython bug.
c.code_mirror.setOption('mode', 'ihaskell');
c.auto_highlight();
}
}
});
// Prevent the pager from surrounding everything with a <pre>
IPython.Pager.prototype.append_text = function (text) {
this.pager_element.find(".container").append($('<div/>').html(IPython.utils.autoLinkUrls(text)));
};
events.on('shell_reply.Kernel', function() {
// Add logic here that should be run once per reply.
// Highlight things with a .highlight-code class
// The id is the mode with with to highlight
$('.highlight-code').each(function() {
var $this = $(this),
$code = $this.html(),
$unescaped = $('<div/>').html($code).text();
$this.empty();
// Never highlight this block again.
this.className = "";
CodeMirror(this, {
value: $unescaped,
mode: this.id,
lineNumbers: false,
readOnly: true
});
});
});
console.log('IHaskell kernel.js should have been loaded.')
} // end def of onload
return {onload:onload};
}
);

BIN
html/logo-64x64.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.9 KiB

7
ihaskell.cabal
View File

@ -43,10 +43,8 @@ build-type: Simple
cabal-version: >=1.16
data-files:
installation/ipython.sh
installation/virtualenv.sh
installation/run.sh
profile/profile.tar
html/kernel.js
html/logo-64x64.png
flag binPkgDb
default: True
@ -145,6 +143,7 @@ executable IHaskell
ghc >=7.6 && < 7.11,
ihaskell -any,
MissingH >=1.2,
here ==1.2.*,
text -any,
ipython-kernel >= 0.2,
unix >= 2.6

32
installation/ipython.sh
View File

@ -1,32 +0,0 @@
#!/bin/bash
set -e
# Which virtualenv to use.
VIRTUALENV=$1
# Activate the virtualenv.
source $VIRTUALENV/bin/activate
# Upgrade pip.
echo "Upgrading pip."
pip install --upgrade "pip>=1.4.1"
# Install all necessary dependencies with Pip.
echo "Installing dependency (pyzmq)."
pip install pyzmq==14.0.1
echo "Installing dependency (markupsafe)."
pip install markupsafe==0.18
echo "Installing dependency (jinja2)."
pip install jinja2==2.7.1
echo "Installing dependency (tornado)."
pip install tornado==3.1.1
echo "Installing dependency (pygments)."
pip install pygments==1.6
# Install IPython itself.
echo "Installing IPython (this may take a while)."
pip install ipython

20
installation/run.sh
View File

@ -1,20 +0,0 @@
#!/bin/bash
set -e
# Which virtualenv to use.
VIRTUALENV=$1
shift
# Activate the virtualenv, if it exists.
if [[ -f $VIRTUALENV/bin/activate ]]; then
source $VIRTUALENV/bin/activate;
fi
# Run IPython.
# Quotes around $@ are necessary to deal properly with spaces.
# Only add IHASKELL_IPYTHON_ARGS to notebook.
if [[ $1 == "notebook" ]]; then
ipython "$@" $IHASKELL_IPYTHON_ARGS
else
ipython "$@"
fi

18
installation/virtualenv.sh
View File

@ -1,18 +0,0 @@
#!/bin/bash
set -e
# Which version of virtualenv to use.
VIRTUALENV=virtualenv-1.9.1
# Where to install the virtualenv.
DESTINATION=$1
# Download virtualenv.
echo "Downloading virtualenv."
curl -O https://pypi.python.org/packages/source/v/virtualenv/$VIRTUALENV.tar.gz
tar xvfz $VIRTUALENV.tar.gz
cd $VIRTUALENV
# Create a virtualenv.
echo "Creating a virtualenv."
python virtualenv.py $DESTINATION

3
ipython-kernel/ipython-kernel.cabal
View File

@ -49,7 +49,8 @@ library
transformers >=0.3,
unix >=2.6,
uuid >=1.3,
zeromq4-haskell >=0.1
zeromq4-haskell >=0.1,
SHA >=1.6
-- Example program

2
ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
View File

@ -173,7 +173,7 @@ easyKernel :: (MonadIO m)
-> m ()
easyKernel profileFile config = do
prof <- liftIO $ getProfile profileFile
zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan) <-
zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <-
liftIO $ serveProfile prof
execCount <- liftIO $ newMVar 0
forever $ do

16
ipython-kernel/src/IHaskell/IPython/Kernel.hs
View File

@ -2,15 +2,11 @@
-- 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,
module X,
) where
import IHaskell.IPython.Types
import IHaskell.IPython.Message.Writer
import IHaskell.IPython.Message.Parser
import IHaskell.IPython.Message.UUID
import IHaskell.IPython.ZeroMQ
import IHaskell.IPython.Types as X
import IHaskell.IPython.Message.Writer as X
import IHaskell.IPython.Message.Parser as X
import IHaskell.IPython.Message.UUID as X
import IHaskell.IPython.ZeroMQ as X

228
ipython-kernel/src/IHaskell/IPython/Message/Parser.hs
View File

@ -6,16 +6,14 @@
-- `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
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
@ -23,16 +21,16 @@ type LByteString = Lazy.ByteString
-- | 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 =
-> 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 }
messageWithoutHeader = parser messageType $ Lazy.fromStrict content
in messageWithoutHeader { header = header }
----- Module internals -----
@ -42,50 +40,50 @@ parseHeader :: [ByteString] -- ^ The list of identifiers.
-> 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 == "{}"
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)
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)
-- 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
-> 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 HistoryRequestMessage = historyRequestParser
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.
@ -99,7 +97,7 @@ kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader }
-- 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 =
executeRequestParser content =
let parser obj = do
code <- obj .: "code"
silent <- obj .: "silent"
@ -108,84 +106,74 @@ executeRequestParser content =
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 = []
}
Success (code, silent, storeHistory, allowStdin) = parse parser decoded
in ExecuteRequest { header = noHeader
, getCode = code
, getSilent = silent
, getAllowStdin = allowStdin
, getStoreHistory = storeHistory
, getUserVariables = []
, getUserExpressions = []
}
requestParser parser content = parsed
where
Success parsed = parse parser decoded
Just decoded = decode content
historyRequestParser :: LByteString -> Message
historyRequestParser = requestParser $ \obj ->
HistoryRequest noHeader <$> obj .: "output" <*> obj .: "raw" <*> historyAccessType obj
where
-- TODO: Implement full history access type parsing from message spec
historyAccessType obj = do
accessTypeStr <- obj .: "hist_access_type"
return $
case accessTypeStr of
"range" -> HistoryRange
"tail" -> HistoryTail
"search" -> HistorySearch
str -> error $ "Unknown history access type: " ++ str
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
completeRequestParser = requestParser $ \obj -> do
code <- obj .: "block" <|> return ""
codeLine <- obj .: "line"
pos <- obj .: "cursor_pos"
return $ CompleteRequest noHeader code codeLine pos
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
objectInfoRequestParser = requestParser $ \obj -> do
oname <- obj .: "oname"
dlevel <- obj .: "detail_level"
return $ ObjectInfoRequest noHeader oname dlevel
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
shutdownRequestParser = requestParser $ \obj -> do
code <- obj .: "restart"
return $ ShutdownRequest noHeader code
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
inputReplyParser = requestParser $ \obj -> do
value <- obj .: "value"
return $ InputReply noHeader value
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
commOpenParser = requestParser $ \obj -> do
uuid <- obj .: "comm_id"
name <- obj .: "target_name"
value <- obj .: "data"
return $ CommOpen noHeader name uuid value
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
commDataParser = requestParser $ \obj -> do
uuid <- obj .: "comm_id"
value <- obj .: "data"
return $ CommData noHeader uuid value
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
commCloseParser = requestParser $ \obj -> do
uuid <- obj .: "comm_id"
value <- obj .: "data"
return $ CommClose noHeader uuid value

5
ipython-kernel/src/IHaskell/IPython/Message/Writer.hs
View File

@ -103,6 +103,11 @@ instance ToJSON Message where
"data" .= commData req
]
toJSON req@HistoryReply{} = object [ "history" .= map tuplify (historyReply req) ]
where tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of
Left inp -> toJSON inp
Right (inp, out) -> toJSON out)
toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body

204
ipython-kernel/src/IHaskell/IPython/Types.hs
View File

@ -8,6 +8,9 @@ module IHaskell.IPython.Types (
Port(..),
IP(..),
-- * IPython kernelspecs
KernelSpec(..),
-- * IPython messaging protocol
Message(..),
MessageHeader(..),
@ -18,6 +21,8 @@ module IHaskell.IPython.Types (
StreamType(..),
ExecutionState(..),
ExecuteReplyStatus(..),
HistoryAccessType(..),
HistoryReplyElement(..),
replyType,
-- ** IPython display data message
@ -48,25 +53,24 @@ type Port = Int
type IP = String
-- | The transport mechanism used to communicate with the IPython frontend.
data Transport
= TCP -- ^ Default transport mechanism via TCP.
deriving (Show, Read)
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)
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.
, signatureKey :: ByteString -- ^ The HMAC encryption key.
}
deriving (Show, Read)
-- Convert the kernel profile to and from JSON.
instance FromJSON Profile where
parseJSON (Object v) =
parseJSON (Object v) =
Profile <$> v .: "ip"
<*> v .: "transport"
<*> v .: "stdin_port"
@ -74,20 +78,20 @@ instance FromJSON Profile where
<*> v .: "hb_port"
<*> v .: "shell_port"
<*> v .: "iopub_port"
<*> v .: "key"
<*> (Text.encodeUtf8 <$> 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
]
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" .= Text.decodeUtf8 (signatureKey profile)
]
instance FromJSON Transport where
parseJSON (String mech) =
@ -100,6 +104,22 @@ instance ToJSON Transport where
toJSON TCP = String "tcp"
-------------------- IPython Kernelspec Types ----------------------
data KernelSpec = KernelSpec {
kernelDisplayName :: String, -- ^ Name shown to users to describe this kernel (e.g. "Haskell")
kernelLanguage :: String, -- ^ Name for the kernel; unique kernel identifier (e.g. "haskell")
kernelCommand :: [String] -- ^ Command to run to start the kernel. One of the strings may be
-- @"{connection_file}"@, which will be replaced by the path to a
-- kernel profile file (see @Profile@) when the command is run.
} deriving (Eq, Show)
instance ToJSON KernelSpec where
toJSON kernelspec = object
[ "argv" .= kernelCommand kernelspec
, "display_name" .= kernelDisplayName kernelspec
, "language" .= kernelLanguage kernelspec
]
-------------------- IPython Message Types ----------------------
-- | A message header with some metadata.
@ -151,56 +171,63 @@ data MessageType = KernelInfoReplyMessage
| CommOpenMessage
| CommDataMessage
| CommCloseMessage
| HistoryRequestMessage
| HistoryReplyMessage
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"
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"
showMessageType HistoryRequestMessage = "history_request"
showMessageType HistoryReplyMessage = "history_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
"comm_open" -> return CommOpenMessage
"comm_msg" -> return CommDataMessage
"comm_close" -> return CommCloseMessage
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
"history_request" -> return HistoryRequestMessage
"history_reply" -> return HistoryReplyMessage
_ -> fail ("Unknown message type: " ++ show s)
_ -> fail ("Unknown message type: " ++ show s)
parseJSON _ = fail "Must be a string."
@ -343,9 +370,35 @@ data Message
commData :: Value
}
| HistoryRequest {
header :: MessageHeader,
historyGetOutput :: Bool, -- ^ If True, also return output history in the resulting dict.
historyRaw :: Bool, -- ^ If True, return the raw input history, else the transformed input.
historyAccessType :: HistoryAccessType -- ^ What history is being requested.
}
| HistoryReply {
header :: MessageHeader,
historyReply :: [HistoryReplyElement]
}
| SendNothing -- Dummy message; nothing is sent.
deriving Show
-- | Ways in which the frontend can request history.
-- TODO: Implement fields as described in messaging spec.
data HistoryAccessType = HistoryRange
| HistoryTail
| HistorySearch
deriving (Eq, Show)
-- | Reply to history requests.
data HistoryReplyElement = HistoryReplyElement { historyReplySession :: Int
, historyReplyLineNumber :: Int
, historyReplyContent :: Either String (String, String)
}
deriving (Eq, Show)
-- | Possible statuses in the execution reply messages.
data ExecuteReplyStatus = Ok | Err | Abort
@ -362,12 +415,13 @@ 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
replyType KernelInfoRequestMessage = Just KernelInfoReplyMessage
replyType ExecuteRequestMessage = Just ExecuteReplyMessage
replyType CompleteRequestMessage = Just CompleteReplyMessage
replyType ObjectInfoRequestMessage = Just ObjectInfoReplyMessage
replyType ShutdownRequestMessage = Just ShutdownReplyMessage
replyType HistoryRequestMessage = Just HistoryReplyMessage
replyType _ = Nothing
-- | Data for display: a string with associated MIME type.
data DisplayData = DisplayData MimeType Text deriving (Typeable, Generic)

87
ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs
View File

@ -11,30 +11,35 @@ module IHaskell.IPython.ZeroMQ (
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 qualified Data.ByteString.Lazy as LBS
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Char
import Control.Concurrent
import Control.Monad
import System.IO.Unsafe
import Data.Aeson (encode)
import System.ZMQ4 hiding (stdin)
import Data.Digest.Pure.SHA as SHA
import Data.Monoid ((<>))
import IHaskell.IPython.Types
import IHaskell.IPython.Message.Parser
import IHaskell.IPython.Message.Writer
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 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.
hmacKey :: ByteString -- ^ Key used to sign messages.
}
data ZeroMQStdin = StdinChannel {
@ -54,7 +59,7 @@ serveProfile profile = do
controlReqChan <- dupChan shellReqChan
controlRepChan <- dupChan shellRepChan
iopubChan <- newChan
let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan
let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan (signatureKey profile)
-- Create the context in a separate thread that never finishes. If
-- withContext or withSocket complete, the context or socket become invalid.
@ -83,7 +88,7 @@ serveStdin profile = do
-- 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
readChan reqChannel >>= sendMessage (signatureKey profile) socket
-- Receive a response and write it to the interface channel.
receiveMessage socket >>= writeChan repChannel
@ -117,7 +122,7 @@ shell channels socket = do
receiveMessage socket >>= writeChan requestChannel
-- Read the reply from the interface channel and send it.
readChan replyChannel >>= sendMessage socket
readChan replyChannel >>= sendMessage (hmacKey channels) socket
where
requestChannel = shellRequestChannel channels
@ -132,7 +137,7 @@ control channels socket = do
receiveMessage socket >>= writeChan requestChannel
-- Read the reply from the interface channel and send it.
readChan replyChannel >>= sendMessage socket
readChan replyChannel >>= sendMessage (hmacKey channels) socket
where
requestChannel = controlRequestChannel channels
@ -143,7 +148,7 @@ control channels socket = do
-- | and then writes the messages to the socket.
iopub :: ZeroMQInterface -> Socket Pub -> IO ()
iopub channels socket =
readChan (iopubChannel channels) >>= sendMessage socket
readChan (iopubChannel channels) >>= sendMessage (hmacKey channels) socket
-- | Receive and parse a message from a socket.
receiveMessage :: Receiver a => Socket a -> IO Message
@ -177,21 +182,15 @@ receiveMessage socket = do
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
-- and send it through the provided socket. Sign it using HMAC
-- with SHA-256 using the provided key.
sendMessage :: Sender a => ByteString -> Socket a -> Message -> IO ()
sendMessage _ _ SendNothing = return ()
sendMessage hmacKey socket message = do
-- Send all pieces of the message.
mapM_ sendPiece idents
sendPiece "<IDS|MSG>"
sendPiece ""
sendPiece signature
sendPiece headStr
sendPiece parentHeaderStr
sendPiece metadata
@ -205,4 +204,20 @@ sendMessage socket message = do
-- Encode to a strict bytestring.
encodeStrict :: ToJSON a => a -> ByteString
encodeStrict = ByteString.toStrict . encode
encodeStrict = LBS.toStrict . encode
-- Signature for the message using HMAC SHA-256.
signature :: ByteString
signature = hmac $ headStr <> parentHeaderStr <> metadata <> content
-- Compute the HMAC SHA-256 signature of a bytestring message.
hmac :: ByteString -> ByteString
hmac = Char.pack . SHA.showDigest . SHA.hmacSha256 (LBS.fromStrict hmacKey) . LBS.fromStrict
-- Pieces of the message.
head = header message
parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head
idents = identifiers head
metadata = "{}"
content = encodeStrict message
headStr = encodeStrict head

4557
notebooks/IHaskell.ipynb
View File

File diff suppressed because one or more lines are too long

1
profile/.profile_version
View File

@ -1 +0,0 @@
0.4.2.0

13
profile/ipython_config.py
View File

@ -1,13 +0,0 @@
# Available Variables:
# exe: Path to IHaskell kernel.
c = get_config()
c.KernelManager.kernel_cmd = [exe, 'kernel', '{connection_file}']
c.Session.key = b''
c.Session.keyfile = b''
# Syntax highlight properly in Haskell notebooks.
c.NbConvertBase.default_language = "haskell"
# Where to look for templates.
template_path = "/".join(__file__.split("/")[:-1] + ["templates"])
c.TemplateExporter.template_path = [template_path]

4
profile/ipython_console_config.py
View File

@ -1,4 +0,0 @@
# Empty.
c = get_config()
c.TerminalIPythonApp.display_banner = False
c.TerminalInteractiveShell.confirm_exit = False

2
profile/ipython_notebook_config.py
View File

@ -1,2 +0,0 @@
c = get_config()
c.NotebookApp.port = 8778

6
profile/ipython_qtconsole_config.py
View File

@ -1,6 +0,0 @@
c = get_config()
# QtConsole try to guess base on Python lexing when the input is done to auto
# execute. This Fails on Haskell, and while it is not possible to do the
# lexing in the kernel just deactivate functionality
c.IPythonWidget.execute_on_complete_input = False

BIN
profile/static/base/images/ipynblogo.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 39 KiB

177
profile/static/custom/conceal/conceal.js
View File

@ -1,177 +0,0 @@
// Implement Haskell-Conceal for IPython notebook with IHaskell.
"using strict";
var concealExtension = (function() {
var Pos = CodeMirror.Pos;
// Concealable elements
var conceals = {
"\\": "λ",
".": "∘",
"/=": "≠",
"::": "∷",
">>": "»",
"<<": "«",
"->": "→",
"<-": "←",
"<>": "•",
"!!": "‼",
"=>": "⇒",
">>=": ">>=",
"forall": "∀",
"<=": "≤",
">=": "≥",
};
// Concealable infix elements
var infixConceals = {
"intersect": "∩",
"intersection": "∩",
"union": "∪",
"elem": "∈",
"notElem": "∉",
};
// Return the previous CodeMirror token
function prevToken(editor, token, line) {
var before = editor.getTokenAt(Pos(line, token.start));
return before;
};
// Return the next CodeMirror token
function nextToken(editor, token, line) {
var after = editor.getTokenAt(Pos(line, token.end + 1));
return after;
};
// Create a DOM element for a given conceal element
function concealDOM(data) {
var span = document.createElement("span");
span.innerHTML = data;
return span;
}
// Process a non-infix conceal token.
function markNonInfixToken(editor, line, token) {
// We have a special case for the dot operator. We only want to
// convert it to a fancy composition if there is a space before it.
// This preserves things like [1..1000] which CodeMirror parses
// incorrectly and also lets you write with lenses as record^.a.b.c,
// which looks better.
if (token.string == ".") {
var handle = editor.getLineHandle(line);
var ch = token.start;
if (handle.text[ch - 1] != ' ') {
return false;
}
}
// Check if this is a normal concealable element. (non-infix)
for (var str in conceals) {
if (conceals.hasOwnProperty(str)) {
if (token.string == str) {
editor.markText(Pos(line, token.start), Pos(line, token.end), {
replacedWith: concealDOM(conceals[str]),
});
return true;
}
}
}
return false;
}
function markInfixToken(editor, line, prev, token, next) {
if (prev.string != "`" || next.string != "`") {
return false;
}
for (var str in infixConceals) {
if (infixConceals.hasOwnProperty(str)) {
if (token.string == str) {
editor.markText(Pos(line, prev.start), Pos(line, next.end), {
replacedWith: concealDOM(infixConceals[str]),
});
return true;
}
}
}
return true;
}
// Mark a token if necessary (mark means change how it looks).
function markToken(editor, line, token) {
// If it's a backtick, it might be the end of an infix conceal.
if (token.string == "`") {
var prev = prevToken(editor, token, line);
var prev2 = prevToken(editor, prev, line);
return markInfixToken(editor, line, prev2, prev, token);
}
// Otherwise, try it as a normal non-infix token
// Or as the center of an infix token.
else {
var marked = markNonInfixToken(editor, line, token);
if (marked) {
return true;
}
// Try it as the middle of an infix set
var prev = prevToken(editor, token, line);
var next = nextToken(editor, token, line);
return markInfixToken(editor, line, prev, token, next);
}
}
/**
* Activate conceal in CodeMirror options, don't overwrite other settings
*/
function concealCell(editor) {
// Initialize all tokens. Just look at the token at every character.
editor.eachLine(function (handle) {
var l = editor.getLineNumber(handle);
for (var c = 0; c < handle.text.length; c++) {
var token = editor.getTokenAt(Pos(l, c), true);
markToken(editor, l, token);
}
});
editor.on("change", function() {
var cursor = editor.getCursor();
var token = editor.getTokenAt(cursor, true);
markToken(editor, cursor.line, token);
});
}
/**
* Add conceal to new cell
*
*/
createCell = function (event,nbcell,nbindex) {
var cell = nbcell.cell;
if ((cell instanceof IPython.CodeCell)) {
var editor = cell.code_mirror;
concealCell(editor)
}
};
/**
* Add conceal to existing cells
*/
initExtension = function(event) {
var cells = IPython.notebook.get_cells();
for(var i in cells){
var cell = cells[i];
if ((cell instanceof IPython.CodeCell)) {
var editor = cell.code_mirror;
concealCell(editor);
}
}
$([IPython.events]).on('create.Cell',createCell);
}
IPython.concealCell = concealCell;
require([], initExtension);
})();

91
profile/static/custom/custom.js
View File

@ -1,91 +0,0 @@
$([IPython.events]).on('notebook_loaded.Notebook', function(){
// add here logic that should be run once per **notebook load**
// (!= page load), like restarting a checkpoint
var md = IPython.notebook.metadata;
if(md.language){
console.log('language already defined and is :', md.language);
} else {
md.language = 'haskell' ;
console.log('add metadata hint that language is haskell...');
}
});
$([IPython.events]).on('app_initialized.NotebookApp', function(){
// add here logic that shoudl be run once per **page load**
// like adding specific UI, or changing the default value
// of codecell highlight.
// Set tooltips to be triggered after 800ms
IPython.tooltip.time_before_tooltip = 800;
// IPython keycodes.
var space = 32;
var downArrow = 40;
IPython.keyboard.keycodes.down = downArrow; // space
IPython.CodeCell.options_default['cm_config']['mode'] = 'haskell';
CodeMirror.requireMode('haskell', function(){
// Create a multiplexing mode that uses Haskell highlighting by default but
// doesn't highlight command-line directives.
CodeMirror.defineMode("ihaskell", function(config) {
return CodeMirror.multiplexingMode(
CodeMirror.getMode(config, "haskell"),
{
open: /:(?=!)/, // Matches : followed by !, but doesn't consume !
close: /^(?!!)/, // Matches start of line not followed by !, doesn't consume character
mode: CodeMirror.getMode(config, "text/plain"),
delimStyle: "delimit"
}
);
});
cells = IPython.notebook.get_cells();
for(var i in cells){
c = cells[i];
if (c.cell_type === 'code') {
// Force the mode to be Haskell
// This is necessary, otherwise sometimes highlighting just doesn't happen.
// This may be an IPython bug.
c.code_mirror.setOption('mode', 'ihaskell');
c.auto_highlight()
}
}
// We can only load the conceal scripts once all cells have mode 'haskell'
require(['/static/custom/conceal/conceal.js']);
});
// Prevent the pager from surrounding everything with a <pre>
IPython.Pager.prototype.append_text = function (text) {
this.pager_element.find(".container").append($('<div/>').html(IPython.utils.autoLinkUrls(text)));
};
require(['/static/custom/hide_input.js']);
});
$([IPython.events]).on('shell_reply.Kernel', function() {
// Add logic here that should be run once per reply.
// Highlight things with a .highlight-code class
// The id is the mode with with to highlight
$('.highlight-code').each(function() {
var $this = $(this),
$code = $this.html(),
$unescaped = $('<div/>').html($code).text();
$this.empty();
// Never highlight this block again.
this.className = "";
CodeMirror(this, {
value: $unescaped,
mode: this.id,
lineNumbers: false,
readOnly: true
});
});
});

166
profile/static/custom/hide_input.js
View File

@ -1,166 +0,0 @@
// This is an extension that enables hiding input cells. It adds a button to
// the cell toolbars to hide and unhide cells, as well as command-mode
// keybindings to left and right arrow keys. Whether or not a cell is hidden is
// stored in the metadata and thus is saved in the notebook. A custom template
// which checks for the "hidden" field in cell metadata could be used to have
// nbconvert ignore hidden cells.
"using strict";
var hideInputCellExtension = (function(){
var Pos = CodeMirror.Pos;
// What text to show for hidden cells. This has to be created every time,
// otherwise you wouldn't be able to hide more than one cell.
var createHiding = function() {
var hiding = document.createElement("span");
hiding.innerHTML = "…";
return hiding;
}
// UI Generator for a simple toggle button. The model for this code is
// taken from IPython.CellToolbar.utils.checkbox_ui_Generator.
IPython.CellToolbar.utils.button_ui_generator = function(name, handler, textfun){
return function(div, cell, celltoolbar) {
var button_container = $(div);
var initText = textfun(cell);
var button = $('<input/>').attr('type', 'button')
.attr('value', initText)
.css('height', '1.1em')
.css('font-size', 20);
var lbl = $('<label/>').append($('<span/>').text(name));
lbl.append(button);
button.click(function() {
handler(cell);
var newText = textfun(cell);
button.attr('value', newText);
});
cell.hide_button = button;
cell.button_container = button_container;
button_container.append($('<div/>').append(lbl));
};
};
// Ensure a cell has the metadata object. Sometimes they don't for unknown reasons.
// Might have something to do with ordering of cell initialization, so this is a hack.
var requireMetadata = function(cell) {
if(cell.metadata === undefined) {
cell.metadata = {};
cell.metadata.hidden = false;
}
}
// Return the text to show in the button for this cell.
var textToShow = function(cell) {
// What text to show on buttons when concealed or shown.
var concealedButton = "⇦";
var shownButton = "⇩";
requireMetadata(cell);
if(cell.metadata.hidden) {
return concealedButton;
} else {
return shownButton;
}
};
// Update whether a cell is visible.
var updateCellVisibility = function(cell, visible) {
cell.metadata.hidden = visible;
if(cell.metadata.hidden) {
if (cell.mark === undefined) {
var editor = cell.code_mirror;
var nLines = editor.lineCount();
var firstLineLen = editor.getLine(0).length;
var lastLineLen = editor.getLine(nLines - 1).length;
var mark = editor.markText(Pos(0, firstLineLen), Pos(nLines, lastLineLen + 1), {
replacedWith: createHiding(),
});
cell.mark = mark;
}
} else if (cell.mark !== undefined) {
cell.mark.clear();
cell.mark = undefined;
}
cell.hide_button.attr('value', textToShow(cell));
}
// Create and register the method that creates the hide arrow.
var flag_name = 'hide_input';
var cell_flag_init = IPython.CellToolbar.utils.button_ui_generator("", function(cell) {
// Toggle cell visibility.
updateCellVisibility(cell, !cell.metadata.hidden);
}, textToShow);
IPython.CellToolbar.register_callback(flag_name, cell_flag_init);
// Create and register the toolbar with IPython.
IPython.CellToolbar.register_preset('Hiding', [flag_name]);
var updateCellToolbar = function(cell) {
var type = cell.cell_type;
if(type != 'code') {
// Set cell to visible.
updateCellVisibility(cell, false);
// Hide the toolbar on Markdown and other non-code cells.
cell.celltoolbar.hide();
} else {
// Show toolbar on code cells.
cell.celltoolbar.show();
}
};
var initExtension = function(event) {
IPython.CellToolbar.activate_preset("Hiding");
IPython.keyboard_manager.command_shortcuts.add_shortcuts({
"left": {
help: "Hide an input cell.",
help_index: "zz",
handler: function(event) {
var cell = IPython.notebook.get_selected_cell();
updateCellVisibility(cell, true);
}
},
"right": {
help: "Unhide an input cell.",
help_index: "zz",
handler: function(event) {
var cell = IPython.notebook.get_selected_cell();
updateCellVisibility(cell, false);
}
}
});
var cells = IPython.notebook.get_cells();
for(var i in cells){
var cell = cells[i];
if ((cell instanceof IPython.CodeCell)) {
updateCellVisibility(cell);
}
updateCellToolbar(cell);
}
$([IPython.events]).on('create.Cell', requireMetadata);
}
// When enetering edit mode, unhide the current cell so you can edit it.
$([IPython.events]).on('edit_mode.Cell',function () {
var cell = IPython.notebook.get_selected_cell();
if(cell.cell_type != "markdown") {
updateCellVisibility(cell, false);
}
});
require([], initExtension);
$([IPython.events]).on('selected_cell_type_changed.Notebook', function (event, data) {
var cell = IPython.notebook.get_selected_cell();
updateCellToolbar(cell);
});
console.log("Loaded input cell hiding extension.")
})();

1
profile/templates/ihaskell-basic.tpl
View File

@ -1 +0,0 @@
{%- extends 'basic.tpl' -%}

161
profile/templates/ihaskell.tpl
View File

@ -1,161 +0,0 @@
{%- extends 'full.tpl' -%}
{%- block header -%}
<!DOCTYPE html>
<html>
<head>
<meta charset="utf-8" />
<title>{{resources['metadata']['name']}}</title>
{% for css in resources.inlining.css -%}
<style type="text/css">
{{ css }}
</style>
{% endfor %}
<style type="text/css">
/* Overrides of notebook CSS for static HTML export */
body {
overflow: visible;
padding: 8px;
}
.input_area {
padding: 0.2em;
}
pre {
padding: 0.2em;
border: none;
margin: 0px;
font-size: 13px;
}
</style>
<!-- Our custom CSS -->
<style type="text/css">
/*
Custom IHaskell CSS.
*/
/* Styles used for the Hoogle display in the pager */
.hoogle-doc {
display: block;
padding-bottom: 1.3em;
padding-left: 0.4em;
}
.hoogle-code {
display: block;
font-family: monospace;
white-space: pre;
}
.hoogle-text {
display: block;
}
.hoogle-name {
color: green;
font-weight: bold;
}
.hoogle-head {
font-weight: bold;
}
.hoogle-sub {
display: block;
margin-left: 0.4em;
}
.hoogle-package {
font-weight: bold;
font-style: italic;
}
.hoogle-module {
font-weight: bold;
}
/* Styles used for basic displays */
.get-type {
color: green;
font-weight: bold;
font-family: monospace;
display: block;
white-space: pre;
}
.show-type {
color: green;
font-weight: bold;
font-family: monospace;
margin-left: 1em;
}
.mono {
font-family: monospace;
display: block;
}
.err-msg {
color: red;
font-style: italic;
font-family: monospace;
white-space: pre;
display: block;
}
#unshowable {
color: red;
font-weight: bold;
}
.err-msg.in.collapse {
padding-top: 0.7em;
}
/* Code that will get highlighted before it is highlighted */
.highlight-code {
white-space: pre;
font-family: monospace;
}
/* Hlint styles */
.suggestion-warning {
font-weight: bold;
color: rgb(200, 130, 0);
}
.suggestion-error {
font-weight: bold;
color: red;
}
.suggestion-name {
font-weight: bold;
}
</style>
<script src="https://c328740.ssl.cf1.rackcdn.com/mathjax/latest/MathJax.js?config=TeX-AMS_HTML" type="text/javascript"></script>
<script type="text/javascript">
init_mathjax = function() {
if (window.MathJax) {
// MathJax loaded
MathJax.Hub.Config({
tex2jax: {
inlineMath: [ ['$','$'], ["\\(","\\)"] ],
displayMath: [ ['$$','$$'], ["\\[","\\]"] ]
},
displayAlign: 'left', // Change this to 'center' to center equations.
"HTML-CSS": {
styles: {'.MathJax_Display': {"margin": 0}}
}
});
MathJax.Hub.Queue(["Typeset",MathJax.Hub]);
}
}
init_mathjax();
</script>
</head>
{%- endblock header -%}
{% block body %}
<body>
{{ super() }}
</body>
{%- endblock body %}

64
src/IHaskell/Eval/Evaluate.hs
View File

@ -98,8 +98,8 @@ typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes)
fullPrefixes = map (++ ".") ignoreTypePrefixes
useStringType = replace "[Char]" "String"
write :: GhcMonad m => String -> m ()
write x = when debug $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
write :: GhcMonad m => KernelState -> String -> m ()
write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
type Interpreter = Ghc
@ -212,7 +212,6 @@ initializeImports = do
let implicitPrelude = importDecl { ideclImplicit = True }
-- Import modules.
mapM_ (write . ("Importing " ++ )) displayImports
imports <- mapM parseImportDecl $ globalImports ++ displayImports
setContext $ map IIDecl $ implicitPrelude : imports
@ -221,7 +220,6 @@ initializeItVariable :: Interpreter ()
initializeItVariable = do
-- This is required due to the way we handle `it` in the wrapper
-- statements - if it doesn't exist, the first statement will fail.
write "Setting `it` to unit."
void $ runStmt "let it = ()" RunToCompletion
-- | Publisher for IHaskell outputs. The first argument indicates whether
@ -355,7 +353,7 @@ wrapExecution state exec = safely state $ exec >>= \res ->
-- resulted in an error.
evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand _ (Import importStr) state = wrapExecution state $ do
write $ "Import: " ++ importStr
write state $ "Import: " ++ importStr
evalImport importStr
-- Warn about `it` variable.
@ -365,7 +363,7 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do
else mempty
evalCommand _ (Module contents) state = wrapExecution state $ do
write $ "Module:\n" ++ contents
write state $ "Module:\n" ++ contents
-- Write the module contents to a temporary file in our work directory
namePieces <- getModuleName contents
@ -424,7 +422,7 @@ evalCommand output (Directive SetDynFlag flags) state =
-- For a single flag.
[flag] -> do
write $ "DynFlags: " ++ flags
write state $ "DynFlags: " ++ flags
-- Check if this is setting kernel options.
case find (elem flag . getSetName) kernelOpts of
@ -479,12 +477,12 @@ evalCommand output (Directive SetDynFlag flags) state =
}
evalCommand output (Directive SetExtension opts) state = do
write $ "Extension: " ++ opts
write state $ "Extension: " ++ opts
let set = concatMap (" -X" ++) $ words opts
evalCommand output (Directive SetDynFlag set) state
evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
write $ "Load Module: " ++ mods
write state $ "Load Module: " ++ mods
let stripped@(firstChar:remainder) = mods
(modules, removeModule) =
case firstChar of
@ -500,7 +498,7 @@ evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
return mempty
evalCommand a (Directive SetOption opts) state = do
write $ "Option: " ++ opts
write state $ "Option: " ++ opts
let (existing, nonExisting) = partition optionExists $ words opts
if not $ null nonExisting
then
@ -528,18 +526,18 @@ evalCommand a (Directive SetOption opts) state = do
find (elem opt . getOptionName) kernelOpts
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
write $ "Type: " ++ expr
write state $ "Type: " ++ expr
formatType <$> ((expr ++ " :: ") ++ ) <$> getType expr
evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do
write $ "Kind: " ++ expr
write state $ "Kind: " ++ expr
(_, kind) <- GHC.typeKind False expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr kind
return $ formatType $ expr ++ " :: " ++ typeStr
evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
write $ "Load: " ++ name
write state $ "Load: " ++ name
let filename = if endswith ".hs" name
then name
@ -640,7 +638,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetHelp _) state = do
write "Help via :help or :?."
write state "Help via :help or :?."
return EvalOut {
evalStatus = Success,
evalResult = Display [out],
@ -664,15 +662,16 @@ evalCommand _ (Directive GetHelp _) state = do
,"Any prefix of the commands will also suffice, e.g. use :ty for :type."
,""
,"Options:"
," lint - enable or disable linting."
," svg - use svg output (cannot be resized)."
," show-types - show types of all bound names"
," show-errors - display Show instance missing errors normally."
," lint – enable or disable linting."
," svg – use svg output (cannot be resized)."
," show-types – show types of all bound names"
," show-errors – display Show instance missing errors normally."
," pager – use the pager to display results of :info, :doc, :hoogle, etc."
]
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetInfo str) state = safely state $ do
write $ "Info: " ++ str
write state $ "Info: " ++ str
-- Get all the info for all the names we're given.
strings <- getDescription str
@ -702,7 +701,7 @@ evalCommand _ (Directive GetDoc query) state = safely state $ do
return $ hoogleResults state results
evalCommand output (Statement stmt) state = wrapExecution state $ do
write $ "Statement:\n" ++ stmt
write state $ "Statement:\n" ++ stmt
let outputter str = output $ IntermediateResult $ Display [plain str]
(printed, result) <- capturedStatement outputter stmt
case result of
@ -716,7 +715,7 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
nonItNames = filter (not . isItName) allNames
output = [plain printed | not . null $ strip printed]
write $ "Names: " ++ show allNames
write state $ "Names: " ++ show allNames
-- Display the types of all bound names if the option is on.
-- This is similar to GHCi :set +t.
@ -744,7 +743,7 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
RunBreak{} -> error "Should not break."
evalCommand output (Expression expr) state = do
write $ "Expression:\n" ++ expr
write state $ "Expression:\n" ++ expr
-- Try to use `display` to convert our type into the output
-- Dislay If typechecking fails and there is no appropriate
@ -762,15 +761,15 @@ evalCommand output (Expression expr) state = do
let anyExpr = printf "((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))" expr :: String
isTHDeclaration <- liftM2 (&&) (attempt $ exprType declExpr) (not <$> attempt (exprType anyExpr))
write $ "Can Display: " ++ show canRunDisplay
write $ "Is Widget: " ++ show isWidget
write $ "Is Declaration: " ++ show isTHDeclaration
write state $ "Can Display: " ++ show canRunDisplay
write state $ "Is Widget: " ++ show isWidget
write state $ "Is Declaration: " ++ show isTHDeclaration
if isTHDeclaration
-- If it typechecks as a DecsQ, we do not want to display the DecsQ,
-- we just want the declaration made.
then do
write $ "Suppressing display for template haskell declaration"
write state $ "Suppressing display for template haskell declaration"
GHC.runDecls expr
return EvalOut {
evalStatus = Success,
@ -816,9 +815,9 @@ evalCommand output (Expression expr) state = do
isShowError (ManyDisplay _) = False
isShowError (Display errs) =
-- Note that we rely on this error message being 'type cleaned', so
-- that `Show` is not displayed as GHC.Show.Show.
-- that `Show` is not displayed as GHC.Show.Show. This is also very fragile!
startswith "No instance for (Show" msg &&
isInfixOf " arising from a use of `print'" msg
isInfixOf "print it" msg
where msg = extractPlain errs
isSvg (DisplayData mime _) = mime == MimeSvg
@ -894,7 +893,7 @@ evalCommand output (Expression expr) state = do
postprocess (DisplayData MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script
where
fmt = "<div class='collapse-group'><span class='btn' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
fmt = "<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
script = unlines [
"$('#unshowable').on('click', function(e) {",
" e.preventDefault();",
@ -919,7 +918,7 @@ evalCommand output (Expression expr) state = do
evalCommand _ (Declaration decl) state = wrapExecution state $ do
write $ "Declaration:\n" ++ decl
write state $ "Declaration:\n" ++ decl
boundNames <- evalDeclarations decl
let nonDataNames = filter (not . isUpper . head) boundNames
@ -944,7 +943,7 @@ evalCommand _ (TypeSignature sig) state = wrapExecution state $
"\nlacks an accompanying binding."
evalCommand _ (ParseError loc err) state = do
write "Parse Error."
write state "Parse Error."
return EvalOut {
evalStatus = Failure,
evalResult = displayError $ formatParseError loc err,
@ -958,7 +957,7 @@ evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecut
"\nare not supported."
evalCommand output (Pragma PragmaLanguage pragmas) state = do
write $ "Got LANGUAGE pragma " ++ show pragmas
write state $ "Got LANGUAGE pragma " ++ show pragmas
evalCommand output (Directive SetExtension $ unwords pragmas) state
hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
@ -1226,6 +1225,7 @@ formatErrorWithClass cls =
replace "\n" "<br/>" .
replace useDashV "" .
replace "Ghci" "IHaskell" .
replace "‘interactive:" "‘" .
fixDollarSigns .
rstrip .
typeCleaner

28
src/IHaskell/Eval/Hoogle.hs
View File

@ -14,7 +14,9 @@ import Network.HTTP.Client.TLS
import Data.Aeson
import Data.String.Utils
import Data.List (elemIndex, (!!), last)
import Data.Char (isAscii, isAlphaNum)
import qualified Data.ByteString.Lazy.Char8 as Char
import qualified Prelude as P
import IHaskell.IPython
@ -58,7 +60,7 @@ instance FromJSON HoogleResponse where
-- message or the successful JSON result.
query :: String -> IO (Either String String)
query str = do
request <- parseUrl $ queryUrl str
request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request
return $ case response of
Left err -> Left $ show (err :: SomeException)
@ -67,6 +69,30 @@ query str = do
queryUrl :: String -> String
queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
-- | Copied from the HTTP package.
urlEncode :: String -> String
urlEncode [] = []
urlEncode (ch:t)
| (isAscii ch && isAlphaNum ch) || ch `P.elem` "-_.~" = ch : urlEncode t
| not (isAscii ch) = P.foldr escape (urlEncode t) (eightBs [] (P.fromEnum ch))
| otherwise = escape (P.fromEnum ch) (urlEncode t)
where
escape :: Int -> String -> String
escape b rs = '%':showH (b `P.div` 16) (showH (b `mod` 16) rs)
showH :: Int -> String -> String
showH x xs
| x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x-10)) : xs
where
o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A'
eightBs :: [Int] -> Int -> [Int]
eightBs acc x
| x <= 0xff = (x:acc)
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
-- | Search for a query on Hoogle.
-- Return all search results.
search :: String -> IO [HoogleResult]

44
src/IHaskell/Flags.hs
View File

@ -24,7 +24,6 @@ data Args = Args IHaskellMode [Argument]
data Argument = ServeFrom String -- ^ Which directory to serve notebooks from.
| Extension String -- ^ An extension to load at startup.
| ConfFile String -- ^ A file with commands to load at startup.
| IPythonFrom String -- ^ Which executable to use for IPython.
| OverwriteFiles -- ^ Present when output should overwrite existing files.
| ConvertFrom String
| ConvertTo String
@ -32,6 +31,7 @@ data Argument = ServeFrom String -- ^ Which directory to serve notebooks from
| ConvertToFormat NotebookFormat
| ConvertLhsStyle (LhsStyle String)
| GhcLibDir String -- ^ Where to find the GHC libraries.
| KernelDebug -- ^ Spew debugging output from the kernel.
| Help -- ^ Display help text.
deriving (Eq, Show)
@ -51,6 +51,7 @@ data NotebookFormat = LhsMarkdown
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode = ShowHelp String
| InstallKernelSpec
| Notebook
| Console
| ConvertLhs
@ -61,38 +62,43 @@ data IHaskellMode = ShowHelp String
-- | Given a list of command-line arguments, return the IHaskell mode and
-- arguments to process.
parseFlags :: [String] -> Either String Args
parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags in
case modeIndex of
Nothing -> Left $ "No mode provided. Modes available are: " ++ show modeFlags ++ "\n" ++
pack (showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs)
Just 0 -> process ihaskellArgs flags
parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags
in case modeIndex of
Nothing ->
-- Treat no mode as 'console'.
if "--help" `elem` flags
then Left $ pack (showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs)
else process ihaskellArgs $ "console" : flags
Just 0 -> process ihaskellArgs flags
Just idx ->
-- If mode not first, move it to be first.
Just idx ->
let (start, first:end) = splitAt idx flags in
process ihaskellArgs $ first:start ++ end
let (start, first:end) = splitAt idx flags
in process ihaskellArgs $ first : start ++ end
where
modeFlags = concatMap modeNames allModes
allModes :: [Mode Args]
allModes = [console, notebook, view, kernel, convert]
allModes = [installKernelSpec, console, notebook, view, kernel, convert]
-- | Get help text for a given IHaskell ode.
help :: IHaskellMode -> String
help mode = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode mode
where
chooseMode Console = console
chooseMode InstallKernelSpec = installKernelSpec
chooseMode Notebook = notebook
chooseMode (Kernel _) = kernel
chooseMode ConvertLhs = convert
ipythonFlag :: Flag Args
ipythonFlag = flagReq ["ipython", "i"] (store IPythonFrom) "<path>" "Executable for IPython."
ghcLibFlag :: Flag Args
ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "<path>" "Library directory for GHC."
kernelDebugFlag :: Flag Args
kernelDebugFlag = flagNone ["debug"] addDebug "Print debugging output from the kernel."
where addDebug (Args mode prev) = Args mode (KernelDebug : prev)
universalFlags :: [Flag Args]
universalFlags = [ flagReq ["extension", "e", "X"] (store Extension) "<ghc-extension>"
"Extension to enable at start."
@ -109,14 +115,16 @@ store constructor str (Args mode prev) = Right $ Args mode $ constructor str : p
notebook :: Mode Args
notebook = mode "notebook" (Args Notebook []) "Browser-based notebook interface." noArgs $
flagReq ["serve","s"] (store ServeFrom) "<dir>" "Directory to serve notebooks from.":
ipythonFlag:
universalFlags
console :: Mode Args
console = mode "console" (Args Console []) "Console-based interactive repl." noArgs $ ipythonFlag : universalFlags
console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags
installKernelSpec :: Mode Args
installKernelSpec = mode "install" (Args InstallKernelSpec []) "Install the Jupyter kernelspec." noArgs []
kernel :: Mode Args
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [ghcLibFlag]
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [ghcLibFlag, kernelDebugFlag]
where
kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
@ -186,7 +194,7 @@ view =
}
where
flags = [ipythonFlag, flagHelpSimple (add Help)]
flags = [flagHelpSimple (add Help)]
formatArg = flagArg updateFmt "<format>"
filenameArg = flagArg updateFile "<name>[.ipynb]"
updateFmt fmtStr (Args (View _ s) flags) =

464
src/IHaskell/IPython.hs
View File

@ -1,94 +1,79 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DoAndIfThenElse #-}
-- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and
-- @console@ commands.
module IHaskell.IPython (
setupIPython,
runConsole,
runNotebook,
readInitInfo,
defaultConfFile,
getIHaskellDir,
getSandboxPackageConf,
nbconvert,
subHome,
ViewFormat(..),
WhichIPython(..),
) where
withIPython,
replaceIPythonKernelspec,
runConsole,
runNotebook,
readInitInfo,
defaultConfFile,
getIHaskellDir,
getSandboxPackageConf,
nbconvert,
subHome,
kernelName,
ViewFormat(..),
) where
import ClassyPrelude
import Control.Concurrent (threadDelay)
import Prelude (read, reads, init)
import Shelly hiding (find, trace, path, (</>))
import System.Argv0
import System.Directory
import qualified Filesystem.Path.CurrentOS as FS
import Data.List.Utils (split)
import Data.String.Utils (rstrip, endswith, strip, replace)
import Text.Printf
import Data.Maybe (fromJust)
import ClassyPrelude
import Control.Concurrent (threadDelay)
import Prelude (read, reads, init)
import Shelly hiding (find, trace, path, (</>))
import System.Argv0
import System.Directory
import qualified Filesystem.Path.CurrentOS as FS
import Data.List.Utils (split)
import Data.String.Utils (rstrip, endswith, strip, replace)
import Text.Printf
import qualified Data.Text as T
import Data.Maybe (fromJust)
import System.Exit (exitFailure)
import Data.Aeson (toJSON)
import Data.Aeson.Encode (encodeToTextBuilder)
import Data.Text.Lazy.Builder (toLazyText)
import qualified System.IO.Strict as StrictIO
import qualified Paths_ihaskell as Paths
import qualified Codec.Archive.Tar as Tar
import IHaskell.Types
import System.Posix.Signals
import IHaskell.Types
import System.Posix.Signals
-- | Which IPython to use.
data WhichIPython
= DefaultIPython -- ^ Use the one that IHaskell tries to install.
| ExplicitIPython String -- ^ Use the command-line flag provided one.
deriving Eq
-- | The IPython kernel name.
kernelName :: IsString a => a
kernelName = "haskell"
-- | The IPython profile name.
ipythonProfile :: String
ipythonProfile = "haskell"
kernelArgs :: IsString a => [a]
kernelArgs = ["--kernel", kernelName]
-- | The current IPython profile version.
-- This must be the same as the file in the profile.tar.
-- The filename used is @profileVersionFile@.
profileVersion :: String
profileVersion = "0.4.2.0"
-- | Filename in the profile where the version ins kept.
profileVersionFile :: FilePath
profileVersionFile = ".profile_version"
-- | Run IPython with any arguments.
ipython :: WhichIPython -- ^ Which IPython to use (user-provided or IHaskell-installed).
-> Bool -- ^ Whether to suppress output.
-- | Run the IPython command with any arguments. The kernel is set to IHaskell.
ipython :: Bool -- ^ Whether to suppress output.
-> [Text] -- ^ IPython command line arguments.
-> Sh String -- ^ IPython output.
ipython which suppress args
| which == DefaultIPython = do
runCmd <- liftIO $ Paths.getDataFileName "installation/run.sh"
venv <- fpToText <$> ipythonDir
let cmdArgs = [pack runCmd, venv] ++ args
-- If we have PYTHONDONTWRITEBYTECODE enabled, everything breaks.
setenv "PYTHONDONTWRITEBYTECODE" ""
ipython suppress args = do
liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing
liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing
-- We have this because using `run` does not let us use stdin.
runHandles "ipython" args handles doNothing
-- We have this because using `run` does not let us use stdin.
runHandles "bash" cmdArgs handles doNothing
| otherwise = do
let ExplicitIPython exe = which
runHandles (fpFromString exe) args handles doNothing
where handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]
outHandle True = OutHandle CreatePipe
outHandle False = OutHandle Inherit
errorHandle True = ErrorHandle CreatePipe
errorHandle False = ErrorHandle Inherit
doNothing _ stdout _ = if suppress
then liftIO $ StrictIO.hGetContents stdout
else return ""
where
handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]
outHandle True = OutHandle CreatePipe
outHandle False = OutHandle Inherit
errorHandle True = ErrorHandle CreatePipe
errorHandle False = ErrorHandle Inherit
doNothing _ stdout _ = if suppress
then liftIO $ StrictIO.hGetContents stdout
else return ""
-- | Run while suppressing all output.
quietRun path args = runHandles path args handles nothing
where
handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe]
handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe]
nothing _ _ _ = return ()
-- | Create the directory and return it.
@ -107,18 +92,9 @@ ihaskellDir = do
ipythonDir :: Sh FilePath
ipythonDir = ensure $ (</> "ipython") <$> ihaskellDir
ipythonExePath :: WhichIPython -> Sh FilePath
ipythonExePath which =
case which of
DefaultIPython -> (</> ("bin" </> "ipython")) <$> ipythonDir
ExplicitIPython path -> return $ fromString path
notebookDir :: Sh FilePath
notebookDir = ensure $ (</> "notebooks") <$> ihaskellDir
ipythonSourceDir :: Sh FilePath
ipythonSourceDir = ensure $ (</> "ipython-src") <$> ihaskellDir
getIHaskellDir :: IO String
getIHaskellDir = shelly $ fpToString <$> ihaskellDir
@ -127,74 +103,110 @@ defaultConfFile = shelly $ do
filename <- (</> "rc.hs") <$> ihaskellDir
exists <- test_f filename
return $ if exists
then Just $ fpToString filename
else Nothing
then Just $ fpToString filename
else Nothing
-- | Find a notebook and then convert it into the provided format.
-- Notebooks are searched in the current directory as well as the IHaskell
-- notebook directory (in that order).
nbconvert :: WhichIPython -> ViewFormat -> String -> IO ()
nbconvert which fmt name = void . shelly $ do
nbconvert :: ViewFormat -> String -> IO ()
nbconvert fmt name = void . shelly $ do
curdir <- pwd
nbdir <- notebookDir
-- Find which of the options is available.
let notebookOptions = [
curdir </> fpFromString name,
curdir </> fpFromString (name ++ ".ipynb"),
nbdir </> fpFromString name,
nbdir </> fpFromString (name ++ ".ipynb")
]
let notebookOptions = [ curdir </> fpFromString name
, curdir </> fpFromString (name ++ ".ipynb")
, nbdir </> fpFromString name
, nbdir </> fpFromString (name ++ ".ipynb")
]
maybeNb <- headMay <$> filterM test_f notebookOptions
case maybeNb of
Nothing -> do
putStrLn $ "Cannot find notebook: " ++ pack name
putStrLn "Tried:"
mapM_ (putStrLn . (" " ++) . fpToText) notebookOptions
mapM_ (putStrLn . (" " ++) . fpToText) notebookOptions
Just notebook ->
let viewArgs = case fmt of
Pdf -> ["--to=latex", "--post=pdf"]
Html -> ["--to=html", "--template=ihaskell"]
fmt -> ["--to=" ++ show fmt] in
void $ runIHaskell which ipythonProfile "nbconvert" $ viewArgs ++ [fpToString notebook]
let viewArgs =
case fmt of
Pdf -> ["--to=latex", "--post=pdf"]
Html -> ["--to=html", "--template=ihaskell"]
fmt -> ["--to=" ++ pack (show fmt)]
args = "nbconvert" : fpToText notebook : viewArgs
in void $ ipython False args
-- | Set up IPython properly.
setupIPython :: WhichIPython -> IO ()
-- | Run an action after having verified that a proper IPython installation exists.
-- This ensures that an IHaskell kernelspec exists; if it doesn't, it creates it.
-- Note that this exits with an error if IPython isn't installed properly.
withIPython :: IO a -> IO a
withIPython act = shelly $ do
verifyIPythonVersion
kernelspecExists <- kernelSpecCreated
unless kernelspecExists $ installKernelspec False
liftIO act
setupIPython (ExplicitIPython path) = do
exists <- shelly $
test_f $ fromString path
replaceIPythonKernelspec :: IO ()
replaceIPythonKernelspec = shelly $ do
verifyIPythonVersion
installKernelspec True
unless exists $
fail $ "Cannot find IPython at " ++ path
setupIPython DefaultIPython = do
installed <- ipythonInstalled
when (not installed) $ do
path <- shelly $ which "ipython"
case path of
Just ipythonPath -> checkIPythonVersion ipythonPath
Nothing -> badIPython "Did not detect IHaskell-installed or system IPython."
where
checkIPythonVersion :: FilePath -> IO ()
checkIPythonVersion path = do
output <- unpack <$> shelly (silently $ run path ["--version"])
-- | Verify that a proper version of IPython is installed and accessible.
verifyIPythonVersion :: Sh ()
verifyIPythonVersion = do
pathMay <- which "ipython"
case pathMay of
Nothing -> badIPython "No IPython detected -- install IPython 3.0+ before using IHaskell."
Just path -> do
output <- unpack <$> silently (run path ["--version"])
case parseVersion output of
Just (3:_) -> putStrLn "Using system-wide dev version of IPython."
Just (2:_) -> putStrLn "Using system-wide IPython."
Just (1:_) -> badIPython "Detected old version of IPython. IHaskell requires 2.0.0 or up."
Just (0:_) -> badIPython "Detected old version of IPython. IHaskell requires 2.0.0 or up."
_ -> badIPython "Detected IPython, but could not parse version number."
Just (3:_) -> return ()
Just (2:_) -> oldIPython
Just (1:_) -> oldIPython
Just (0:_) -> oldIPython
_ -> badIPython "Detected IPython, but could not parse version number."
where
badIPython :: Text -> Sh ()
badIPython message = liftIO $ do
hPutStrLn stderr message
exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
badIPython :: Text -> IO ()
badIPython reason = void $ do
putStrLn reason
putStrLn "IHaskell will now proceed to install IPython (locally for itself)."
putStrLn "Installing IPython in IHaskell's virtualenv in 10 seconds. Ctrl-C to cancel."
threadDelay $ 1000 * 1000 * 10
installIPython
-- | Install an IHaskell kernelspec into the right location.
-- The right location is determined by using `ipython kernelspec install --user`.
installKernelspec :: Bool -> Sh ()
installKernelspec replace = void $ do
ihaskellPath <- getIHaskellPath
let kernelSpec = KernelSpec {
kernelDisplayName = "Haskell",
kernelLanguage = kernelName,
kernelCommand = [ihaskellPath, "kernel", "{connection_file}"]
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec
-- directory; then, shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json"
mkdir_p kernelDir
writefile filename $ toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec
let files = ["kernel.js", "logo-64x64.png"]
forM_ files $ \file -> do
src <- liftIO $ Paths.getDataFileName $ "html/" ++ file
cp (fpFromString src) (tmp </> kernelName </> fpFromString file)
Just ipython <- which "ipython"
let replaceFlag = ["--replace" | replace]
cmd = ["kernelspec", "install", "--user", fpToText kernelDir] ++ replaceFlag
silently $ run ipython cmd
kernelSpecCreated :: Sh Bool
kernelSpecCreated = do
Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined.
-- Otherwise, do nothing.
@ -217,55 +229,34 @@ path exe = do
-- | Parse an IPython version string into a list of integers.
parseVersion :: String -> Maybe [Int]
parseVersion versionStr =
parseVersion versionStr =
let versions = map read' $ split "." versionStr
parsed = all isJust versions in
if parsed
then Just $ map fromJust versions
else Nothing
where
parsed = all isJust versions
in if parsed
then Just $ map fromJust versions
else Nothing
where
read' :: String -> Maybe Int
read' x =
read' x =
case reads x of
[(n, _)] -> Just n
_ -> Nothing
_ -> Nothing
-- | Run an IHaskell application using the given profile.
runIHaskell :: WhichIPython
-> String -- ^ IHaskell profile name.
-> String -- ^ IPython app name.
-> [String] -- ^ Arguments to IPython.
-> Sh ()
runIHaskell which profile app args = void $ do
-- Try to locate the profile. Do not die if it doesn't exist.
errExit False $ ipython which True ["locate", "profile", pack profile]
-- If the profile doesn't exist, create it.
exitCode <- lastExitCode
if exitCode /= 0
then liftIO $ do
putStrLn "Creating IPython profile."
setupIPythonProfile which profile
-- If the profile exists, update it if necessary.
else updateIPythonProfile which profile
-- Run the IHaskell command.
ipython which False $ map pack $ [app, "--profile", profile] ++ args
runConsole :: WhichIPython -> InitInfo -> IO ()
runConsole which initInfo = void . shelly $ do
runConsole :: InitInfo -> IO ()
runConsole initInfo = void . shelly $ do
writeInitInfo initInfo
runIHaskell which ipythonProfile "console" []
ipython False $ "console" : "--no-banner" : kernelArgs
runNotebook :: WhichIPython -> InitInfo -> Maybe String -> IO ()
runNotebook which initInfo maybeServeDir = void . shelly $ do
notebookDirStr <- fpToString <$> notebookDir
let args = case maybeServeDir of
Nothing -> ["--notebook-dir", unpack notebookDirStr]
Just dir -> ["--notebook-dir", dir]
runNotebook :: InitInfo -> Maybe Text -> IO ()
runNotebook initInfo maybeServeDir = void . shelly $ do
notebookDirStr <- fpToText <$> notebookDir
let args =
case maybeServeDir of
Nothing -> ["--notebook-dir", notebookDirStr]
Just dir -> ["--notebook-dir", dir]
writeInitInfo initInfo
runIHaskell which ipythonProfile "notebook" args
ipython False $ "notebook" : args
writeInitInfo :: InitInfo -> Sh ()
writeInitInfo info = do
@ -274,72 +265,13 @@ writeInitInfo info = do
readInitInfo :: IO InitInfo
readInitInfo = shelly $ do
filename <- (</> ".last-arguments") <$> ihaskellDir
filename <- (</> ".last-arguments") <$> ihaskellDir
exists <- test_f filename
if exists
then read <$> liftIO (readFile filename)
else do
dir <- fromMaybe "." <$> fmap unpack <$> get_env "HOME"
return InitInfo { extensions = [], initCells = [], initDir = dir, frontend = IPythonNotebook }
-- | Create the IPython profile.
setupIPythonProfile :: WhichIPython
-> String -- ^ IHaskell profile name.
-> IO ()
setupIPythonProfile which profile = shelly $ do
-- Create the IPython profile.
void $ ipython which True ["profile", "create", pack profile]
-- Find the IPython profile directory. Make sure to get rid of trailing
-- newlines from the output of the `ipython locate` call.
ipythonDir <- pack <$> rstrip <$> ipython which True ["locate"]
let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/"
liftIO $ copyProfile profileDir
insertIHaskellPath profileDir
-- | Update the IPython profile.
updateIPythonProfile :: WhichIPython
-> String -- ^ IHaskell profile name.
-> Sh ()
updateIPythonProfile which profile = do
-- Find out whether the profile exists.
dir <- pack <$> rstrip <$> errExit False (ipython which True ["locate", "profile", pack profile])
exitCode <- lastExitCode
updated <- if exitCode == 0 && dir /= ""
then do
let versionFile = fpFromText dir </> profileVersionFile
fileExists <- test_f versionFile
if not fileExists
then return False
else liftIO $ do
contents <- StrictIO.readFile $ fpToString versionFile
return $ strip contents == profileVersion
else return False
when (not updated) $ do
putStrLn "Updating IPython profile."
liftIO $ copyProfile dir
insertIHaskellPath $ dir ++ "/"
-- | Copy the profile files into the IPython profile.
copyProfile :: Text -> IO ()
copyProfile profileDir = do
profileTar <- Paths.getDataFileName "profile/profile.tar"
putStrLn $ pack $ "Loading profile from " ++ profileTar
Tar.extract (unpack profileDir) profileTar
-- | Insert the IHaskell path into the IPython configuration.
insertIHaskellPath :: Text -> Sh ()
insertIHaskellPath profileDir = do
path <- getIHaskellPath
let filename = profileDir ++ "ipython_config.py"
template = "exe = '%s'.replace(' ', '\\\\ ')"
exeLine = printf template $ unpack path :: String
liftIO $ do
contents <- StrictIO.readFile $ unpack filename
writeFile (fromText filename) $ exeLine ++ "\n" ++ contents
then read <$> liftIO (readFile filename)
else do
dir <- fromMaybe "." <$> fmap unpack <$> get_env "HOME"
return InitInfo { extensions = [], initCells = [], initDir = dir, frontend = IPythonNotebook }
-- | Get the absolute path to this IHaskell executable.
getIHaskellPath :: Sh String
@ -349,62 +281,34 @@ getIHaskellPath = do
-- If we have an absolute path, that's the IHaskell we're interested in.
if FS.absolute f
then return $ FS.encodeString f
else
then return $ FS.encodeString f
else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH
-- variable to find where IHaskell lives.
if FS.filename f == f
then do
ihaskellPath <- which "IHaskell"
case ihaskellPath of
Nothing -> error "IHaskell not on $PATH and not referenced relative to directory."
Just path -> return $ FS.encodeString path
else do
-- If it's actually a relative path, make it absolute.
cd <- liftIO getCurrentDirectory
return $ FS.encodeString $ FS.decodeString cd FS.</> f
then do
ihaskellPath <- which "IHaskell"
case ihaskellPath of
Nothing -> error "IHaskell not on $PATH and not referenced relative to directory."
Just path -> return $ FS.encodeString path
else do
-- If it's actually a relative path, make it absolute.
cd <- liftIO getCurrentDirectory
return $ FS.encodeString $ FS.decodeString cd FS.</> f
getSandboxPackageConf :: IO (Maybe String)
getSandboxPackageConf = shelly $ do
myPath <- getIHaskellPath
let sandboxName = ".cabal-sandbox"
if not $ sandboxName`isInfixOf` myPath
then return Nothing
else do
let pieces = split "/" myPath
sandboxDir = intercalate "/" $ takeWhile (/= sandboxName) pieces ++ [sandboxName]
subdirs <- ls $ fpFromString sandboxDir
let confdirs = filter (endswith "packages.conf.d") $ map fpToString subdirs
case confdirs of
[] -> return Nothing
dir:_ ->
return $ Just dir
-- | Check whether IPython is properly installed.
ipythonInstalled :: IO Bool
ipythonInstalled = shelly $ do
ipythonPath <- ipythonExePath DefaultIPython
test_f ipythonPath
-- | Install IPython from source.
installIPython :: IO ()
installIPython = shelly $ do
-- Print a message and wait a little.
liftIO $ do
putStrLn "Installing IPython for IHaskell. This may take a while."
threadDelay $ 500 * 1000
-- Set up the virtualenv.
virtualenvScript <- liftIO $ Paths.getDataFileName "installation/virtualenv.sh"
venvDir <- fpToText <$> ipythonDir
runTmp virtualenvScript [venvDir]
-- Set up Python depenencies.
setenv "ARCHFLAGS" "-Wno-error=unused-command-line-argument-hard-error-in-future"
installScript <- liftIO $ Paths.getDataFileName "installation/ipython.sh"
runTmp installScript [venvDir]
runTmp script args = withTmpDir $ \tmp -> do
cd tmp
run_ "bash" $ pack script: args
if not $ sandboxName `isInfixOf` myPath
then return Nothing
else do
let pieces = split "/" myPath
sandboxDir = intercalate "/" $ takeWhile (/= sandboxName) pieces ++ [sandboxName]
subdirs <- ls $ fpFromString sandboxDir
let confdirs = filter (endswith "packages.conf.d") $ map fpToString subdirs
case confdirs of
[] -> return Nothing
dir:_ ->
return $ Just dir

41
src/IHaskell/Types.hs
View File

@ -29,6 +29,7 @@ module IHaskell.Types (
IHaskellWidget(..),
Widget(..),
CommInfo(..),
KernelSpec(..),
) where
import ClassyPrelude
@ -141,29 +142,29 @@ instance Semigroup Display where
a <> b = a `mappend` b
-- | All state stored in the kernel between executions.
data KernelState = KernelState
{ getExecutionCounter :: Int,
getLintStatus :: LintStatus, -- Whether to use hlint, and what arguments to pass it.
getFrontend :: FrontendType,
useSvg :: Bool,
useShowErrors :: Bool,
useShowTypes :: Bool,
usePager :: Bool,
openComms :: Map UUID Widget
}
data KernelState = KernelState { getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, getFrontend :: FrontendType
, useSvg :: Bool
, useShowErrors :: Bool
, useShowTypes :: Bool
, usePager :: Bool
, openComms :: Map UUID Widget
, kernelDebug :: Bool
}
deriving Show
defaultKernelState :: KernelState
defaultKernelState = KernelState
{ getExecutionCounter = 1,
getLintStatus = LintOn,
getFrontend = IPythonConsole,
useSvg = True,
useShowErrors = False,
useShowTypes = False,
usePager = True,
openComms = empty
}
defaultKernelState = KernelState { getExecutionCounter = 1
, getLintStatus = LintOn
, getFrontend = IPythonConsole
, useSvg = True
, useShowErrors = False
, useShowTypes = False
, usePager = True
, openComms = empty
, kernelDebug = False
}
data FrontendType
= IPythonConsole

118
src/Main.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets.
module Main where
@ -17,6 +17,7 @@ import System.Exit (exitSuccess)
import Text.Printf
import System.Posix.Signals
import qualified Data.Map as Map
import Data.String.Here (hereFile)
-- IHaskell imports.
import IHaskell.Convert (convert)
@ -44,6 +45,13 @@ ghcVersionInts = map read . words . map dotToSpace $ VERSION_ghc
dotToSpace '.' = ' '
dotToSpace x = x
ihaskellCSS :: String
ihaskellCSS = [hereFile|html/custom.css|]
consoleBanner :: Text
consoleBanner =
"Welcome to IHaskell! Run `IHaskell --help` for more information.\n" ++
"Enter `:help` to learn more about IHaskell built-ins."
main :: IO ()
main = do
@ -52,35 +60,23 @@ main = do
Left errorMessage -> hPutStrLn stderr errorMessage
Right args -> ihaskell args
chooseIPython [] = return DefaultIPython
chooseIPython (IPythonFrom path:_) = ExplicitIPython <$> subHome path
chooseIPython (_:xs) = chooseIPython xs
ihaskell :: Args -> IO ()
-- If no mode is specified, print help text.
ihaskell (Args (ShowHelp help) _) = putStrLn $ pack help
ihaskell (Args ConvertLhs args) = showingHelp ConvertLhs args $ convert args
ihaskell (Args InstallKernelSpec args) = showingHelp InstallKernelSpec args replaceIPythonKernelspec
ihaskell (Args Console flags) = showingHelp Console flags $ do
ipython <- chooseIPython flags
setupIPython ipython
flags <- addDefaultConfFile flags
info <- initInfo IPythonConsole flags
runConsole ipython info
ihaskell (Args mode@(View (Just fmt) (Just name)) args) = showingHelp mode args $ do
ipython <- chooseIPython args
nbconvert ipython fmt name
ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do
ipython <- chooseIPython flags
setupIPython ipython
let server = case mapMaybe serveDir flags of
[] -> Nothing
xs -> Just $ last xs
putStrLn consoleBanner
withIPython $ do
flags <- addDefaultConfFile flags
info <- initInfo IPythonConsole flags
runConsole info
ihaskell (Args mode@(View (Just fmt) (Just name)) args) = showingHelp mode args $ withIPython $
nbconvert fmt name
ihaskell (Args Notebook flags) = showingHelp Notebook flags $ withIPython $ do
let server =
case mapMaybe serveDir flags of
[] -> Nothing
xs -> Just $ last xs
flags <- addDefaultConfFile flags
@ -88,20 +84,19 @@ ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do
curdir <- getCurrentDirectory
let info = undirInfo { initDir = curdir }
runNotebook ipython info server
runNotebook info (pack <$> server)
where
serveDir (ServeFrom dir) = Just dir
serveDir _ = Nothing
ihaskell (Args (Kernel (Just filename)) flags) = do
initInfo <- readInitInfo
runKernel libdir filename initInfo
runKernel debug libdir filename initInfo
where
libdir = case flags of
[] -> GHC.Paths.libdir
[GhcLibDir dir] -> dir
(debug, libdir) = foldl' processFlag (False, GHC.Paths.libdir) flags
processFlag (debug, libdir) (GhcLibDir libdir') = (debug, libdir')
processFlag (debug, libdir) KernelDebug = (True, libdir)
processFlag x _ = x
-- | Add a conf file to the arguments if none exists.
addDefaultConfFile :: [Argument] -> IO [Argument]
@ -135,11 +130,12 @@ initInfo front (flag:flags) = do
_ -> return info
-- | Run the IHaskell language kernel.
runKernel :: String -- ^ GHC libdir.
runKernel :: Bool -- ^ Spew debugging output?
-> String -- ^ GHC libdir.
-> String -- ^ Filename of profile JSON file.
-> InitInfo -- ^ Initialization information from the invocation.
-> IO ()
runKernel libdir profileSrc initInfo = do
runKernel debug libdir profileSrc initInfo = do
setCurrentDirectory $ initDir initInfo
-- Parse the profile file.
@ -155,7 +151,7 @@ runKernel libdir profileSrc initInfo = do
-- Create initial state in the directory the kernel *should* be in.
state <- initialKernelState
modifyMVar_ state $ \kernelState -> return $
kernelState { getFrontend = frontend initInfo }
kernelState { getFrontend = frontend initInfo, kernelDebug = debug }
-- Receive and reply to all messages on the shell socket.
interpret libdir True $ do
@ -189,30 +185,31 @@ runKernel libdir profileSrc initInfo = do
-- The normal ones are a standard request/response style, while comms
-- can be anything, and don't necessarily require a response.
if isCommMessage request
then liftIO $ do
oldState <- takeMVar state
let replier = writeChan (iopubChannel interface)
newState <- handleComm replier oldState request replyHeader
putMVar state newState
writeChan (shellReplyChannel interface) SendNothing
else do
-- Create the reply, possibly modifying kernel state.
oldState <- liftIO $ takeMVar state
(newState, reply) <- replyTo interface request replyHeader oldState
liftIO $ putMVar state newState
then liftIO $ do
oldState <- takeMVar state
let replier = writeChan (iopubChannel interface)
newState <- handleComm replier oldState request replyHeader
putMVar state newState
writeChan (shellReplyChannel interface) SendNothing
else do
-- Create the reply, possibly modifying kernel state.
oldState <- liftIO $ takeMVar state
(newState, reply) <- replyTo interface request replyHeader oldState
liftIO $ putMVar state newState
-- Write the reply to the reply channel.
liftIO $ writeChan (shellReplyChannel interface) reply
-- Write the reply to the reply channel.
liftIO $ writeChan (shellReplyChannel interface) reply
where
ignoreCtrlC =
installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing
installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.")
Nothing
isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage]
-- Initial kernel state.
initialKernelState :: IO (MVar KernelState)
initialKernelState =
newMVar defaultKernelState
initialKernelState = newMVar defaultKernelState
-- | Duplicate a message header, giving it a new UUID and message type.
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
@ -292,12 +289,15 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
sendOutput (Display outs) = do
header <- dupHeader replyHeader DisplayDataMessage
send $ PublishDisplayData header "haskell" $ map convertSvgToHtml outs
send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ encodeUtf8 svg
convertSvgToHtml x = x
makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"
prependCss (DisplayData MimeHtml html) = DisplayData MimeHtml $ concat ["<style>", pack ihaskellCSS, "</style>", html]
prependCss x = x
startComm :: CommInfo -> IO ()
startComm (CommInfo widget uuid target) = do
-- Send the actual comm open.
@ -375,8 +375,8 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
let reply = CompleteReply replyHeader (map pack completions) (pack matchedText) line True
return (state, reply)
-- | Reply to the object_info_request message. Given an object name, return
-- | the associated type calculated by GHC.
-- Reply to the object_info_request message. Given an object name, return
-- the associated type calculated by GHC.
replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
docs <- pack <$> info (unpack oname)
let reply = ObjectInfoReply {
@ -388,6 +388,14 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
}
return (state, reply)
-- TODO: Implement history_reply.
replyTo _ HistoryRequest{} replyHeader state = do
let reply = HistoryReply {
header = replyHeader,
historyReply = [] -- FIXME
}
return (state, reply)
handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
handleComm replier kernelState req replyHeader = do
let widgets = openComms kernelState