Commit 3c68a6af authored by Eyal Dechter's avatar Eyal Dechter

Merge remote-tracking branch 'upstream/master' into path_completion

parents 291363a9 45664753
:set -package ghc
:set -package ghc-paths
:set -optP-include -optPdist/build/autogen/cabal_macros.h
:set -i. -isrc -idist/build/autogen
:set -XDoAndIfThenElse -XNoImplicitPrelude -XOverloadedStrings
......@@ -46,6 +46,7 @@ data-files:
profile/profile.tar
library
hs-source-dirs: src
build-depends: base ==4.6.*,
hlint,
cmdargs >= 0.10,
......@@ -75,8 +76,7 @@ library
filepath,
cereal ==0.3.*,
text >=0.11,
mtl >= 2.1,
template-haskell
mtl >= 2.1
exposed-modules: IHaskell.Display,
Paths_ihaskell,
IHaskell.Types,
......@@ -84,6 +84,7 @@ library
executable IHaskell
-- .hs or .lhs file containing the Main module.
hs-source-dirs: src
main-is: Main.hs
build-tools: happy, cpphs
......@@ -102,7 +103,6 @@ executable IHaskell
IHaskell.Types
IHaskell.ZeroMQ
IHaskell.Display
IHaskell.Config
extensions: DoAndIfThenElse
......@@ -136,8 +136,7 @@ executable IHaskell
filepath,
cereal ==0.3.*,
text >=0.11,
mtl >= 2.1,
template-haskell
mtl >= 2.1
Test-Suite hspec
Type: exitcode-stdio-1.0
......@@ -170,8 +169,7 @@ Test-Suite hspec
system-filepath,
cereal ==0.3.*,
text >=0.11,
mtl >= 2.1,
template-haskell
mtl >= 2.1
source-repository head
type: git
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Description : IPython configuration files are compiled-into IHaskell
module IHaskell.Config (ipython, notebook, console, qtconsole, customjs, notebookJavascript) where
import Data.String.Here
import ClassyPrelude
ipython :: String -> String
ipython executable = [template|config/ipython_config.py|]
notebook :: String
notebook = [template|config/ipython_notebook_config.py|]
console :: String
console = [template|config/ipython_console_config.py|]
qtconsole :: String
qtconsole = [template|config/ipython_qtconsole_config.py|]
customjs :: String
customjs = [template|config/custom.js|]
notebookJavascript :: [(FilePath, String)]
notebookJavascript = [("tooltip.js", [template|deps/tooltip.js|]),
("codecell.js", [template|deps/codecell.js|])]
......@@ -69,8 +69,7 @@ Compilation Tools
---
Install the `happy` parser generator tool and `cpphs` preprocessor:
```bash
cabal install happy
cabal install cpphs
cabal install happy cpphs
```
IHaskell Installation
......@@ -148,10 +147,17 @@ The will hide all packages not listed in the
**Using GHCi directly**
If you don't want to use cabal repl, you can just call ghci with the appropriate options. You can find these in the IHaskell.cabal file.
If you don't want to use `cabal repl`, you can just call ghci which can read the `.ghci` file included in the repository for the options.
```bash
ghci -XDoAndIfThenElse -XNoImplicitPrelude -XOverloadedStrings -package ghc -optP-include -optPdist/build/autogen/cabal_macros.h
cd <path-to-IHaskell>
chmod 600 .ghci # trust the .ghci file
ghci
```
Then in the ghci session you can type things like:
If you just call ghci, it will use the options present in the .ghci file that comes with the IHaskell repo.
```
:load src/Hspec.hs
hspec parserTests
:browse IHaskell.Types
```
......@@ -2,8 +2,8 @@
# exe: Path to IHaskell kernel.
c = get_config()
c.KernelManager.kernel_cmd = [exe, 'kernel', '{connection_file}']
c.Session.key = ''
c.Session.keyfile = ''
c.Session.key = b''
c.Session.keyfile = b''
# Syntax highlight properly in Haskell notebooks.
c.NbConvertBase.default_language = "haskell"
No preview for this file type
......@@ -53,7 +53,19 @@ var concealExtension = (function() {
// Process a non-infix conceal token.
function markNonInfixToken(editor, line, token) {
// First, check if this is a normal concealable element. (non-infix)
// We have a special case for the dot operator.
// This is because CodeMirror parses some bits of Haskell incorrectly.
// For instance: [1..100] gets parsed as a number "1." followed by a dot ".".
// This causes the "." to become marked, although it shouldn't be.
if (token.string == ".") {
var prev = prevToken(editor, token, line);
var prevStr = prev.string;
if(prevStr[prevStr.length - 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) {
......
/*
Custom IHaskell CSS.
*/
/* Styles used for basic displays */
.get-type {
color: green;
font-weight: bold;
font-family: monospace;
}
.err-msg {
color: red;
font-style: italic;
font-family: monospace;
white-space: pre;
}
/* 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);
......
......@@ -53,7 +53,7 @@ $([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
var md = IPython.notebook.metadata;
if(md.language){
console.log('language already defined and is :', md.language);
} else {
......@@ -71,14 +71,21 @@ $([IPython.events]).on('app_initialized.NotebookApp', function(){
cells = IPython.notebook.get_cells();
for(var i in cells){
c = cells[i];
if (c.cell_type === 'code'){
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', 'haskell');
c.auto_highlight()
}
}
})
// We can only load the conceal scripts once all cells have mode 'haskell'
require(['/static/custom/conceal/conceal.js']);
});
IPython.CodeCell.options_default['cm_config']['mode'] = 'haskell';
require(['/static/custom/conceal/conceal.js']);
});
var highlightCodes = function() {
......
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Prelude
import GHC
import GHC.Paths
import Data.IORef
......@@ -7,6 +9,7 @@ import Data.List
import System.Directory
import Data.String.Here
import Data.String.Utils (strip, replace)
import Data.Monoid
import IHaskell.Eval.Parser
import IHaskell.Types
......@@ -33,7 +36,7 @@ eval string = do
outputAccum <- newIORef []
let publish final displayDatas = when final $ modifyIORef outputAccum (displayDatas :)
getTemporaryDirectory >>= setCurrentDirectory
let state = KernelState 1 LintOff "."
let state = defaultKernelState { getLintStatus = LintOff }
interpret $ Eval.evaluate state string publish
out <- readIORef outputAccum
return $ reverse out
......@@ -283,7 +286,7 @@ parseStringTests = describe "Parser" $ do
it "parses :set x" $
parses ":set x" `like` [
Directive HelpForSet "x"
Directive SetOpt "x"
]
it "parses :extension x" $
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display (
IHaskellDisplay(..),
plain, html, png, jpg, svg, latex,
serializeDisplay
serializeDisplay,
Width, Height, Base64Data
) where
import ClassyPrelude
......@@ -13,9 +13,17 @@ import Data.String.Utils (rstrip)
import IHaskell.Types
type Base64Data = String
-- | A class for displayable Haskell types.
--
-- IHaskell's displaying of results behaves as if these two
-- overlapping/undecidable instances also existed:
--
-- > instance (Show a) => IHaskellDisplay a
-- > instance Show a where shows _ = id
class IHaskellDisplay a where
display :: a -> [DisplayData]
display :: a -> IO [DisplayData]
-- | Generate a plain text display.
plain :: String -> DisplayData
......@@ -25,11 +33,11 @@ plain = Display PlainText . rstrip
html :: String -> DisplayData
html = Display MimeHtml
png :: String -> DisplayData
png = Display MimePng
png :: Width -> Height -> Base64Data -> DisplayData
png width height = Display (MimePng width height)
jpg :: String -> DisplayData
jpg = Display MimeJpg
jpg :: Width -> Height -> Base64Data -> DisplayData
jpg width height = Display (MimeJpg width height)
svg :: String -> DisplayData
svg = Display MimeSvg
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : generates tab-completion options
context-insensitive completion for what is probably
the identifier under the cursor.
[@Known issues@]
> import Data.Lef<tab>
> System.IO.h<tab>
> Just.he<tab>
The first should not complete to Left. The second should only
include things like System.IO.hPutStrLn, not head. Qualified
names should not be confused by the third option.
{- |
Description : Generates tab completion options.
This has a limited amount of context sensitivity. It distinguishes between four contexts at the moment:
- import statements (completed using modules)
- identifiers (completed using in scope values)
- extensions via :ext (completed using GHC extensions)
- qualified identifiers (completed using in-scope values)
-}
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
......
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings #-}
{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
a statement, declaration, import, or directive.
......@@ -12,7 +12,7 @@ import ClassyPrelude hiding (liftIO, hGetContents, try)
import Control.Concurrent (forkIO, threadDelay)
import Prelude (putChar, head, tail, last, init, (!!))
import Data.List.Utils
import Data.List(findIndex)
import Data.List(findIndex, and)
import Data.String.Utils
import Text.Printf
import Data.Char as Char
......@@ -24,6 +24,7 @@ import System.Posix.IO
import System.IO (hGetChar, hFlush)
import System.Random (getStdGen, randomRs)
import Unsafe.Coerce
import Control.Monad (guard)
import NameSet
import Name
......@@ -52,6 +53,9 @@ import IHaskell.Eval.Parser
import IHaskell.Eval.Lint
import IHaskell.Display
import Paths_ihaskell (version)
import Data.Version (versionBranch)
data ErrorOccurred = Success | Failure deriving Show
debug :: Bool
......@@ -101,15 +105,38 @@ interpret action = runGhc (Just libdir) $ do
-- | Initialize our GHC session with imports and a value for 'it'.
initializeImports :: Interpreter ()
initializeImports = do
-- Load packages that start with ihaskell-* and aren't just IHaskell.
-- Load packages that start with ihaskell-*, aren't just IHaskell,
-- and depend directly on the right version of the ihaskell library
dflags <- getSessionDynFlags
displayPackages <- liftIO $ do
(dflags, _) <- initPackages dflags
let Just db = pkgDatabase dflags
packageNames = map (packageIdString . packageConfigId) db
initStr = "ihaskell-"
ihaskellPkgs = filter (startswith initStr) packageNames
displayPkgs = filter (isAlpha . (!! (length initStr + 1))) ihaskellPkgs
-- "ihaskell-1.2.3.4"
iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))
dependsOnRight pkg = not $ null $ do
pkg <- db
depId <- depends pkg
dep <- filter ((== depId) . installedPackageId) db
guard (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))
-- ideally the Paths_ihaskell module could provide a way to get the
-- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9),
-- for now. Things will end badly if you also happen to have an
-- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.
iHaskellPkg = case filter (== iHaskellPkgName) packageNames of
[x] -> x
[] -> error ("cannot find required haskell library: "++iHaskellPkgName)
_ -> error ("multiple haskell packages "++iHaskellPkgName++" found")
displayPkgs = [ pkgName
| pkgName <- packageNames,
Just (x:_) <- [stripPrefix initStr pkgName],
isAlpha x]
return displayPkgs
-- Generate import statements all Display modules.
......@@ -305,17 +332,6 @@ evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
-- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
evalCommand _ (Directive SetLint status) state = do
let isOn = "on" == strip status
let isOff = "off" == strip status
return $ if isOn
then EvalOut Success [] (state { getLintStatus = LintOn })
else if isOff
then EvalOut Success [] (state { getLintStatus = LintOff })
else EvalOut Failure err state
where
err = displayError $ "Unknown hlint command: " ++ status
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
write $ "Type: " ++ expr
result <- exprType expr
......@@ -339,18 +355,33 @@ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive HelpForSet _) state = do
write "Help for :set."
evalCommand _ (Directive SetOpt option) state = do
let opt = strip option
newState = setOpt opt state
out = case newState of
Nothing -> displayError $ "Unknown option: " ++ opt
Just _ -> []
return EvalOut {
evalStatus = Success,
evalResult = [out],
evalState = state
evalStatus = if isJust newState then Success else Failure,
evalResult = out,
evalState = fromMaybe state newState
}
where out = plain $ intercalate "\n"
[":set is not implemented in IHaskell."
," Use :extension <Extension> to enable a GHC extension."
," Use :extension No<Extension> to disable a GHC extension."
]
where
setOpt :: String -> KernelState -> Maybe KernelState
setOpt "lint" state = Just $
state { getLintStatus = LintOn }
setOpt "nolint" state = Just $
state { getLintStatus = LintOff }
setOpt "svg" state = Just $
state { useSvg = True }
setOpt "nosvg" state = Just $
state { useSvg = False }
setOpt _ _ = Nothing
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetHelp _) state = do
......@@ -366,9 +397,15 @@ evalCommand _ (Directive GetHelp _) state = do
," :extension No<Extension> - disable a GHC extension."
," :type <expression> - Print expression type."
," :info <name> - Print all info for a name."
," :set <opt> - Set an option."
," :set no<opt> - Unset an option."
," :?, :help - Show this help text."
,""
,"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)."
]
-- This is taken largely from GHCi's info section in InteractiveUI.
......@@ -423,9 +460,9 @@ evalCommand output (Expression expr) state = do
-- The output is bound to 'it', so we can then use it.
evalOut <- evalCommand output (Statement expr) state
-- Try to use `display` to convert our type into the output
-- Try to use `display` to convert our type into the output
-- DisplayData. If typechecking fails and there is no appropriate
-- typeclass, this will throw an exception and thus `attempt` will
-- typeclass instance, this will throw an exception and thus `attempt` will
-- return False, and we just resort to plaintext.
let displayExpr = printf "(IHaskell.Display.display (%s))" expr
canRunDisplay <- attempt $ exprType displayExpr
......@@ -463,6 +500,9 @@ evalCommand output (Expression expr) state = do
Nothing -> False
where isPlain (Display mime _) = mime == PlainText
isSvg (Display MimeSvg _) = True
isSvg _ = False
useDisplay displayExpr = wrapExecution state $ do
-- If there are instance matches, convert the object into
-- a [DisplayData]. We also serialize it into a bytestring. We get
......@@ -472,7 +512,7 @@ evalCommand output (Expression expr) state = do
-- back gives very strange errors - all the types match but it
-- refuses to decode back into a [DisplayData].
-- Suppress output, so as not to mess up console.
capturedStatement (const $ return ()) displayExpr
out <- capturedStatement (const $ return ()) displayExpr
displayedBytestring <- dynCompileExpr "IHaskell.Display.serializeDisplay it"
case fromDynamic displayedBytestring of
......@@ -482,7 +522,10 @@ evalCommand output (Expression expr) state = do
Left err -> error err
Right displayData -> do
write $ show displayData
return displayData
return $
if useSvg state
then displayData
else filter (not . isSvg) displayData
evalCommand _ (Declaration decl) state = wrapExecution state $ do
......@@ -692,20 +735,44 @@ capturedStatement output stmt = do
return (printedOutput, result)
formatError :: ErrMsg -> String
formatError = printf "<span style='color: red; font-style: italic;'>%s</span>" .
formatError = printf "<span class='err-msg'>%s</span>" .
replace "\n" "<br/>" .
fixLineWrapping .
replace useDashV "" .
rstrip .
typeCleaner
where
useDashV = "\nUse -v to see a list of the files searched for."
useDashV = "\nUse -v to see a list of the files searched for."
fixLineWrapping err
| isThreePartTypeError err =
let (before, exp:after) = break ("Expected type" `isInfixOf`) $ lines err
(expected, act:actual) = break ("Actual type" `isInfixOf`) after in
unlines $ map unstripped [before, exp:expected, act:actual]
| isTwoPartTypeError err =
let (one, two) = break ("with actual type" `isInfixOf`) $ lines err in
unlines $ map unstripped [one, two]
| otherwise = err
where
unstripped (line:lines) = unwords $ line:map lstrip lines
isThreePartTypeError err = all (`isInfixOf` err) [
"Couldn't match type",
"with",
"Expected type:",
"Actual type:"
]
isTwoPartTypeError err = all (`isInfixOf` err) [
"Couldn't match expected type",
"with actual type"
]
formatParseError :: StringLoc -> String -> ErrMsg
formatParseError (Loc line col) =
printf "Parse error (line %d, column %d): %s" line col
formatGetType :: String -> String
formatGetType = printf "<span style='font-weight: bold; color: green;'>%s</span>"
formatGetType = printf "<span class='get-type'>%s</span>"
displayError :: ErrMsg -> [DisplayData]
displayError msg = [plain . typeCleaner $ msg, html $ formatError msg]
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (
lint
) where
......@@ -11,6 +11,8 @@ import Control.Monad
import Data.List (findIndex)
import Text.Printf
import Data.String.Here
import Data.Char
import Data.Monoid
import IHaskell.Types
import IHaskell.Display
......@@ -22,6 +24,7 @@ data LintSeverity = LintWarning | LintError deriving (Eq, Show)
data LintSuggestion
= Suggest {
line :: LineNumber,
chunkNumber :: Int,
found :: String,
whyNot :: String,
severity :: LintSeverity,
......@@ -38,7 +41,7 @@ lintIdent = "lintIdentAEjlkQeh"
lint :: [Located CodeBlock] -> IO [DisplayData]
lint blocks = do
let validBlocks = map makeValid blocks
fileContents = joinBlocks 1 validBlocks
fileContents = joinBlocks validBlocks
-- Get a temporarly location to store this file.
ihaskellDir <- getIHaskellDir
let filename = ihaskellDir ++ "/.hlintFile.hs"
......@@ -54,15 +57,13 @@ lint blocks = do
-- Join together multiple valid file blocks into a single file.
-- However, join them with padding so that the line numbers are
-- correct.
joinBlocks :: LineNumber -> [Located String] -> String
joinBlocks nextLine (Located desiredLine str:strs) =
-- Place padding to shift the line number appropriately.
replicate (desiredLine - nextLine) '\n' ++
str ++ "\n" ++
joinBlocks (desiredLine + nlines str) strs
joinBlocks _ [] = ""
joinBlocks :: [Located String] -> String
joinBlocks = unlines . zipWith addPragma [1 .. ]
nlines = length . lines
addPragma :: Int -> Located String -> String
addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str
linePragma = printf "{-# LINE %d \"%d\" #-}\n"
plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest =
......@@ -114,46 +115,56 @@ htmlSuggestions = concatMap toHtml
-- If parsing fails, return Nothing.
parseSuggestion :: Suggestion -> Maybe LintSuggestion
parseSuggestion suggestion = do
let str = showSuggestion suggestion
let str = showSuggestion (show suggestion)
severity = suggestionSeverity suggestion
guard (severity /= HLint.Ignore)
let lintSeverity = case severity of
Warning -> LintWarning
Error -> LintError
let suggestionLines = lines str
-- Expect a header line, a "Found" line, and a "Why not" line.
guard (length suggestionLines > 3)
headerLine:foundLine:rest <- Just (lines str)
-- Expect the line after the header to have 'Found' in it.
let headerLine:foundLine:rest = suggestionLines
guard ("Found:" `isInfixOf` foundLine)
-- Expect something like:
-- ".hlintFile.hs:1:19: Warning: Redundant bracket"
let headerPieces = split ":" headerLine
guard (length headerPieces == 5)
let [file, line, col, severity, name] = headerPieces
-- ==>
-- [".hlintFile.hs","1","19"," Warning"," Redundant bracket"]
[readMay -> Just chunkN,
readMay -> Just lineNum, _col, severity, name] <- Just (split ":" headerLine)
whyIndex <- findIndex ("Why not:" `isInfixOf`) rest
let (before, _:after) = splitAt whyIndex rest
lineNum <- readMay line
(before, _:after) <- Just (break ("Why not:" `isInfixOf`) rest)
return Suggest {
line = lineNum,
chunkNumber = chunkN,
found = unlines before,
whyNot = unlines after,
suggestion = name,
severity = lintSeverity
}
where
showSuggestion =
replace (lintIdent ++ "=") "" .
replace (lintIdent ++ "$do ") "" .
replace (replicate (length lintIdent + length " $ do ") ' ' ++ lintIdent) "" .
replace (" in " ++ lintIdent) "" .
show
showSuggestion :: String -> String
showSuggestion =
replace ("return " ++ lintIdent) "" .
replace (lintIdent ++ "=") "" .
dropDo
where
-- drop leading ' do ', and blank spaces following
dropDo :: String -> String
dropDo = unlines . f . lines
where
f :: [String] -> [String]
f ((stripPrefix " do " -> Just a) : as) =
let as' = catMaybes
$ takeWhile isJust
$ map (stripPrefix " ") as
in a : as' ++ f (drop (length as') as)
f (x:xs) = x : f xs
f [] = []
-- | Convert a code chunk into something that could go into a file.
-- The line number on the output is the same as on the input.
makeValid :: Located CodeBlock -> Located String
......@@ -162,28 +173,27 @@ makeValid (Located line block) = Located line $
-- Expressions need to be bound to some identifier.
Expression expr -> lintIdent ++ "=" ++ expr
-- Statements need to go in a 'do' block bound to an identifier.
-- It must also end with a 'return'.
Statement stmt ->
-- Let's must be handled specially, because we can't have layout
-- inside non-layout. For instance, this is illegal:
-- a = do { let x = 3; return 3 }
-- because it should be
-- a = do { let {x = 3}; return 3 }
-- Thus, we rely on template haskell and instead turn it into an
-- expression via let x = blah 'in blah'.
if startswith "let" $ strip stmt
then stmt ++ " in " ++ lintIdent
else
-- We take advantage of the fact that naked expressions at toplevel
-- are allowed by Template Haskell, and output them to a file.
let prefix = lintIdent ++ " $ do "
first:rest = split "\n" stmt
indent = replicate (length prefix) ' '
fixedLines = first : map (indent ++) rest
extraReturnLine = [indent ++ lintIdent]
code = intercalate "\n" (fixedLines ++ extraReturnLine) in
prefix ++ code
-- Statements go in a 'do' block bound to an identifier.
--
-- a cell can contain:
-- > x <- readFile "foo"
-- so add a return () to avoid a Parse error: Last statement in
-- a do-block must be an expression
--
-- one place this goes wrong is when the chunk is:
--
-- > do
-- > {- a comment that has to -} let x = 1
-- > {- count as whitespace -} y = 2
-- > return (x+y)
Statement stmt ->
let expandTabs = replace "\t" " "
nLeading = maybe 0 (length . takeWhile isSpace)
$ listToMaybe
$ filter (not . all isSpace)
(lines (expandTabs stmt))
finalReturn = replicate nLeading ' ' ++ "return " ++ lintIdent
in intercalate ("\n ") ((lintIdent ++ " $ do") : lines stmt ++ [finalReturn])
-- Modules, declarations, and type signatures are fine as is.
Module mod -> mod
......
......@@ -61,8 +61,7 @@ data DirectiveType
| GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)
| SetExtension -- ^ Enable or disable an extension via ':extension' (or prefixes)
| LoadFile -- ^ Load a Haskell module.
| SetLint -- ^ Enable or disable a hlint via ':hlint on' or ':hlint off'
| HelpForSet -- ^ Provide useful info if people try ':set'.
| SetOpt -- ^ Set various options.
| GetHelp -- ^ General help via ':?' or ':help'.
deriving (Show, Eq)
......@@ -238,8 +237,7 @@ parseDirective (':':directive) line = case find rightDirective directives of
,(GetInfo, "info")
,(SetExtension, "extension")
,(LoadFile, "load")
,(SetLint, "hlint")
,(HelpForSet, "set")
,(SetOpt, "set")
,(GetHelp, "?")
,(GetHelp, "help")
]
......
......@@ -201,30 +201,39 @@ installIPython = void . shellyNoDir $ do
-- | Install all Python dependencies.
installPipDependencies :: Sh ()
installPipDependencies = mapM_ installDependency [("markupsafe", "0.18")
,("pyzmq", "14.0.1")
,("tornado","3.1.1")
,("jinja2","2.7.1")]
installPipDependencies = withTmpDir $ \tmpDir ->
mapM_ (installDependency tmpDir)
[
("pyzmq", "14.0.1")
, ("setuptools", "2.0.2") -- This cannot go first in the dependenc list, because its setup.py is broken.
, ("MarkupSafe", "0.18") -- Neither can this
, ("tornado","3.1.1")
, ("jinja2","2.7.1")
]
where
installDependency :: (Text, Text) -> Sh ()
installDependency (dep, version) = withTmpDir $ \tmpDir -> do
installDependency :: FilePath -> (Text, Text) -> Sh ()
installDependency tmpDir (dep, version) = sub $ do
let versioned = dep ++ "-" ++ version
putStrLn $ "Installing dependency: " ++ versioned
pipPath <- path "pip"
tarPath <- path "tar"
pythonPath <- path "python"
-- Download the package.
let downloadOpt = "--download=" ++ fpToText tmpDir
run_ pipPath ["install", downloadOpt, dep ++ "==" ++ version]
-- Extract it.
cd tmpDir
run_ tarPath ["-xf", versioned ++ ".tar.gz"]
-- Install it.
cd $ fromText versioned
prefixOpt <- ("--prefix=" ++) <$> fpToText <$> ipythonDir
run_ pipPath ["install", prefixOpt]
dir <- fpToText <$> ipythonDir
setenv "PYTHONPATH" $ dir ++ "/lib/python2.7/site-packages/"
let prefixOpt = "--prefix=" ++ dir
run_ pythonPath ["setup.py", "install", prefixOpt]
-- | Once things are checked out into the IPython source directory, build it and install it.
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-}
-- | Description : @ToJSON@ for Messages
--
-- This module contains the @ToJSON@ instance for @Message@.
......@@ -11,20 +10,16 @@ import Prelude (read)
import ClassyPrelude
import Data.Aeson
import Language.Haskell.TH
import Shelly hiding (trace)
import IHaskell.Types
-- | Compute the GHC API version number using Template Haskell.
-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
ghcVersionInts :: [Int]
ghcVersionInts = ints . map read . words . map dotToSpace $ version
ghcVersionInts = ints . map read . words . map dotToSpace $ VERSION_ghc
where dotToSpace '.' = ' '
dotToSpace x = x
version :: String
version = $(runIO (unpack <$> shelly (run "ghc" ["--numeric-version"])) >>= stringE)
-- Convert message bodies into JSON.
instance ToJSON Message where
toJSON KernelInfoReply{} = object [
......
......@@ -18,6 +18,8 @@ module IHaskell.Types (
InitInfo(..),
KernelState(..),
LintStatus(..),
Width, Height,
defaultKernelState
) where
import ClassyPrelude
......@@ -72,7 +74,16 @@ instance ToJSON Profile where
data KernelState = KernelState
{ getExecutionCounter :: Int,
getLintStatus :: LintStatus, -- Whether to use hlint, and what arguments to pass it.
getCwd :: String
getCwd :: String,
useSvg :: Bool
}
defaultKernelState :: KernelState
defaultKernelState = KernelState
{ getExecutionCounter = 1,
getLintStatus = LintOn,
getCwd = ".",
useSvg = True
}
-- | Initialization information for the kernel.
......@@ -294,17 +305,25 @@ instance Show ExecuteReplyStatus where
data ExecutionState = Busy | Idle | Starting deriving Show
-- | Data for display: a string with associated MIME type.
data DisplayData = Display MimeType String deriving (Show, Typeable, Generic)
data DisplayData = Display MimeType String deriving (Typeable, Generic)
-- We can't print the actual data, otherwise this will be printed every
-- time it gets computed because of the way the evaluator is structured.
-- See how `displayExpr` is computed.
instance Show DisplayData where
show _ = "Display"
-- Allow DisplayData serialization
instance Serialize DisplayData
instance Serialize MimeType
-- | Possible MIME types for the display data.
type Width = Int
type Height = Int
data MimeType = PlainText
| MimeHtml
| MimePng
| MimeJpg
| MimePng Width Height
| MimeJpg Width Height
| MimeSvg
| MimeLatex
deriving (Eq, Typeable, Generic)
......@@ -313,8 +332,8 @@ data MimeType = PlainText
instance Show MimeType where
show PlainText = "text/plain"
show MimeHtml = "text/html"
show MimePng = "image/png"
show MimeJpg = "image/jpeg"
show (MimePng _ _) = "image/png"
show (MimeJpg _ _) = "image/jpeg"
show MimeSvg = "image/svg+xml"
show MimeLatex = "text/latex"
......
......@@ -260,11 +260,7 @@ runKernel profileSrc initInfo = do
-- Initial kernel state.
initialKernelState :: IO (MVar KernelState)
initialKernelState =
newMVar KernelState {
getExecutionCounter = 1,
getLintStatus = LintOn,
getCwd = "."
}
newMVar defaultKernelState
-- | Duplicate a message header, giving it a new UUID and message type.
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
......
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