Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
G
gargantext-ihaskell
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
gargantext-ihaskell
Commits
3c68a6af
Commit
3c68a6af
authored
Jan 05, 2014
by
Eyal Dechter
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'upstream/master' into path_completion
parents
291363a9
45664753
Changes
23
Hide whitespace changes
Inline
Side-by-side
Showing
23 changed files
with
298 additions
and
182 deletions
+298
-182
.ghci
.ghci
+1
-0
IHaskell.cabal
IHaskell.cabal
+5
-7
Config.hs
IHaskell/Config.hs
+0
-26
README.md
README.md
+11
-5
ipython_config.py
profile/ipython_config.py
+2
-2
profile.tar
profile/profile.tar
+0
-0
conceal.js
profile/static/custom/conceal/conceal.js
+13
-1
custom.css
profile/static/custom/custom.css
+19
-0
custom.js
profile/static/custom/custom.js
+11
-4
Hspec.hs
src/Hspec.hs
+5
-2
Display.hs
src/IHaskell/Display.hs
+15
-7
Completion.hs
src/IHaskell/Eval/Completion.hs
+8
-14
Evaluate.hs
src/IHaskell/Eval/Evaluate.hs
+100
-33
Info.hs
src/IHaskell/Eval/Info.hs
+0
-0
Lint.hs
src/IHaskell/Eval/Lint.hs
+60
-50
Parser.hs
src/IHaskell/Eval/Parser.hs
+2
-4
IPython.hs
src/IHaskell/IPython.hs
+17
-8
Parser.hs
src/IHaskell/Message/Parser.hs
+0
-0
UUID.hs
src/IHaskell/Message/UUID.hs
+0
-0
Writer.hs
src/IHaskell/Message/Writer.hs
+3
-8
Types.hs
src/IHaskell/Types.hs
+25
-6
ZeroMQ.hs
src/IHaskell/ZeroMQ.hs
+0
-0
Main.hs
src/Main.hs
+1
-5
No files found.
.ghci
View file @
3c68a6af
: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
IHaskell.cabal
View file @
3c68a6af
...
...
@@ -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
...
...
IHaskell/Config.hs
deleted
100644 → 0
View file @
291363a9
{-# 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
|]
)]
README.md
View file @
3c68a6af
...
...
@@ -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
```
profile/ipython_config.py
View file @
3c68a6af
...
...
@@ -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"
profile/profile.tar
View file @
3c68a6af
No preview for this file type
profile/static/custom/conceal/conceal.js
View file @
3c68a6af
...
...
@@ -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) {
...
...
profile/static/custom/custom.css
View file @
3c68a6af
/*
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
);
...
...
profile/static/custom/custom.js
View file @
3c68a6af
...
...
@@ -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
()
{
...
...
Hspec.hs
→
src/
Hspec.hs
View file @
3c68a6af
{-# 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
HelpForSe
t
"x"
Directive
SetOp
t
"x"
]
it
"parses :extension x"
$
...
...
IHaskell/Display.hs
→
src/
IHaskell/Display.hs
View file @
3c68a6af
{-# 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
...
...
IHaskell/Eval/Completion.hs
→
src/
IHaskell/Eval/Completion.hs
View file @
3c68a6af
{-# 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
...
...
IHaskell/Eval/Evaluate.hs
→
src/
IHaskell/Eval/Evaluate.hs
View file @
3c68a6af
{-# 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
=
s
tate
evalStatus
=
if
isJust
newState
then
Success
else
Failure
,
evalResult
=
out
,
evalState
=
fromMaybe
state
newS
tate
}
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
=
"
\n
Use -v to see a list of the files searched for."
useDashV
=
"
\n
Use -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
]
IHaskell/Eval/Info.hs
→
src/
IHaskell/Eval/Info.hs
View file @
3c68a6af
File moved
IHaskell/Eval/Lint.hs
→
src/
IHaskell/Eval/Lint.hs
View file @
3c68a6af
{-# 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
...
...
IHaskell/Eval/Parser.hs
→
src/
IHaskell/Eval/Parser.hs
View file @
3c68a6af
...
...
@@ -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"
)
]
...
...
IHaskell/IPython.hs
→
src/
IHaskell/IPython.hs
View file @
3c68a6af
...
...
@@ -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.
...
...
IHaskell/Message/Parser.hs
→
src/
IHaskell/Message/Parser.hs
View file @
3c68a6af
File moved
IHaskell/Message/UUID.hs
→
src/
IHaskell/Message/UUID.hs
View file @
3c68a6af
File moved
IHaskell/Message/Writer.hs
→
src/
IHaskell/Message/Writer.hs
View file @
3c68a6af
{-# 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
[
...
...
IHaskell/Types.hs
→
src/
IHaskell/Types.hs
View file @
3c68a6af
...
...
@@ -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"
...
...
IHaskell/ZeroMQ.hs
→
src/
IHaskell/ZeroMQ.hs
View file @
3c68a6af
File moved
Main.hs
→
src/
Main.hs
View file @
3c68a6af
...
...
@@ -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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment