Merging jupyter branch into master

Hspec.hs

@@ -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

Setup.hs

 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

build.sh

@@ -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

html/kernel.js

+
+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};
+        }
+);

ihaskell.cabal

@@ -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

installation/ipython.sh

-#!/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

installation/run.sh

-#!/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

installation/virtualenv.sh

-#!/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

ipython-kernel/ipython-kernel.cabal

@@ -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

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

@@ -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

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

@@ -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

ipython-kernel/src/IHaskell/IPython/Message/Parser.hs

@@ -7,14 +7,12 @@
 module IHaskell.IPython.Message.Parser (parseMessage) where
 
 import           Data.Aeson ((.:), decode, Result(..), Object)
-import            Control.Applicative   ((<|>))
+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
@@ -31,8 +29,8 @@ parseMessage :: [ByteString] -- ^ The list of identifiers sent with the 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,15 +40,16 @@ 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
+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
@@ -58,7 +57,6 @@ parseHeader idents headerData parentHeader metadata = MessageHeader {
                      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"
@@ -73,9 +71,8 @@ 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.
+       -> 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
@@ -85,6 +82,7 @@ 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.
@@ -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 = []
                     }
 
-completeRequestParser :: LByteString -> Message
-completeRequestParser content = parsed
+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
-  Success parsed = flip parse decoded $ \ obj -> do
+    -- 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 = requestParser $ \obj -> do
   code <- obj .: "block" <|> return ""
   codeLine <- obj .: "line"
   pos <- obj .: "cursor_pos"
   return $ CompleteRequest noHeader code codeLine pos
 
-  Just decoded = decode content
-
 objectInfoRequestParser :: LByteString -> Message
-objectInfoRequestParser content = parsed
-  where
-    Success parsed = flip parse decoded $ \obj -> do
+objectInfoRequestParser = requestParser $ \obj -> do
   oname <- obj .: "oname"
   dlevel <- obj .: "detail_level"
   return $ ObjectInfoRequest noHeader oname dlevel
 
-    Just decoded = decode content
-
 
 shutdownRequestParser :: LByteString -> Message
-shutdownRequestParser content = parsed
-  where
-  Success parsed = flip parse decoded $ \ obj -> do
+shutdownRequestParser = requestParser $ \obj -> do
   code <- obj .: "restart"
   return $ ShutdownRequest noHeader code
 
-  Just decoded = decode content
-
 inputReplyParser :: LByteString -> Message
-inputReplyParser content = parsed
-  where
-  Success parsed = flip parse decoded $ \ obj -> do
+inputReplyParser = requestParser $ \obj -> do
   value <- obj .: "value"
   return $ InputReply noHeader value
 
-  Just decoded = decode content
-
 commOpenParser :: LByteString -> Message
-commOpenParser content = parsed
-  where
-  Success parsed = flip parse decoded $ \ obj -> do
+commOpenParser = requestParser $ \obj -> do
   uuid <- obj .: "comm_id"
   name <- obj .: "target_name"
   value <- obj .: "data"
   return $ CommOpen noHeader name uuid value
 
-  Just decoded = decode content
-
 commDataParser :: LByteString -> Message
-commDataParser content = parsed
-  where
-  Success parsed = flip parse decoded $ \ obj -> do
+commDataParser = requestParser $ \obj -> do
   uuid <- obj .: "comm_id"
   value <- obj .: "data"
   return $ CommData noHeader uuid value
 
-  Just decoded = decode content
-
 commCloseParser :: LByteString -> Message
-commCloseParser content = parsed
-  where
-  Success parsed = flip parse decoded $ \ obj -> do
+commCloseParser = requestParser $ \obj -> do
   uuid <- obj .: "comm_id"
   value <- obj .: "data"
   return $ CommClose noHeader uuid value
-
-  Just decoded = decode content

ipython-kernel/src/IHaskell/IPython/Message/Writer.hs

@@ -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
 
 

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

@@ -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,21 +53,20 @@ type Port = Int
 type IP = String
 
 -- | The transport mechanism used to communicate with the IPython frontend.
-data Transport
-     = TCP                 -- ^ Default transport mechanism via TCP.
+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
@@ -74,19 +78,19 @@ 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
@@ -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,6 +171,8 @@ data MessageType = KernelInfoReplyMessage
                  | CommOpenMessage
                  | CommDataMessage
                  | CommCloseMessage
+                 | HistoryRequestMessage
+                 | HistoryReplyMessage
                  deriving (Show, Read, Eq)
 
 showMessageType :: MessageType -> String
@@ -175,9 +197,12 @@ 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
+  parseJSON (String s) =
+    case s of
       "kernel_info_reply"   -> return KernelInfoReplyMessage
       "kernel_info_request" -> return KernelInfoRequestMessage
       "execute_reply"       -> return ExecuteReplyMessage
@@ -199,6 +224,8 @@ instance FromJSON MessageType where
       "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)
   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
 
@@ -367,6 +420,7 @@ 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.

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

@@ -11,13 +11,16 @@ module IHaskell.IPython.ZeroMQ (
   serveStdin,
   ) where
 
-import qualified  Data.ByteString.Lazy  as ByteString
+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
@@ -27,14 +30,16 @@ import IHaskell.IPython.Message.Writer
 -- 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 {
+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.
+                                         -- 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.
+                                         -- 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

profile/.profile_version

-0.4.2.0

profile/ipython_config.py

-# 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]

profile/ipython_console_config.py

-# Empty.
-c = get_config()
-c.TerminalIPythonApp.display_banner = False
-c.TerminalInteractiveShell.confirm_exit = False

profile/ipython_notebook_config.py

-c = get_config()
-c.NotebookApp.port = 8778

profile/ipython_qtconsole_config.py

-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

profile/static/custom/conceal/conceal.js

-// 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);
-})();

profile/static/custom/custom.js

-$([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
-            });
-    });
-});

profile/static/custom/hide_input.js

-// 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.")
-})();

profile/templates/ihaskell-basic.tpl

-{%- extends 'basic.tpl' -%}

profile/templates/ihaskell.tpl

-{%- 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 %}

src/IHaskell/Eval/Evaluate.hs

@@ -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

src/IHaskell/Eval/Hoogle.hs

@@ -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]

src/IHaskell/Flags.hs

@@ -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
@@ -62,37 +63,42 @@ data IHaskellMode = ShowHelp String
 -- 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)
+  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
 
-      -- If mode not first, move it to be first.
     Just idx ->
-        let (start, first:end) = splitAt idx flags in
-          process ihaskellArgs $ first:start ++ end
+      -- If mode not first, move it to be first.
+      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) = 

src/IHaskell/IPython.hs

-{-# 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,
+    withIPython,
+    replaceIPythonKernelspec,
     runConsole,
     runNotebook,
     readInitInfo,
@@ -12,9 +15,9 @@ module IHaskell.IPython (
     getSandboxPackageConf,
     nbconvert,
     subHome,
+    kernelName,
     ViewFormat(..),
-  WhichIPython(..),
-) where
+    ) where
 
 import           ClassyPrelude
 import           Control.Concurrent (threadDelay)
@@ -26,7 +29,12 @@ 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
@@ -35,48 +43,25 @@ import qualified Codec.Archive.Tar as Tar
 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 profile name.
-ipythonProfile :: String
-ipythonProfile = "haskell"
-
--- | 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.
+-- | The IPython kernel name.
+kernelName :: IsString a => a
+kernelName = "haskell"
+
+kernelArgs :: IsString a => [a]
+kernelArgs = ["--kernel", kernelName]
+
+-- | 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
 
   -- 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
+  runHandles "ipython" args handles doNothing
 
-  where handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]
+  where
+    handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]
     outHandle True = OutHandle CreatePipe
     outHandle False = OutHandle Inherit
     errorHandle True = ErrorHandle CreatePipe
@@ -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
 
@@ -133,17 +109,16 @@ defaultConfFile = shelly $ do
 -- | 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
@@ -153,48 +128,85 @@ nbconvert which fmt name = void . shelly $ do
       mapM_ (putStrLn . ("  " ++) . fpToText) notebookOptions
 
     Just notebook ->
-      let viewArgs = case fmt of
+      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]
-
--- | Set up IPython properly.
-setupIPython :: WhichIPython -> IO ()
-
-setupIPython (ExplicitIPython path) = do
-  exists <- shelly $
-    test_f $ fromString path
-
-  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"])
+              fmt  -> ["--to=" ++ pack (show fmt)]
+          args = "nbconvert" : fpToText notebook : viewArgs
+      in void $ ipython False args
+
+-- | 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
+
+replaceIPythonKernelspec :: IO ()
+replaceIPythonKernelspec = shelly $ do
+  verifyIPythonVersion
+  installKernelspec True
+
+-- | 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."
+        Just (3:_) -> return ()
+        Just (2:_) -> oldIPython
+        Just (1:_) -> oldIPython
+        Just (0:_) -> oldIPython
         _          -> badIPython "Detected IPython, but could not parse version number."
-
-    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
-
+  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."
+
+-- | 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.
@@ -219,8 +231,8 @@ path exe = do
 parseVersion :: String -> Maybe [Int]
 parseVersion versionStr =
   let versions = map read' $ split "." versionStr
-      parsed = all isJust versions in
-    if parsed
+      parsed = all isJust versions
+  in if parsed
        then Just $ map fromJust versions
        else Nothing
   where
@@ -230,42 +242,21 @@ parseVersion versionStr =
         [(n, _)] -> Just n
         _        -> 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" []
-
-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]
+  ipython False $ "console" : "--no-banner" : kernelArgs
+
+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
@@ -282,65 +273,6 @@ readInitInfo = shelly $ 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
-
 -- | Get the absolute path to this IHaskell executable.
 getIHaskellPath :: Sh String
 getIHaskellPath = do
@@ -369,7 +301,7 @@ getSandboxPackageConf :: IO (Maybe String)
 getSandboxPackageConf = shelly $ do
   myPath <- getIHaskellPath
   let sandboxName = ".cabal-sandbox"
-  if not $ sandboxName`isInfixOf` myPath
+  if not $ sandboxName `isInfixOf` myPath
     then return Nothing
     else do
       let pieces = split "/" myPath
@@ -380,31 +312,3 @@ getSandboxPackageConf = shelly $ do
         [] -> 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

src/IHaskell/Types.hs

@@ -29,6 +29,7 @@ module IHaskell.Types (
   IHaskellWidget(..),
   Widget(..),
   CommInfo(..),
+  KernelSpec(..),
   ) where
 
 import            ClassyPrelude
@@ -141,28 +142,28 @@ 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

src/Main.hs

-{-# 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,33 +60,21 @@ 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
-
+  putStrLn consoleBanner
+  withIPython $ do
     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
+    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
 
@@ -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
@@ -203,16 +199,17 @@ runKernel libdir profileSrc initInfo = do
 
           -- 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