Commit daa62ecb authored by Adam Vogt's avatar Adam Vogt

Merge branch 'master' of https://github.com/gibiansky/IHaskell

parents 07fda863 63ef0a8d
...@@ -48,21 +48,21 @@ data-files: ...@@ -48,21 +48,21 @@ data-files:
library library
hs-source-dirs: src hs-source-dirs: src
build-depends: base ==4.6.*, build-depends: base ==4.6.*,
cereal == 0.3.*,
HTTP, HTTP,
base64-bytestring >= 1.0, base64-bytestring >= 1.0,
process >= 1.1, process >= 1.1,
hlint, hlint,
cmdargs >= 0.10, cmdargs >= 0.10,
tar, tar,
ipython-kernel,
ghc-parser, ghc-parser,
unix >= 2.6, unix >= 2.6,
hspec, hspec,
zeromq4-haskell >= 0.1,
aeson >=0.6, aeson >=0.6,
MissingH >=1.2, MissingH >=1.2,
classy-prelude >=0.7, classy-prelude >=0.7,
bytestring >=0.10, bytestring >=0.10,
uuid >=1.2.6,
containers >=0.5, containers >=0.5,
ghc ==7.6.*, ghc ==7.6.*,
ghc-paths ==0.1.*, ghc-paths ==0.1.*,
...@@ -76,11 +76,11 @@ library ...@@ -76,11 +76,11 @@ library
here, here,
system-filepath, system-filepath,
filepath, filepath,
cereal ==0.3.*,
text >=0.11,
mtl >= 2.1, mtl >= 2.1,
transformers, transformers,
haskeline haskeline,
HUnit,
parsec
exposed-modules: IHaskell.Display exposed-modules: IHaskell.Display
IHaskell.Eval.Completion IHaskell.Eval.Completion
...@@ -88,14 +88,12 @@ library ...@@ -88,14 +88,12 @@ library
IHaskell.Eval.Info IHaskell.Eval.Info
IHaskell.Eval.Lint IHaskell.Eval.Lint
IHaskell.Eval.Parser IHaskell.Eval.Parser
IHaskell.Eval.Stdin
IHaskell.Eval.Hoogle IHaskell.Eval.Hoogle
IHaskell.Eval.ParseShell
IHaskell.Eval.Util
IHaskell.IPython IHaskell.IPython
IHaskell.Message.Parser IHaskell.Flags
IHaskell.Message.UUID
IHaskell.Message.Writer
IHaskell.Types IHaskell.Types
IHaskell.ZeroMQ
Paths_ihaskell Paths_ihaskell
executable IHaskell executable IHaskell
...@@ -112,20 +110,19 @@ executable IHaskell ...@@ -112,20 +110,19 @@ executable IHaskell
IHaskell.Eval.Info IHaskell.Eval.Info
IHaskell.Eval.Evaluate IHaskell.Eval.Evaluate
IHaskell.Eval.Parser IHaskell.Eval.Parser
IHaskell.Eval.Stdin
IHaskell.Eval.Hoogle IHaskell.Eval.Hoogle
IHaskell.Eval.ParseShell
IHaskell.Eval.Util
IHaskell.IPython IHaskell.IPython
IHaskell.Message.Parser IHaskell.Flags
IHaskell.Message.UUID
IHaskell.Message.Writer
IHaskell.Types IHaskell.Types
IHaskell.ZeroMQ
IHaskell.Display IHaskell.Display
extensions: DoAndIfThenElse extensions: DoAndIfThenElse
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base ==4.6.*, build-depends: base ==4.6.*,
cereal == 0.3.*,
HTTP, HTTP,
base64-bytestring >= 1.0, base64-bytestring >= 1.0,
process >= 1.1, process >= 1.1,
...@@ -133,14 +130,13 @@ executable IHaskell ...@@ -133,14 +130,13 @@ executable IHaskell
cmdargs >= 0.10, cmdargs >= 0.10,
tar, tar,
ghc-parser, ghc-parser,
ipython-kernel,
unix >= 2.6, unix >= 2.6,
hspec, hspec,
zeromq4-haskell >= 0.1,
aeson >=0.6, aeson >=0.6,
MissingH >=1.2, MissingH >=1.2,
classy-prelude >=0.7, classy-prelude >=0.7,
bytestring >=0.10, bytestring >=0.10,
uuid >=1.2.6,
containers >=0.5, containers >=0.5,
ghc ==7.6.*, ghc ==7.6.*,
ghc-paths ==0.1.*, ghc-paths ==0.1.*,
...@@ -154,11 +150,11 @@ executable IHaskell ...@@ -154,11 +150,11 @@ executable IHaskell
here, here,
system-filepath, system-filepath,
filepath, filepath,
cereal ==0.3.*,
text >=0.11,
mtl >= 2.1, mtl >= 2.1,
transformers, transformers,
haskeline haskeline,
HUnit,
parsec
Test-Suite hspec Test-Suite hspec
hs-source-dirs: src hs-source-dirs: src
...@@ -166,6 +162,7 @@ Test-Suite hspec ...@@ -166,6 +162,7 @@ Test-Suite hspec
Ghc-Options: -threaded Ghc-Options: -threaded
Main-Is: Hspec.hs Main-Is: Hspec.hs
build-depends: base ==4.6.*, build-depends: base ==4.6.*,
cereal == 0.3.*,
HTTP, HTTP,
base64-bytestring >= 1.0, base64-bytestring >= 1.0,
process >= 1.1, process >= 1.1,
...@@ -173,14 +170,13 @@ Test-Suite hspec ...@@ -173,14 +170,13 @@ Test-Suite hspec
cmdargs >= 0.10, cmdargs >= 0.10,
tar, tar,
ghc-parser, ghc-parser,
ipython-kernel,
unix >= 2.6, unix >= 2.6,
hspec, hspec,
zeromq4-haskell >= 0.1,
aeson >=0.6, aeson >=0.6,
MissingH >=1.2, MissingH >=1.2,
classy-prelude >=0.7, classy-prelude >=0.7,
bytestring >=0.10, bytestring >=0.10,
uuid >=1.2.6,
containers >=0.5, containers >=0.5,
ghc ==7.6.*, ghc ==7.6.*,
ghc-paths ==0.1.*, ghc-paths ==0.1.*,
...@@ -194,12 +190,12 @@ Test-Suite hspec ...@@ -194,12 +190,12 @@ Test-Suite hspec
here, here,
system-filepath, system-filepath,
filepath, filepath,
cereal ==0.3.*,
text >=0.11,
mtl >= 2.1, mtl >= 2.1,
transformers, transformers,
haskeline, haskeline,
HUnit HUnit,
setenv,
parsec
extensions: DoAndIfThenElse extensions: DoAndIfThenElse
OverloadedStrings OverloadedStrings
......
#!/bin/sh #!/bin/sh
# Recompile ipython-kernel
cd ipython-kernel
cabal clean
cabal install --force-reinstalls || exit 1
cd ..
# Make the profile
cd profile cd profile
rm -f profile.tar rm -f profile.tar
tar -cvf profile.tar * tar -cvf profile.tar *
cd .. cd ..
# Make ihaskell itself
cabal clean
cabal install --force-reinstalls || exit 1 cabal install --force-reinstalls || exit 1
# Remove my profile # Remove my profile
rm -rf ~/.ipython/profile_haskell rm -rf ~/.ipython/profile_haskell
# Install all the display libraries
cd ihaskell-display cd ihaskell-display
for dir in `ls` for dir in `ls`
do do
cd $dir cd $dir
cabal clean
cabal install || exit 1 cabal install || exit 1
cd .. cd ..
done done
The MIT License (MIT)
Copyright (c) 2013 Andrew Gibiansky
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
import Distribution.Simple
main = defaultMain
name: ipython-kernel
version: 0.1.0.0
synopsis: A library for creating kernels for IPython frontends
description: ipython-kernel is a library for communicating with frontends for the interactive IPython framework. It is used extensively in IHaskell, the interactive Haskell environment.
homepage: http://github.com/gibiansky/IHaskell
license: MIT
license-file: LICENSE
author: Andrew Gibiansky
maintainer: andrew.gibiansky@gmail.com
category: Development
build-type: Simple
cabal-version: >=1.16
library
exposed-modules: IPython.Kernel
IPython.Types
IPython.ZeroMQ
IPython.Stdin
IPython.Message.Writer
IPython.Message.Parser
IPython.Message.UUID
-- other-modules:
other-extensions: OverloadedStrings
hs-source-dirs: src
default-language: Haskell2010
build-depends: base >=4.6 && <4.7,
bytestring >= 0.10,
aeson >= 0.6,
text >= 0.11,
containers >= 0.5,
unix >= 2.6,
uuid >= 1.3,
cereal == 0.3.*,
zeromq4-haskell >= 0.1
-- | This module exports all the types and functions necessary to create an
-- IPython language kernel that supports the @ipython console@ and @ipython
-- notebook@ frontends.
module IPython.Kernel (
module IPython.Types,
module IPython.Message.Writer,
module IPython.Message.Parser,
module IPython.Message.UUID,
module IPython.ZeroMQ,
) where
import IPython.Types
import IPython.Message.Writer
import IPython.Message.Parser
import IPython.Message.UUID
import IPython.ZeroMQ
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Description : Parsing messages received from IPython -- | Description : Parsing messages received from IPython
-- --
-- This module is responsible for converting from low-level ByteStrings -- This module is responsible for converting from low-level ByteStrings
-- obtained from the 0MQ sockets into Messages. The only exposed function is -- obtained from the 0MQ sockets into Messages. The only exposed function is
-- `parseMessage`, which should only be used in the low-level 0MQ interface. -- `parseMessage`, which should only be used in the low-level 0MQ interface.
module IHaskell.Message.Parser (parseMessage) where module IPython.Message.Parser (parseMessage) where
import ClassyPrelude
import Data.Aeson ((.:), decode, Result(..), Object) import Data.Aeson ((.:), decode, Result(..), Object)
import Control.Applicative ((<|>))
import Data.Aeson.Types (parse) import Data.Aeson.Types (parse)
import Data.ByteString
import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy as Lazy
import Data.Map (Map)
import IPython.Types
import IHaskell.Types type LByteString = Lazy.ByteString
----- External interface ----- ----- External interface -----
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
-- | Description : UUID generator and data structure -- | Description : UUID generator and data structure
-- --
-- Generate, parse, and pretty print UUIDs for use with IPython. -- Generate, parse, and pretty print UUIDs for use with IPython.
module IHaskell.Message.UUID ( module IPython.Message.UUID (
UUID, UUID,
random, randoms, random, randoms,
) where ) where
import ClassyPrelude import Control.Monad (mzero, replicateM)
import Control.Monad (mzero) import Control.Applicative ((<$>))
import Data.Text (pack)
import Data.Aeson import Data.Aeson
import Data.UUID.V4 (nextRandom) import Data.UUID.V4 (nextRandom)
......
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | Description : @ToJSON@ for Messages -- | Description : @ToJSON@ for Messages
-- --
-- This module contains the @ToJSON@ instance for @Message@. -- This module contains the @ToJSON@ instance for @Message@.
module IHaskell.Message.Writer ( module IPython.Message.Writer (
ToJSON(..) ToJSON(..)
) where ) where
import Prelude (read)
import ClassyPrelude
import Data.Aeson import Data.Aeson
import Data.Map (Map)
import Data.Text (Text, pack)
import Data.Monoid (mempty)
import Shelly hiding (trace)
import IHaskell.Types import IPython.Types
-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
ghcVersionInts :: [Int]
ghcVersionInts = ints . map read . words . map dotToSpace $ VERSION_ghc
where dotToSpace '.' = ' '
dotToSpace x = x
-- Convert message bodies into JSON. -- Convert message bodies into JSON.
instance ToJSON Message where instance ToJSON Message where
toJSON KernelInfoReply{} = object [ toJSON KernelInfoReply{ versionList = vers, language = language } = object [
"protocol_version" .= ints [4, 0], -- current protocol version, major and minor "protocol_version" .= ints [4, 0], -- current protocol version, major and minor
"language_version" .= ghcVersionInts, "language_version" .= vers,
"language" .= string "haskell" "language" .= language
] ]
toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [ toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}
module IHaskell.Eval.Stdin (fixStdin, recordParentHeader, recordKernelProfile) where -- | This module provides a way in which the Haskell standard input may be
-- forwarded to the IPython frontend and thus allows the notebook to use
-- the standard input.
--
-- This relies on the implementation of file handles in GHC, and is
-- generally unsafe and terrible. However, it is difficult to find another
-- way to do it, as file handles are generally meant to point to streams
-- and files, and not networked communication protocols.
--
-- In order to use this module, it must first be initialized with two
-- things. First of all, in order to know how to communicate with the
-- IPython frontend, it must know the kernel profile used for
-- communication. For this, use @recordKernelProfile@ once the profile is
-- known. Both this and @recordParentHeader@ take a directory name where
-- they can store this data.
--
-- Finally, the module must know what @execute_request@ message is
-- currently being replied to (which will request the input). Thus, every
-- time the language kernel receives an @execute_request@ message, it
-- should inform this module via @recordParentHeader@, so that the module
-- may generate messages with an appropriate parent header set. If this is
-- not done, the IPython frontends will not recognize the target of the
-- communication.
--
-- Finally, in order to activate this module, @fixStdin@ must be called
-- once. It must be passed the same directory name as @recordParentHeader@
-- and @recordKernelProfile@. Note that if this is being used from within
-- the GHC API, @fixStdin@ /must/ be called from within the GHC session
-- not from the host code.
module IPython.Stdin (
fixStdin,
recordParentHeader,
recordKernelProfile
) where
import ClassyPrelude hiding (hPutStrLn, readFile, writeFile) import Control.Concurrent
import Control.Applicative ((<$>))
import Prelude (read)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Chan import Control.Concurrent.Chan
import Control.Monad import Control.Monad
import GHC.IO.Handle import GHC.IO.Handle
...@@ -14,28 +45,27 @@ import System.Posix.IO ...@@ -14,28 +45,27 @@ import System.Posix.IO
import System.IO.Unsafe import System.IO.Unsafe
import qualified Data.Map as Map import qualified Data.Map as Map
import IHaskell.Types import IPython.Types
import IHaskell.IPython import IPython.ZeroMQ
import IHaskell.ZeroMQ import IPython.Message.UUID as UUID
import IHaskell.Message.UUID as UUID
stdinInterface :: MVar ZeroMQStdin stdinInterface :: MVar ZeroMQStdin
{-# NOINLINE stdinInterface #-}
stdinInterface = unsafePerformIO newEmptyMVar stdinInterface = unsafePerformIO newEmptyMVar
-- | Manipulate standard input so that it is sourced from the IPython -- | Manipulate standard input so that it is sourced from the IPython
-- frontend. This function is build on layers of deep magical hackery, so -- frontend. This function is build on layers of deep magical hackery, so
-- be careful modifying it. -- be careful modifying it.
fixStdin :: IO () fixStdin :: String -> IO ()
fixStdin = do fixStdin dir = do
-- Initialize the stdin interface. -- Initialize the stdin interface.
dir <- getIHaskellDir
profile <- read <$> readFile (dir ++ "/.kernel-profile") profile <- read <$> readFile (dir ++ "/.kernel-profile")
interface <- serveStdin profile interface <- serveStdin profile
putMVar stdinInterface interface putMVar stdinInterface interface
void $ forkIO stdinOnce void $ forkIO $ stdinOnce dir
stdinOnce :: IO () stdinOnce :: String -> IO ()
stdinOnce = do stdinOnce dir = do
-- Create a pipe using and turn it into handles. -- Create a pipe using and turn it into handles.
(readEnd, writeEnd) <- createPipe (readEnd, writeEnd) <- createPipe
newStdin <- fdToHandle readEnd newStdin <- fdToHandle readEnd
...@@ -56,18 +86,17 @@ stdinOnce = do ...@@ -56,18 +86,17 @@ stdinOnce = do
if not empty if not empty
then loop stdinInput oldStdin newStdin then loop stdinInput oldStdin newStdin
else do else do
line <- getInputLine line <- getInputLine dir
hPutStr stdinInput $ line ++ "\n" hPutStr stdinInput $ line ++ "\n"
loop stdinInput oldStdin newStdin loop stdinInput oldStdin newStdin
-- | Get a line of input from the IPython frontend. -- | Get a line of input from the IPython frontend.
getInputLine :: IO String getInputLine :: String -> IO String
getInputLine = do getInputLine dir = do
StdinChannel req rep <- readMVar stdinInterface StdinChannel req rep <- readMVar stdinInterface
-- Send a request for input. -- Send a request for input.
uuid <- UUID.random uuid <- UUID.random
dir <- getIHaskellDir
parentHeader <- read <$> readFile (dir ++ "/.last-req-header") parentHeader <- read <$> readFile (dir ++ "/.last-req-header")
let header = MessageHeader { let header = MessageHeader {
username = username parentHeader, username = username parentHeader,
...@@ -83,15 +112,12 @@ getInputLine = do ...@@ -83,15 +112,12 @@ getInputLine = do
-- Get the reply. -- Get the reply.
InputReply _ value <- readChan rep InputReply _ value <- readChan rep
hPrint stderr value
return value return value
recordParentHeader :: MessageHeader -> IO () recordParentHeader :: String -> MessageHeader -> IO ()
recordParentHeader header = do recordParentHeader dir header =
dir <- getIHaskellDir
writeFile (dir ++ "/.last-req-header") $ show header writeFile (dir ++ "/.last-req-header") $ show header
recordKernelProfile :: Profile -> IO () recordKernelProfile :: String -> Profile -> IO ()
recordKernelProfile profile = do recordKernelProfile dir profile =
dir <- getIHaskellDir
writeFile (dir ++ "/.kernel-profile") $ show profile writeFile (dir ++ "/.kernel-profile") $ show profile
This diff is collapsed.
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}
-- | Description : Low-level ZeroMQ communication wrapper. -- | Description : Low-level ZeroMQ communication wrapper.
-- --
-- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, -- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython,
-- replacing it instead with a Haskell Channel based interface. The `serveProfile` function -- replacing it instead with a Haskell Channel based interface. The `serveProfile` function
-- takes a IPython profile specification and returns the channel interface to use. -- takes a IPython profile specification and returns the channel interface to use.
module IHaskell.ZeroMQ ( module IPython.ZeroMQ (
ZeroMQInterface (..), ZeroMQInterface (..),
ZeroMQStdin(..), ZeroMQStdin(..),
serveProfile, serveProfile,
serveStdin, serveStdin,
) where ) where
import ClassyPrelude hiding (stdin) import qualified Data.ByteString.Lazy as ByteString
import Data.ByteString (ByteString)
import Control.Concurrent import Control.Concurrent
import System.ZMQ4 hiding (stdin) import Control.Monad
import System.IO.Unsafe
import Data.Aeson (encode) import Data.Aeson (encode)
import System.ZMQ4 hiding (stdin)
import qualified Data.ByteString.Lazy as ByteString import IPython.Types
import IPython.Message.Parser
import IHaskell.Types import IPython.Message.Writer
import IHaskell.Message.Parser
import IHaskell.Message.Writer
import System.IO.Unsafe
-- | The channel interface to the ZeroMQ sockets. All communication is done via -- | The channel interface to the ZeroMQ sockets. All communication is done via
-- Messages, which are encoded and decoded into a lower level form before being -- Messages, which are encoded and decoded into a lower level form before being
...@@ -97,7 +96,7 @@ serveStdin profile = do ...@@ -97,7 +96,7 @@ serveStdin profile = do
serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO () serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO ()
serveSocket context socketType port action = void $ serveSocket context socketType port action = void $
withSocket context socketType $ \socket -> do withSocket context socketType $ \socket -> do
bind socket $ unpack $ "tcp://127.0.0.1:" ++ show port bind socket $ "tcp://127.0.0.1:" ++ show port
forever $ action socket forever $ action socket
-- | Listener on the heartbeat port. Echoes back any data it was sent. -- | Listener on the heartbeat port. Echoes back any data it was sent.
......
...@@ -53,14 +53,15 @@ var concealExtension = (function() { ...@@ -53,14 +53,15 @@ var concealExtension = (function() {
// Process a non-infix conceal token. // Process a non-infix conceal token.
function markNonInfixToken(editor, line, token) { function markNonInfixToken(editor, line, token) {
// We have a special case for the dot operator. // We have a special case for the dot operator. We only want to
// This is because CodeMirror parses some bits of Haskell incorrectly. // convert it to a fancy composition if there is a space before it.
// For instance: [1..100] gets parsed as a number "1." followed by a dot ".". // This preserves things like [1..1000] which CodeMirror parses
// This causes the "." to become marked, although it shouldn't be. // incorrectly and also lets you write with lenses as record^.a.b.c,
// which looks better.
if (token.string == ".") { if (token.string == ".") {
var prev = prevToken(editor, token, line); var handle = editor.getLineHandle(line);
var prevStr = prev.string; var ch = token.start;
if(prevStr[prevStr.length - 1] == ".") { if (handle.text[ch - 1] != ' ') {
return false; return false;
} }
} }
...@@ -125,9 +126,7 @@ var concealExtension = (function() { ...@@ -125,9 +126,7 @@ var concealExtension = (function() {
/** /**
* Activate conceal in CodeMirror options, don't overwrite other settings * Activate conceal in CodeMirror options, don't overwrite other settings
*/ */
function concealCell(cell) { function concealCell(editor) {
var editor = cell.code_mirror;
// Initialize all tokens. Just look at the token at every character. // Initialize all tokens. Just look at the token at every character.
editor.eachLine(function (handle) { editor.eachLine(function (handle) {
var l = editor.getLineNumber(handle); var l = editor.getLineNumber(handle);
...@@ -151,7 +150,8 @@ var concealExtension = (function() { ...@@ -151,7 +150,8 @@ var concealExtension = (function() {
createCell = function (event,nbcell,nbindex) { createCell = function (event,nbcell,nbindex) {
var cell = nbcell.cell; var cell = nbcell.cell;
if ((cell instanceof IPython.CodeCell)) { if ((cell instanceof IPython.CodeCell)) {
concealCell(cell) var editor = cell.code_mirror;
concealCell(editor)
} }
}; };
...@@ -163,12 +163,15 @@ var concealExtension = (function() { ...@@ -163,12 +163,15 @@ var concealExtension = (function() {
for(var i in cells){ for(var i in cells){
var cell = cells[i]; var cell = cells[i];
if ((cell instanceof IPython.CodeCell)) { if ((cell instanceof IPython.CodeCell)) {
concealCell(cell); var editor = cell.code_mirror;
concealCell(editor);
} }
} }
$([IPython.events]).on('create.Cell',createCell); $([IPython.events]).on('create.Cell',createCell);
} }
IPython.concealCell = concealCell;
require([], initExtension); require([], initExtension);
})(); })();
...@@ -13,6 +13,7 @@ import Shelly (Sh, shelly, cmd, (</>), toTextIgnore, cd, withTmpDir, mkdir_p, ...@@ -13,6 +13,7 @@ import Shelly (Sh, shelly, cmd, (</>), toTextIgnore, cd, withTmpDir, mkdir_p,
touchfile) touchfile)
import qualified Shelly import qualified Shelly
import Filesystem.Path.CurrentOS (encodeString) import Filesystem.Path.CurrentOS (encodeString)
import System.SetEnv (setEnv)
import Data.String.Here import Data.String.Here
import Data.String.Utils (strip, replace) import Data.String.Utils (strip, replace)
import Data.Monoid import Data.Monoid
...@@ -24,12 +25,13 @@ import IHaskell.Eval.Evaluate as Eval hiding (liftIO) ...@@ -24,12 +25,13 @@ import IHaskell.Eval.Evaluate as Eval hiding (liftIO)
import qualified IHaskell.Eval.Evaluate as Eval (liftIO) import qualified IHaskell.Eval.Evaluate as Eval (liftIO)
import IHaskell.Eval.Completion import IHaskell.Eval.Completion
import IHaskell.Eval.ParseShell
import Debug.Trace import Debug.Trace
import Test.Hspec import Test.Hspec
import Test.Hspec.HUnit import Test.Hspec.HUnit
import Test.HUnit (assertBool) import Test.HUnit (assertBool, assertFailure)
doGhc = runGhc (Just libdir) doGhc = runGhc (Just libdir)
...@@ -88,33 +90,38 @@ pages string expected = evaluationComparing comparison string ...@@ -88,33 +90,38 @@ pages string expected = evaluationComparing comparison string
comparison (results, pageOut) = comparison (results, pageOut) =
strip pageOut `shouldBe` strip (unlines expected) strip pageOut `shouldBe` strip (unlines expected)
completes string expected = completionTarget newString cursorloc `shouldBe` expected readCompletePrompt :: String -> (String, Int)
where (newString, cursorloc) = case elemIndex '*' string of -- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of
-- @'*'@ in the input string.
readCompletePrompt string = case elemIndex '*' string of
Nothing -> error "Expected cursor written as '*'." Nothing -> error "Expected cursor written as '*'."
Just idx -> (replace "*" "" string, idx) Just idx -> (replace "*" "" string, idx)
completionEvent :: String -> [String] -> Interpreter (String, [String]) completes string expected = completionTarget newString cursorloc `shouldBe` expected
completionEvent string expected = where (newString, cursorloc) = readCompletePrompt string
completionEvent :: String -> Interpreter (String, [String])
completionEvent string = do
complete newString cursorloc complete newString cursorloc
where (newString, cursorloc) = case elemIndex '*' string of where (newString, cursorloc) = case elemIndex '*' string of
Nothing -> error "Expected cursor written as '*'." Nothing -> error "Expected cursor written as '*'."
Just idx -> (replace "*" "" string, idx) Just idx -> (replace "*" "" string, idx)
completionEventInDirectory :: String -> [String] -> IO (String, [String]) completionEventInDirectory :: String -> IO (String, [String])
completionEventInDirectory string expected completionEventInDirectory string
= withHsDirectory $ completionEvent string expected = withHsDirectory $ const $ completionEvent string
shouldHaveCompletionsInDirectory :: String -> [String] -> IO () shouldHaveCompletionsInDirectory :: String -> [String] -> IO ()
shouldHaveCompletionsInDirectory string expected shouldHaveCompletionsInDirectory string expected
= do (matched, completions) <- completionEventInDirectory string expected = do (matched, completions) <- completionEventInDirectory string
let existsInCompletion = (`elem` completions) let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected unmatched = filter (not . existsInCompletion) expected
expected `shouldBeAmong` completions expected `shouldBeAmong` completions
completionHas string expected completionHas string expected
= do (matched, completions) <- doGhc $ do initCompleter = do (matched, completions) <- doGhc $ do initCompleter
completionEvent string expected completionEvent string
let existsInCompletion = (`elem` completions) let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected unmatched = filter (not . existsInCompletion) expected
expected `shouldBeAmong` completions expected `shouldBeAmong` completions
...@@ -133,7 +140,7 @@ initCompleter = do ...@@ -133,7 +140,7 @@ initCompleter = do
inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory
-> [Shelly.FilePath] -- ^ files relative to temporary directory -> [Shelly.FilePath] -- ^ files relative to temporary directory
-> Interpreter a -> (Shelly.FilePath -> Interpreter a)
-> IO a -> IO a
-- | Run an Interpreter action, but first make a temporary directory -- | Run an Interpreter action, but first make a temporary directory
-- with some files and folder and cd to it. -- with some files and folder and cd to it.
...@@ -141,7 +148,7 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> ...@@ -141,7 +148,7 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath ->
do cd dirPath do cd dirPath
mapM_ mkdir_p dirs mapM_ mkdir_p dirs
mapM_ touchfile files mapM_ touchfile files
liftIO $ doGhc $ wrap (encodeString dirPath) action liftIO $ doGhc $ wrap (encodeString dirPath) (action dirPath)
where noPublish = const $ return () where noPublish = const $ return ()
cdEvent path = Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish cdEvent path = Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish
wrap :: FilePath -> Interpreter a -> Interpreter a wrap :: FilePath -> Interpreter a -> Interpreter a
...@@ -153,7 +160,7 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> ...@@ -153,7 +160,7 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath ->
cdEvent pwd -- change back to the original directory cdEvent pwd -- change back to the original directory
return out return out
withHsDirectory :: Interpreter a -> IO a withHsDirectory :: (Shelly.FilePath -> Interpreter a) -> IO a
withHsDirectory = inDirectory ["" </> "dir", "dir" </> "dir1"] withHsDirectory = inDirectory ["" </> "dir", "dir" </> "dir1"]
[""</> "file1.hs", "dir" </> "file2.hs", [""</> "file1.hs", "dir" </> "file2.hs",
"" </> "file1.lhs", "dir" </> "file2.lhs"] "" </> "file1.lhs", "dir" </> "file2.lhs"]
...@@ -165,6 +172,7 @@ main = hspec $ do ...@@ -165,6 +172,7 @@ main = hspec $ do
completionTests completionTests
completionTests = do completionTests = do
parseShellTests
describe "Completion" $ do describe "Completion" $ do
it "correctly gets the completion identifier without dots" $ do it "correctly gets the completion identifier without dots" $ do
"hello*" `completes` ["hello"] "hello*" `completes` ["hello"]
...@@ -191,7 +199,9 @@ completionTests = do ...@@ -191,7 +199,9 @@ completionTests = do
completionType "a.x" 3 ["a", "x"] `shouldBe` Identifier "x" completionType "a.x" 3 ["a", "x"] `shouldBe` Identifier "x"
completionType "pri" 3 ["pri"] `shouldBe` Identifier "pri" completionType "pri" 3 ["pri"] `shouldBe` Identifier "pri"
completionType ":load A" 7 ["A"] `shouldBe` HsFilePath ":load A" completionType ":load A" 7 ["A"] `shouldBe` HsFilePath ":load A"
completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " "A"
completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " ""
it "properly completes identifiers" $ do it "properly completes identifiers" $ do
...@@ -235,6 +245,45 @@ completionTests = do ...@@ -235,6 +245,45 @@ completionTests = do
, "" </> "file1.hs" , "" </> "file1.hs"
, "" </> "file1.lhs"]) , "" </> "file1.lhs"])
it "correctly interprets ~ as the environment HOME variable" $
let shouldHaveCompletions :: String -> [String] -> IO ()
shouldHaveCompletions string expected = do
(matched, completions)
<- withHsDirectory $ \dirPath ->
do setHomeEvent dirPath
completionEvent string
let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected
expected `shouldBeAmong` completions
setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)
in do
":! cd ~/*" `shouldHaveCompletions` ["~/dir/"]
":! ~/*" `shouldHaveCompletions` ["~/dir/"]
":load ~/*" `shouldHaveCompletions` ["~/dir/"]
":l ~/*" `shouldHaveCompletions` ["~/dir/"]
let shouldHaveMatchingText :: String -> String -> IO ()
shouldHaveMatchingText string expected = do
matchText
<- withHsDirectory $ \dirPath ->
do setHomeEvent dirPath
(matchText, _) <- uncurry complete (readCompletePrompt string)
return matchText
matchText `shouldBe` expected
setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)
it "generates the correct matchingText on `:! cd ~/*` " $
do ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String)
it "generates the correct matchingText on `:load ~/*` " $
do ":load ~/*" `shouldHaveMatchingText` ("~/" :: String)
it "generates the correct matchingText on `:l ~/*` " $
do ":l ~/*" `shouldHaveMatchingText` ("~/" :: String)
evalTests = do evalTests = do
describe "Code Evaluation" $ do describe "Code Evaluation" $ do
it "evaluates expressions" $ do it "evaluates expressions" $ do
...@@ -492,6 +541,24 @@ parseStringTests = describe "Parser" $ do ...@@ -492,6 +541,24 @@ parseStringTests = describe "Parser" $ do
Located 4 (Expression "second")]) Located 4 (Expression "second")])
parseShellTests =
describe "Parsing Shell Commands" $ do
test "A" ["A"]
test ":load A" [":load", "A"]
test ":!l ~/Downloads/MyFile\\ Has\\ Spaces.txt"
[":!l", "~/Downloads/MyFile\\ Has\\ Spaces.txt"]
test ":!l \"~/Downloads/MyFile Has Spaces.txt\" /Another/File\\ WithSpaces.doc"
[":!l", "~/Downloads/MyFile Has Spaces.txt", "/Another/File\\ WithSpaces.doc" ]
where
test string expected =
it ("parses " ++ string ++ " correctly") $
string `shouldParseTo` expected
shouldParseTo xs ys = fun ys (parseShell xs)
where fun ys (Right xs') = xs' `shouldBe` ys
fun ys (Left e) = assertFailure $ "parseShell returned error: \n" ++ show e
-- Useful HSpec expectations ---- -- Useful HSpec expectations ----
--------------------------------- ---------------------------------
......
...@@ -40,6 +40,7 @@ import System.Console.Haskeline.Completion ...@@ -40,6 +40,7 @@ import System.Console.Haskeline.Completion
import IHaskell.Types import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter) import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell)
data CompletionType data CompletionType
...@@ -48,8 +49,8 @@ data CompletionType ...@@ -48,8 +49,8 @@ data CompletionType
| Extension String | Extension String
| Qualified String String | Qualified String String
| ModuleName String String | ModuleName String String
| HsFilePath String | HsFilePath String String
| FilePath String | FilePath String String
deriving (Show, Eq) deriving (Show, Eq)
complete :: String -> Int -> Interpreter (String, [String]) complete :: String -> Int -> Interpreter (String, [String])
...@@ -66,7 +67,11 @@ complete line pos = do ...@@ -66,7 +67,11 @@ complete line pos = do
moduleNames = nub $ concatMap getNames db moduleNames = nub $ concatMap getNames db
let target = completionTarget line pos let target = completionTarget line pos
matchedText = intercalate "." target
let matchedText = case completionType line pos target of
HsFilePath _ match -> match
FilePath _ match -> match
otherwise -> intercalate "." target
options <- options <-
case completionType line pos target of case completionType line pos target of
...@@ -94,9 +99,9 @@ complete line pos = do ...@@ -94,9 +99,9 @@ complete line pos = do
nonames = map ("No" ++) names nonames = map ("No" ++) names
return $ filter (ext `isPrefixOf`) $ names ++ nonames return $ filter (ext `isPrefixOf`) $ names ++ nonames
HsFilePath path -> completePathWithExtensions [".hs", ".lhs"] path HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
FilePath path -> completePath path FilePath lineUpToCursor match -> completePath lineUpToCursor
return (matchedText, options) return (matchedText, options)
...@@ -126,9 +131,13 @@ completionType :: String -- ^ The line on which the completion is bei ...@@ -126,9 +131,13 @@ completionType :: String -- ^ The line on which the completion is bei
completionType line loc target completionType line loc target
-- File and directory completions are special -- File and directory completions are special
| startswith ":!" stripped | startswith ":!" stripped
= FilePath lineUpToCursor = case parseShell lineUpToCursor of
Right xs -> FilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []
Left _ -> Empty
| startswith ":l" stripped | startswith ":l" stripped
= HsFilePath lineUpToCursor = case parseShell lineUpToCursor of
Right xs -> HsFilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []
Left _ -> Empty
-- Use target for other completions. -- Use target for other completions.
-- If it's empty, no completion. -- If it's empty, no completion.
| null target | null target
...@@ -149,6 +158,7 @@ completionType line loc target ...@@ -149,6 +158,7 @@ completionType line loc target
isCapitalized = isUpper . head isCapitalized = isUpper . head
lineUpToCursor = take loc line lineUpToCursor = take loc line
-- | Get the word under a given cursor location. -- | Get the word under a given cursor location.
completionTarget :: String -> Int -> [String] completionTarget :: String -> Int -> [String]
completionTarget code cursor = expandCompletionPiece pieceToComplete completionTarget code cursor = expandCompletionPiece pieceToComplete
......
...@@ -61,10 +61,12 @@ import ErrUtils (errMsgShortDoc, errMsgExtraInfo) ...@@ -61,10 +61,12 @@ import ErrUtils (errMsgShortDoc, errMsgExtraInfo)
import qualified System.IO.Strict as StrictIO import qualified System.IO.Strict as StrictIO
import IHaskell.Types import IHaskell.Types
import IHaskell.IPython
import IHaskell.Eval.Parser import IHaskell.Eval.Parser
import IHaskell.Eval.Lint import IHaskell.Eval.Lint
import IHaskell.Display import IHaskell.Display
import qualified IHaskell.Eval.Hoogle as Hoogle import qualified IHaskell.Eval.Hoogle as Hoogle
import IHaskell.Eval.Util
import Paths_ihaskell (version) import Paths_ihaskell (version)
import Data.Version (versionBranch) import Data.Version (versionBranch)
...@@ -96,7 +98,7 @@ instance MonadIO.MonadIO Interpreter where ...@@ -96,7 +98,7 @@ instance MonadIO.MonadIO Interpreter where
globalImports :: [String] globalImports :: [String]
globalImports = globalImports =
[ "import IHaskell.Display" [ "import IHaskell.Display"
, "import qualified IHaskell.Eval.Stdin" , "import qualified IPython.Stdin"
, "import Control.Applicative ((<$>))" , "import Control.Applicative ((<$>))"
, "import GHC.IO.Handle (hDuplicateTo, hDuplicate, hClose)" , "import GHC.IO.Handle (hDuplicateTo, hDuplicate, hClose)"
, "import System.Posix.IO" , "import System.Posix.IO"
...@@ -122,8 +124,10 @@ interpret allowedStdin action = runGhc (Just libdir) $ do ...@@ -122,8 +124,10 @@ interpret allowedStdin action = runGhc (Just libdir) $ do
-- Close stdin so it can't be used. -- Close stdin so it can't be used.
-- Otherwise it'll block the kernel forever. -- Otherwise it'll block the kernel forever.
dir <- liftIO getIHaskellDir
let cmd = printf "IPython.Stdin.fixStdin \"%s\"" dir
when allowedStdin $ void $ when allowedStdin $ void $
runStmt "IHaskell.Eval.Stdin.fixStdin" RunToCompletion runStmt cmd RunToCompletion
initializeItVariable initializeItVariable
...@@ -189,9 +193,10 @@ initializeImports = do ...@@ -189,9 +193,10 @@ initializeImports = do
-- | Give a value for the `it` variable. -- | Give a value for the `it` variable.
initializeItVariable :: Interpreter () initializeItVariable :: Interpreter ()
initializeItVariable = initializeItVariable = do
-- This is required due to the way we handle `it` in the wrapper -- This is required due to the way we handle `it` in the wrapper
-- statements - if it doesn't exist, the first statement will fail. -- statements - if it doesn't exist, the first statement will fail.
write "Setting `it` to unit."
void $ runStmt "let it = ()" RunToCompletion void $ runStmt "let it = ()" RunToCompletion
-- | Publisher for IHaskell outputs. The first argument indicates whether -- | Publisher for IHaskell outputs. The first argument indicates whether
...@@ -272,8 +277,8 @@ safely state = ghandle handler . ghandle sourceErrorHandler ...@@ -272,8 +277,8 @@ safely state = ghandle handler . ghandle sourceErrorHandler
evalPager = "" evalPager = ""
} }
doc :: GhcMonad m => SDoc -> m String doc :: GhcMonad m => SDoc -> m String
doc sdoc = do doc sdoc = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
let cols = pprCols flags let cols = pprCols flags
d = runSDoc sdoc (initSDocContext flags defaultUserStyle) d = runSDoc sdoc (initSDocContext flags defaultUserStyle)
...@@ -369,34 +374,6 @@ evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do ...@@ -369,34 +374,6 @@ evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
case catMaybes results of case catMaybes results of
[] -> return [] [] -> return []
errors -> return $ displayError $ intercalate "\n" errors errors -> return $ displayError $ intercalate "\n" errors
where
-- Set an extension and update flags.
-- Return Nothing on success. On failure, return an error message.
setExtension :: String -> Interpreter (Maybe ErrMsg)
setExtension ext = do
flags <- getSessionDynFlags
-- First, try to check if this flag matches any extension name.
let newFlags =
case find (flagMatches ext) xFlags of
Just (_, flag, _) -> Just $ xopt_set flags flag
-- If it doesn't match an extension name, try matching against
-- disabling an extension.
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just (_, flag, _) -> Just $ xopt_unset flags flag
Nothing -> Nothing
-- Set the flag if we need to.
case newFlags of
Just flags -> setSessionDynFlags flags >> return Nothing
Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
-- Check if a FlagSpec matches an extension name.
flagMatches ext (name, _, _) = ext == name
-- Check if a FlagSpec matches "No<ExtensionName>".
-- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
write $ "Type: " ++ expr write $ "Type: " ++ expr
...@@ -594,18 +571,23 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do ...@@ -594,18 +571,23 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
if fixity == GHC.defaultFixity if fixity == GHC.defaultFixity
then empty then empty
else ppr fixity <+> pprInfixName (getName thing) else ppr fixity <+> pprInfixName (getName thing)
outs = map printInfo filteredOutput
-- Print nicely. -- Print nicely.
unqual <- getPrintUnqual strings <- mapM (doc . printInfo) filteredOutput
flags <- getSessionDynFlags let output = case getFrontend state of
let strings = map (showSDocForUser flags unqual) outs IPythonConsole -> unlines strings
IPythonNotebook -> unlines (map htmlify strings)
htmlify str =
printf "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>" str
++ script
script =
"<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>"
return EvalOut { return EvalOut {
evalStatus = Success, evalStatus = Success,
evalResult = [], evalResult = [],
evalState = state, evalState = state,
evalPager = unlines strings evalPager = output
} }
evalCommand _ (Directive SearchHoogle query) state = safely state $ do evalCommand _ (Directive SearchHoogle query) state = safely state $ do
......
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where
import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional)
eol :: Parser Char
eol = oneOf "\n\r" <?> "end of line"
quote :: Parser Char
quote = char '\"'
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
manyTill :: Parser a -> Parser [a] -> Parser [a]
manyTill p end = scan
where
scan = end <|> do
x <- p
xs <- scan
return $ x:xs
manyTill1 p end = do x <- p
xs <- manyTill p end
return $ x : xs
unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do
x <- noneOf "\\"
lookAhead p
return [x]
quotedString = do
quote <?> "expected starting quote"
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end
where end = unescapedChar space
<|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word"
separator :: Parser String
separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n)
words :: Parser [String]
words = try (eof *> return []) <|> do
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
xs <- words
return $ x : xs
parseShell :: String -> Either ParseError [String]
parseShell string = parse words "shell" (string ++ "\n")
...@@ -33,6 +33,7 @@ import SrcLoc hiding (Located) ...@@ -33,6 +33,7 @@ import SrcLoc hiding (Located)
import StringBuffer import StringBuffer
import Language.Haskell.GHC.Parser import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
-- | A block of code to be evaluated. -- | A block of code to be evaluated.
-- Each block contains a single element - one declaration, statement, -- Each block contains a single element - one declaration, statement,
...@@ -84,10 +85,16 @@ parseString codeString = do ...@@ -84,10 +85,16 @@ parseString codeString = do
let output = runParser flags parserModule codeString let output = runParser flags parserModule codeString
case output of case output of
Parsed {} -> return [Located 1 $ Module codeString] Parsed {} -> return [Located 1 $ Module codeString]
Failure {} -> Failure {} -> do
-- Split input into chunks based on indentation. -- Split input into chunks based on indentation.
let chunks = layoutChunks $ dropComments codeString in let chunks = layoutChunks $ dropComments codeString
joinFunctions <$> processChunks [] chunks result <- joinFunctions <$> processChunks [] chunks
-- Return to previous flags. When parsing, flags can be set to make
-- sure parsing works properly. But we don't want those flags to be
-- set during evaluation until the right time.
setSessionDynFlags flags
return result
where where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock) parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$> parseChunk chunk line = Located line <$>
...@@ -104,6 +111,7 @@ parseString codeString = do ...@@ -104,6 +111,7 @@ parseString codeString = do
-- If we have more remaining, parse the current chunk and recurse. -- If we have more remaining, parse the current chunk and recurse.
Located line chunk:remaining -> do Located line chunk:remaining -> do
block <- parseChunk chunk line block <- parseChunk chunk line
activateParsingExtensions $ unloc block
processChunks (block : accum) remaining processChunks (block : accum) remaining
-- Test wither a given chunk is a directive. -- Test wither a given chunk is a directive.
...@@ -114,6 +122,10 @@ parseString codeString = do ...@@ -114,6 +122,10 @@ parseString codeString = do
nlines :: String -> Int nlines :: String -> Int
nlines = length . lines nlines = length . lines
activateParsingExtensions :: GhcMonad m => CodeBlock -> m ()
activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext
activateParsingExtensions _ = return ()
-- | Parse a single chunk of code, as indicated by the layout of the code. -- | Parse a single chunk of code, as indicated by the layout of the code.
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk code startLine = do parseCodeChunk code startLine = do
......
module IHaskell.Eval.Util (
extensionFlag, setExtension,
ExtFlag(..),
) where
-- GHC imports.
import GHC
import GhcMonad
import DynFlags
import Data.List (find)
data ExtFlag
= SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
extensionFlag :: String -> Maybe ExtFlag
extensionFlag ext =
case find (flagMatches ext) xFlags of
Just (_, flag, _) -> Just $ SetFlag flag
-- If it doesn't match an extension name, try matching against
-- disabling an extension.
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just (_, flag, _) -> Just $ UnsetFlag flag
Nothing -> Nothing
where
-- Check if a FlagSpec matches an extension name.
flagMatches ext (name, _, _) = ext == name
-- Check if a FlagSpec matches "No<ExtensionName>".
-- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
-- Set an extension and update flags.
-- Return Nothing on success. On failure, return an error message.
setExtension :: GhcMonad m => String -> m (Maybe String)
setExtension ext = do
flags <- getSessionDynFlags
case extensionFlag ext of
Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
Just flag -> do
setSessionDynFlags $
case flag of
SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing
{-# LANGUAGE NoImplicitPrelude #-}
module IHaskell.Flags (
IHaskellMode(..),
Argument(..),
Args(..),
parseFlags,
help,
) where
import ClassyPrelude
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with
-- the mode being invoked.
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.
| Help -- ^ Display help text.
deriving (Eq, Show)
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode
= ShowHelp String
| Notebook
| Console
| UpdateIPython
| Kernel (Maybe String)
| View (Maybe ViewFormat) (Maybe String)
deriving (Eq, Show)
-- | Given a list of command-line arguments, return the IHaskell mode and
-- arguments to process.
parseFlags :: [String] -> Either String Args
parseFlags = process ihaskellArgs
-- | 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 Notebook = notebook
chooseMode (Kernel _) = kernel
chooseMode UpdateIPython = update
universalFlags :: [Flag Args]
universalFlags = [
flagReq ["extension","e", "X"] (store Extension) "<ghc-extension>" "Extension to enable at start.",
flagReq ["conf","c"] (store ConfFile) "<file.hs>" "File with commands to execute at start.",
flagHelpSimple (add Help)
]
where
add flag (Args mode flags) = Args mode $ flag : flags
store :: (String -> Argument) -> String -> Args -> Either String Args
store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev
notebook :: Mode Args
notebook = mode "notebook" (Args Notebook []) "Browser-based notebook interface." noArgs $
flagReq ["serve","s"] (store ServeFrom) "<dir>" "Directory to serve notebooks from.":
universalFlags
console :: Mode Args
console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg []
where
kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
update :: Mode Args
update = mode "update" (Args UpdateIPython []) "Update IPython frontends." noArgs []
view :: Mode Args
view = (modeEmpty $ Args (View Nothing Nothing) []) {
modeNames = ["view"],
modeCheck =
\a@(Args (View fmt file) _) ->
if not (isJust fmt && isJust file)
then Left "Syntax: IHaskell view <format> <name>[.ipynb]"
else Right a,
modeHelp = concat [
"Convert an IHaskell notebook to another format.\n",
"Notebooks are searched in the IHaskell directory and the current directory.\n",
"Available formats are " ++ intercalate ", " (map show
["pdf", "html", "ipynb", "markdown", "latex"]),
"."
],
modeArgs = ([formatArg, filenameArg], Nothing)
}
where
formatArg = flagArg updateFmt "<format>"
filenameArg = flagArg updateFile "<name>[.ipynb]"
updateFmt fmtStr (Args (View _ s) flags) =
case readMay fmtStr of
Just fmt -> Right $ Args (View (Just fmt) s) flags
Nothing -> Left $ "Invalid format '" ++ fmtStr ++ "'."
updateFile name (Args (View f _) flags) = Right $ Args (View f (Just name)) flags
ihaskellArgs :: Mode Args
ihaskellArgs =
let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in
noMode { modeGroupModes = toGroup [console, notebook, view, update, kernel] }
where
add flag (Args mode flags) = Args mode $ flag : flags
noArgs = flagArg unexpected ""
where
unexpected a = error $ "Unexpected argument: " ++ a
...@@ -26,44 +26,12 @@ import Data.List.Utils (split) ...@@ -26,44 +26,12 @@ import Data.List.Utils (split)
import Data.String.Utils (rstrip) import Data.String.Utils (rstrip)
import Text.Printf import Text.Printf
import Text.Read as Read hiding (pfail)
import Text.ParserCombinators.ReadP
import qualified System.IO.Strict as StrictIO import qualified System.IO.Strict as StrictIO
import qualified Paths_ihaskell as Paths import qualified Paths_ihaskell as Paths
import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar as Tar
import IHaskell.Types import IHaskell.Types
data ViewFormat
= Pdf
| Html
| Ipynb
| Markdown
| Latex
deriving Eq
instance Show ViewFormat where
show Pdf = "pdf"
show Html = "html"
show Ipynb = "ipynb"
show Markdown = "markdown"
show Latex = "latex"
instance Read ViewFormat where
readPrec = Read.lift $ do
str <- munch (const True)
case str of
"pdf" -> return Pdf
"html" -> return Html
"ipynb" -> return Ipynb
"notebook" -> return Ipynb
"latex" -> return Latex
"markdown" -> return Markdown
"md" -> return Markdown
_ -> pfail
-- | Which commit of IPython we are on. -- | Which commit of IPython we are on.
ipythonCommit :: Text ipythonCommit :: Text
ipythonCommit = "9c922f54af799704f4000aeee94ec7c74cada194" ipythonCommit = "9c922f54af799704f4000aeee94ec7c74cada194"
...@@ -229,7 +197,7 @@ installPipDependencies = withTmpDir $ \tmpDir -> ...@@ -229,7 +197,7 @@ installPipDependencies = withTmpDir $ \tmpDir ->
-- Extract it. -- Extract it.
cd tmpDir cd tmpDir
run_ tarPath ["-xf", versioned ++ ".tar.gz"] run_ tarPath ["-xzf", versioned ++ ".tar.gz"]
-- Install it. -- Install it.
cd $ fromText versioned cd $ fromText versioned
......
This diff is collapsed.
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell -- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets. -- Chans to communicate with the ZeroMQ sockets.
module Main where module Main where
import ClassyPrelude hiding (liftIO) import ClassyPrelude hiding (liftIO)
import Prelude (last) import Prelude (last, read)
import Control.Concurrent.Chan import Control.Concurrent.Chan
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Data.Aeson import Data.Aeson
import Text.Printf import Text.Printf
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.Directory import System.Directory
import System.Console.CmdArgs.Explicit hiding (complete)
import qualified Data.Map as Map import qualified Data.Map as Map
import IHaskell.Types import IHaskell.Types
import IHaskell.ZeroMQ import IPython.ZeroMQ
import qualified IHaskell.Message.UUID as UUID import qualified IPython.Message.UUID as UUID
import IHaskell.Eval.Evaluate import IHaskell.Eval.Evaluate
import IHaskell.Eval.Completion (complete) import IHaskell.Eval.Completion (complete)
import IHaskell.Eval.Info import IHaskell.Eval.Info
import qualified Data.ByteString.Char8 as Chars import qualified Data.ByteString.Char8 as Chars
import IHaskell.IPython import IHaskell.IPython
import qualified IHaskell.Eval.Stdin as Stdin import qualified IPython.Stdin as Stdin
import IHaskell.Flags
import GHC hiding (extensions) import GHC hiding (extensions, language)
import Outputable (showSDoc, ppr) import Outputable (showSDoc, ppr)
-- Command line arguments to IHaskell. A set of aruments is annotated with -- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
-- the mode being invoked. ghcVersionInts :: [Int]
data Args = Args IHaskellMode [Argument] ghcVersionInts = map read . words . map dotToSpace $ VERSION_ghc
where dotToSpace '.' = ' '
data Argument dotToSpace x = x
= 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.
| Help -- ^ Display help text.
deriving (Eq, Show)
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode
= None
| Notebook
| Console
| UpdateIPython
| Kernel (Maybe String)
| View (Maybe ViewFormat) (Maybe String)
deriving (Eq, Show)
main :: IO () main :: IO ()
main = do main = do
stringArgs <- map unpack <$> getArgs args <- parseFlags <$> map unpack <$> getArgs
case process ihaskellArgs stringArgs of case args of
Left errmsg -> putStrLn $ pack errmsg Left errorMessage ->
hPutStrLn stderr errorMessage
Right args -> Right args ->
ihaskell args ihaskell args
universalFlags :: [Flag Args]
universalFlags = [
flagReq ["extension","e", "X"] (store Extension) "<ghc-extension>" "Extension to enable at start.",
flagReq ["conf","c"] (store ConfFile) "<file.hs>" "File with commands to execute at start.",
flagHelpSimple (add Help)
]
where
add flag (Args mode flags) = Args mode $ flag : flags
store :: (String -> Argument) -> String -> Args -> Either String Args
store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev
notebook :: Mode Args
notebook = mode "notebook" (Args Notebook []) "Browser-based notebook interface." noArgs $
flagReq ["serve","s"] (store ServeFrom) "<dir>" "Directory to serve notebooks from.":
universalFlags
console :: Mode Args
console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg []
where
kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
update :: Mode Args
update = mode "update" (Args UpdateIPython []) "Update IPython frontends." noArgs []
view :: Mode Args
view = (modeEmpty $ Args (View Nothing Nothing) []) {
modeNames = ["view"],
modeCheck =
\a@(Args (View fmt file) _) ->
if not (isJust fmt && isJust file)
then Left "Syntax: IHaskell view <format> <name>[.ipynb]"
else Right a,
modeHelp = concat [
"Convert an IHaskell notebook to another format.\n",
"Notebooks are searched in the IHaskell directory and the current directory.\n",
"Available formats are " ++ intercalate ", " (map show
["pdf", "html", "ipynb", "markdown", "latex"]),
"."
],
modeArgs = ([formatArg, filenameArg], Nothing)
}
where
formatArg = flagArg updateFmt "<format>"
filenameArg = flagArg updateFile "<name>[.ipynb]"
updateFmt fmtStr (Args (View _ s) flags) =
case readMay fmtStr of
Just fmt -> Right $ Args (View (Just fmt) s) flags
Nothing -> Left $ "Invalid format '" ++ fmtStr ++ "'."
updateFile name (Args (View f _) flags) = Right $ Args (View f (Just name)) flags
ihaskellArgs :: Mode Args
ihaskellArgs =
let descr = "Haskell for Interactive Computing."
onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args None []) descr noArgs onlyHelp in
noMode { modeGroupModes = toGroup [console, notebook, view, update, kernel] }
where
add flag (Args mode flags) = Args mode $ flag : flags
noArgs = flagArg unexpected ""
where
unexpected a = error $ "Unexpected argument: " ++ a
ihaskell :: Args -> IO () ihaskell :: Args -> IO ()
-- If no mode is specified, print help text. -- If no mode is specified, print help text.
ihaskell (Args None _) = ihaskell (Args (ShowHelp help) _) =
print $ helpText [] HelpFormatAll ihaskellArgs putStrLn $ pack help
-- Update IPython: remove then reinstall. -- Update IPython: remove then reinstall.
-- This is in case cabal updates IHaskell but the corresponding IPython -- This is in case cabal updates IHaskell but the corresponding IPython
...@@ -188,14 +103,9 @@ showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO () ...@@ -188,14 +103,9 @@ showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
showingHelp mode flags act = showingHelp mode flags act =
case find (==Help) flags of case find (==Help) flags of
Just _ -> Just _ ->
print $ helpText [] HelpFormatAll $ chooseMode mode putStrLn $ pack $ help mode
Nothing -> Nothing ->
act act
where
chooseMode Console = console
chooseMode Notebook = notebook
chooseMode (Kernel _) = kernel
chooseMode UpdateIPython = update
-- | Parse initialization information from the flags. -- | Parse initialization information from the flags.
initInfo :: FrontendType -> [Argument] -> IO InitInfo initInfo :: FrontendType -> [Argument] -> IO InitInfo
...@@ -220,7 +130,8 @@ runKernel profileSrc initInfo = do ...@@ -220,7 +130,8 @@ runKernel profileSrc initInfo = do
Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc
-- Necessary for `getLine` and their ilk to work. -- Necessary for `getLine` and their ilk to work.
Stdin.recordKernelProfile profile dir <- getIHaskellDir
Stdin.recordKernelProfile dir profile
-- Serve on all sockets and ports defined in the profile. -- Serve on all sockets and ports defined in the profile.
interface <- serveProfile profile interface <- serveProfile profile
...@@ -278,6 +189,8 @@ createReplyHeader :: MessageHeader -> Interpreter MessageHeader ...@@ -278,6 +189,8 @@ createReplyHeader :: MessageHeader -> Interpreter MessageHeader
createReplyHeader parent = do createReplyHeader parent = do
-- Generate a new message UUID. -- Generate a new message UUID.
newMessageId <- liftIO UUID.random newMessageId <- liftIO UUID.random
let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader { return MessageHeader {
identifiers = identifiers parent, identifiers = identifiers parent,
...@@ -286,7 +199,7 @@ createReplyHeader parent = do ...@@ -286,7 +199,7 @@ createReplyHeader parent = do
messageId = newMessageId, messageId = newMessageId,
sessionId = sessionId parent, sessionId = sessionId parent,
username = username parent, username = username parent,
msgType = replyType $ msgType parent msgType = repType
} }
-- | Compute a reply to a message. -- | Compute a reply to a message.
...@@ -296,7 +209,11 @@ replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpr ...@@ -296,7 +209,11 @@ replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpr
-- needs to be done, as a kernel info reply is a static object (all info is -- needs to be done, as a kernel info reply is a static object (all info is
-- hard coded into the representation of that message type). -- hard coded into the representation of that message type).
replyTo _ KernelInfoRequest{} replyHeader state = replyTo _ KernelInfoRequest{} replyHeader state =
return (state, KernelInfoReply { header = replyHeader }) return (state, KernelInfoReply {
header = replyHeader,
language = "haskell",
versionList = ghcVersionInts
})
-- Reply to a shutdown request by exiting the main thread. -- Reply to a shutdown request by exiting the main thread.
-- Before shutdown, reply to the request to let the frontend know shutdown -- Before shutdown, reply to the request to let the frontend know shutdown
...@@ -313,7 +230,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -313,7 +230,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
let send msg = liftIO $ writeChan (iopubChannel interface) msg let send msg = liftIO $ writeChan (iopubChannel interface) msg
-- Log things so that we can use stdin. -- Log things so that we can use stdin.
liftIO $ Stdin.recordParentHeader $ header req dir <- liftIO getIHaskellDir
liftIO $ Stdin.recordParentHeader dir $ header req
-- Notify the frontend that the kernel is busy computing. -- Notify the frontend that the kernel is busy computing.
-- All the headers are copies of the reply header with a different -- All the headers are copies of the reply header with a different
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment