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
7ba7c4d1
Commit
7ba7c4d1
authored
Mar 21, 2015
by
Andrew Gibiansky
Browse files
Options
Browse Files
Download
Plain Diff
Merge pull request #444 from gibiansky/enforce-proper-formatting
Enforce proper formatting
parents
be10d383
dadd074f
Changes
21
Hide whitespace changes
Inline
Side-by-side
Showing
21 changed files
with
1985 additions
and
1901 deletions
+1985
-1901
.gitignore
.gitignore
+3
-0
.travis.yml
.travis.yml
+7
-1
BrokenPackages.hs
src/IHaskell/BrokenPackages.hs
+17
-19
Convert.hs
src/IHaskell/Convert.hs
+21
-19
Args.hs
src/IHaskell/Convert/Args.hs
+67
-73
IpynbToLhs.hs
src/IHaskell/Convert/IpynbToLhs.hs
+29
-27
LhsToIpynb.hs
src/IHaskell/Convert/LhsToIpynb.hs
+67
-65
Display.hs
src/IHaskell/Display.hs
+75
-71
Completion.hs
src/IHaskell/Eval/Completion.hs
+190
-194
Evaluate.hs
src/IHaskell/Eval/Evaluate.hs
+652
-629
Hoogle.hs
src/IHaskell/Eval/Hoogle.hs
+114
-128
Info.hs
src/IHaskell/Eval/Info.hs
+10
-12
Lint.hs
src/IHaskell/Eval/Lint.hs
+104
-114
ParseShell.hs
src/IHaskell/Eval/ParseShell.hs
+23
-22
Parser.hs
src/IHaskell/Eval/Parser.hs
+127
-121
Util.hs
src/IHaskell/Eval/Util.hs
+172
-179
Flags.hs
src/IHaskell/Flags.hs
+20
-19
IPython.hs
src/IHaskell/IPython.hs
+31
-29
Types.hs
src/IHaskell/Types.hs
+97
-92
Main.hs
src/Main.hs
+85
-87
verify_formatting.py
verify_formatting.py
+74
-0
No files found.
.gitignore
View file @
7ba7c4d1
...
@@ -16,3 +16,6 @@ todo
...
@@ -16,3 +16,6 @@ todo
profile/profile.tar
profile/profile.tar
.cabal-sandbox
.cabal-sandbox
cabal.sandbox.config
cabal.sandbox.config
.tmp1
.tmp2
.tmp3
.travis.yml
View file @
7ba7c4d1
...
@@ -14,6 +14,7 @@ before_install:
...
@@ -14,6 +14,7 @@ before_install:
-
travis_retry sudo apt-get update
-
travis_retry sudo apt-get update
-
travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
# see note about happy/alex
-
travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
# see note about happy/alex
-
travis_retry sudo apt-get install libmagic-dev
-
travis_retry sudo apt-get install libmagic-dev
-
travis_retry sudo apt-get install python3
-
travis_retry git clone http://www.github.com/zeromq/zeromq4-x.git libzmq
-
travis_retry git clone http://www.github.com/zeromq/zeromq4-x.git libzmq
-
export OLDPWD=$(pwd) && cd libzmq && travis_retry ./autogen.sh && travis_retry ./configure && make && travis_retry sudo make install && travis_retry sudo ldconfig && cd $OLDPWD
-
export OLDPWD=$(pwd) && cd libzmq && travis_retry ./autogen.sh && travis_retry ./configure && make && travis_retry sudo make install && travis_retry sudo ldconfig && cd $OLDPWD
-
export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH
-
export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH
...
@@ -34,6 +35,8 @@ install:
...
@@ -34,6 +35,8 @@ install:
-
|
-
|
if [ ${GHCVER%.*} = "7.8" ]; then
if [ ${GHCVER%.*} = "7.8" ]; then
travis_retry cabal install arithmoi==0.4.* -fllvm
travis_retry cabal install arithmoi==0.4.* -fllvm
travis_retry git clone http://www.github.com/gibiansky/hindent
cd hindent && cabal install && cd ..
fi
fi
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
...
@@ -47,7 +50,10 @@ script:
...
@@ -47,7 +50,10 @@ script:
# Build and run the test suite
# Build and run the test suite
-
travis_retry cabal configure --enable-tests
-
travis_retry cabal configure --enable-tests
-
travis_retry cabal test --show-details=always
-
travis_retry cabal test --show-details=always
-
|
if [ ${GHCVER%.*} = "7.8" ]; then
./verify_formatting.py
fi
-
cabal sdist
-
cabal sdist
# The following scriptlet checks that the resulting source distribution can be built & installed
# The following scriptlet checks that the resulting source distribution can be built & installed
...
...
src/IHaskell/BrokenPackages.hs
View file @
7ba7c4d1
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module
IHaskell.BrokenPackages
(
getBrokenPackages
)
where
module
IHaskell.BrokenPackages
(
getBrokenPackages
)
where
import
ClassyPrelude
hiding
((
<|>
))
import
ClassyPrelude
hiding
((
<|>
))
import
Text.Parsec
import
Text.Parsec
import
Text.Parsec.String
import
Text.Parsec.String
import
Control.Applicative
hiding
((
<|>
),
many
)
import
Control.Applicative
hiding
((
<|>
),
many
)
import
Data.String.Utils
(
startswith
)
import
Data.String.Utils
(
startswith
)
import
Shelly
import
Shelly
data
BrokenPackage
=
BrokenPackage
{
data
BrokenPackage
=
BrokenPackage
{
packageID
::
String
,
brokenDeps
::
[
String
]
}
packageID
::
String
,
brokenDeps
::
[
String
]
}
instance
Show
BrokenPackage
where
instance
Show
BrokenPackage
where
show
=
packageID
show
=
packageID
-- | Get a list of broken packages.
-- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- This function internally shells out to `ghc-pkg`, and parses the output
-- output in order to determine what packages are broken.
-- in order to determine what packages are broken.
getBrokenPackages
::
IO
[
String
]
getBrokenPackages
::
IO
[
String
]
getBrokenPackages
=
shelly
$
do
getBrokenPackages
=
shelly
$
do
silently
$
errExit
False
$
run
"ghc-pkg"
[
"check"
]
silently
$
errExit
False
$
run
"ghc-pkg"
[
"check"
]
checkOut
<-
lastStderr
checkOut
<-
lastStderr
-- Get rid of extraneous things
-- Get rid of extraneous things
let
rightStart
str
=
startswith
"There are problems"
str
||
let
rightStart
str
=
startswith
"There are problems"
str
||
startswith
" dependency"
str
startswith
" dependency"
str
ghcPkgOutput
=
unlines
.
filter
rightStart
.
lines
$
unpack
checkOut
ghcPkgOutput
=
unlines
.
filter
rightStart
.
lines
$
unpack
checkOut
return
$
case
parse
(
many
check
)
"ghc-pkg output"
ghcPkgOutput
of
return
$
Left
err
->
[]
case
parse
(
many
check
)
"ghc-pkg output"
ghcPkgOutput
of
Right
pkgs
->
map
show
pkgs
Left
err
->
[]
Right
pkgs
->
map
show
pkgs
check
::
Parser
BrokenPackage
check
::
Parser
BrokenPackage
check
=
string
"There are problems in package "
check
=
string
"There are problems in package "
...
...
src/IHaskell/Convert.hs
View file @
7ba7c4d1
-- | Description : mostly reversible conversion between ipynb and lhs
-- | Description : mostly reversible conversion between ipynb and lhs
module
IHaskell.Convert
(
convert
)
where
module
IHaskell.Convert
(
convert
)
where
import
Control.Monad.Identity
(
Identity
(
Identity
),
unless
,
when
)
import
IHaskell.Convert.Args
(
ConvertSpec
(
ConvertSpec
,
convertInput
,
convertLhsStyle
,
convertOutput
,
convertOverwriteFiles
,
convertToIpynb
),
fromJustConvertSpec
,
toConvertSpec
)
import
Control.Monad.Identity
(
Identity
(
Identity
),
unless
,
when
)
import
IHaskell.Convert.IpynbToLhs
(
ipynbToLhs
)
import
IHaskell.Convert.Args
(
ConvertSpec
(
..
),
fromJustConvertSpec
,
toConvertSpec
)
import
IHaskell.Convert.LhsToIpynb
(
lhsToIpynb
)
import
IHaskell.Convert.IpynbToLhs
(
ipynbToLhs
)
import
IHaskell.Flags
(
Argument
)
import
IHaskell.Convert.LhsToIpynb
(
lhsToIpynb
)
import
System.Directory
(
doesFileExist
)
import
IHaskell.Flags
(
Argument
)
import
Text.Printf
(
printf
)
import
System.Directory
(
doesFileExist
)
import
Text.Printf
(
printf
)
-- | used by @IHaskell convert@
-- | used by @IHaskell convert@
convert
::
[
Argument
]
->
IO
()
convert
::
[
Argument
]
->
IO
()
convert
args
=
case
fromJustConvertSpec
(
toConvertSpec
args
)
of
convert
args
=
ConvertSpec
{
convertToIpynb
=
Identity
toIpynb
,
case
fromJustConvertSpec
(
toConvertSpec
args
)
of
convertInput
=
Identity
inputFile
,
ConvertSpec
convertOutput
=
Identity
outputFile
,
{
convertToIpynb
=
Identity
toIpynb
convertLhsStyle
=
Identity
lhsStyle
,
,
convertInput
=
Identity
inputFile
convertOverwriteFiles
=
force
}
,
convertOutput
=
Identity
outputFile
,
convertLhsStyle
=
Identity
lhsStyle
,
convertOverwriteFiles
=
force
}
|
toIpynb
->
do
|
toIpynb
->
do
unless
force
(
failIfExists
outputFile
)
unless
force
(
failIfExists
outputFile
)
lhsToIpynb
lhsStyle
inputFile
outputFile
lhsToIpynb
lhsStyle
inputFile
outputFile
|
otherwise
->
do
|
otherwise
->
do
unless
force
(
failIfExists
outputFile
)
unless
force
(
failIfExists
outputFile
)
ipynbToLhs
lhsStyle
inputFile
outputFile
ipynbToLhs
lhsStyle
inputFile
outputFile
-- | Call fail when the named file already exists.
-- | Call fail when the named file already exists.
failIfExists
::
FilePath
->
IO
()
failIfExists
::
FilePath
->
IO
()
...
@@ -29,5 +33,3 @@ failIfExists file = do
...
@@ -29,5 +33,3 @@ failIfExists file = do
exists
<-
doesFileExist
file
exists
<-
doesFileExist
file
when
exists
$
fail
$
when
exists
$
fail
$
printf
"File %s already exists. To force supply --force."
file
printf
"File %s already exists. To force supply --force."
file
src/IHaskell/Convert/Args.hs
View file @
7ba7c4d1
-- | Description: interpret flags parsed by "IHaskell.Flags"
-- | Description: interpret flags parsed by "IHaskell.Flags"
module
IHaskell.Convert.Args
module
IHaskell.Convert.Args
(
ConvertSpec
(
..
),
fromJustConvertSpec
,
toConvertSpec
)
where
(
ConvertSpec
(
..
),
fromJustConvertSpec
,
toConvertSpec
,
)
where
import
Control.Applicative
((
<$>
))
import
Control.Applicative
((
<$>
))
import
Control.Monad.Identity
(
Identity
(
Identity
))
import
Control.Monad.Identity
(
Identity
(
Identity
))
import
Data.Char
(
toLower
)
import
Data.Char
(
toLower
)
import
Data.List
(
partition
)
import
Data.List
(
partition
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Maybe
(
fromMaybe
)
import
qualified
Data.Text.Lazy
as
T
(
pack
,
Text
)
import
qualified
Data.Text.Lazy
as
T
(
pack
,
Text
)
import
IHaskell.Flags
(
Argument
(
..
),
LhsStyle
,
lhsStyleBird
,
NotebookFormat
(
..
))
import
IHaskell.Flags
(
Argument
(
..
),
LhsStyle
,
lhsStyleBird
,
NotebookFormat
(
..
))
import
System.FilePath
((
<.>
),
dropExtension
,
takeExtension
)
import
System.FilePath
((
<.>
),
dropExtension
,
takeExtension
)
import
Text.Printf
(
printf
)
import
Text.Printf
(
printf
)
-- | ConvertSpec is the accumulator for command line arguments
-- | ConvertSpec is the accumulator for command line arguments
data
ConvertSpec
f
=
ConvertSpec
data
ConvertSpec
f
=
{
convertToIpynb
::
f
Bool
,
ConvertSpec
convertInput
::
f
FilePath
,
{
convertToIpynb
::
f
Bool
convertOutput
::
f
FilePath
,
,
convertInput
::
f
FilePath
convertLhsStyle
::
f
(
LhsStyle
T
.
Text
),
,
convertOutput
::
f
FilePath
convertOverwriteFiles
::
Bool
,
convertLhsStyle
::
f
(
LhsStyle
T
.
Text
)
}
,
convertOverwriteFiles
::
Bool
}
-- | Convert a possibly-incomplete specification for what to convert
-- | Convert a possibly-incomplete specification for what to convert into one which can be executed.
-- into one which can be executed. Calls error when data is missing.
-- Calls error when data is missing.
fromJustConvertSpec
::
ConvertSpec
Maybe
->
ConvertSpec
Identity
fromJustConvertSpec
::
ConvertSpec
Maybe
->
ConvertSpec
Identity
fromJustConvertSpec
convertSpec
=
convertSpec
{
fromJustConvertSpec
convertSpec
=
convertSpec
convertToIpynb
=
Identity
toIpynb
,
{
convertToIpynb
=
Identity
toIpynb
convertInput
=
Identity
inputFile
,
,
convertInput
=
Identity
inputFile
convertOutput
=
Identity
outputFile
,
,
convertOutput
=
Identity
outputFile
convertLhsStyle
=
Identity
$
fromMaybe
,
convertLhsStyle
=
Identity
$
fromMaybe
(
T
.
pack
<$>
lhsStyleBird
)
(
convertLhsStyle
convertSpec
)
(
T
.
pack
<$>
lhsStyleBird
)
}
(
convertLhsStyle
convertSpec
)
}
where
where
toIpynb
=
fromMaybe
(
error
"Error: direction for conversion unknown"
)
toIpynb
=
fromMaybe
(
error
"Error: direction for conversion unknown"
)
(
convertToIpynb
convertSpec
)
(
convertToIpynb
convertSpec
)
(
inputFile
,
outputFile
)
=
case
(
convertInput
convertSpec
,
convertOutput
convertSpec
)
of
(
inputFile
,
outputFile
)
=
case
(
convertInput
convertSpec
,
convertOutput
convertSpec
)
of
(
Nothing
,
Nothing
)
->
error
"Error: no files specified for conversion"
(
Nothing
,
Nothing
)
->
error
"Error: no files specified for conversion"
(
Just
i
,
Nothing
)
|
toIpynb
->
(
i
,
dropExtension
i
<.>
"ipynb"
)
(
Just
i
,
Nothing
)
|
otherwise
->
(
i
,
dropExtension
i
<.>
"lhs"
)
|
toIpynb
->
(
i
,
dropExtension
i
<.>
"ipynb"
)
(
Nothing
,
Just
o
)
|
toIpynb
->
(
dropExtension
o
<.>
"lhs"
,
o
)
|
otherwise
->
(
i
,
dropExtension
i
<.>
"lhs"
)
|
otherwise
->
(
dropExtension
o
<.>
"ipynb"
,
o
)
(
Nothing
,
Just
o
)
|
toIpynb
->
(
dropExtension
o
<.>
"lhs"
,
o
)
|
otherwise
->
(
dropExtension
o
<.>
"ipynb"
,
o
)
(
Just
i
,
Just
o
)
->
(
i
,
o
)
(
Just
i
,
Just
o
)
->
(
i
,
o
)
-- | Does this @Argument@ explicitly request a file format?
-- | Does this @Argument@ explicitly request a file format?
isFormatSpec
::
Argument
->
Bool
isFormatSpec
::
Argument
->
Bool
isFormatSpec
(
ConvertToFormat
_
)
=
True
isFormatSpec
(
ConvertToFormat
_
)
=
True
isFormatSpec
(
ConvertFromFormat
_
)
=
True
isFormatSpec
(
ConvertFromFormat
_
)
=
True
isFormatSpec
_
=
False
isFormatSpec
_
=
False
toConvertSpec
::
[
Argument
]
->
ConvertSpec
Maybe
toConvertSpec
::
[
Argument
]
->
ConvertSpec
Maybe
toConvertSpec
args
=
mergeArgs
otherArgs
toConvertSpec
args
=
mergeArgs
otherArgs
(
mergeArgs
formatSpecArgs
initialConvertSpec
)
(
mergeArgs
formatSpecArgs
initialConvertSpec
)
where
where
(
formatSpecArgs
,
otherArgs
)
=
partition
isFormatSpec
args
(
formatSpecArgs
,
otherArgs
)
=
partition
isFormatSpec
args
initialConvertSpec
=
ConvertSpec
Nothing
Nothing
Nothing
Nothing
False
initialConvertSpec
=
ConvertSpec
Nothing
Nothing
Nothing
Nothing
False
mergeArgs
::
[
Argument
]
->
ConvertSpec
Maybe
->
ConvertSpec
Maybe
mergeArgs
::
[
Argument
]
->
ConvertSpec
Maybe
->
ConvertSpec
Maybe
mergeArgs
args
initialConvertSpec
=
foldr
mergeArg
initialConvertSpec
args
mergeArgs
args
initialConvertSpec
=
foldr
mergeArg
initialConvertSpec
args
mergeArg
::
Argument
->
ConvertSpec
Maybe
->
ConvertSpec
Maybe
mergeArg
::
Argument
->
ConvertSpec
Maybe
->
ConvertSpec
Maybe
mergeArg
OverwriteFiles
convertSpec
=
convertSpec
{
convertOverwriteFiles
=
True
}
mergeArg
OverwriteFiles
convertSpec
=
convertSpec
{
convertOverwriteFiles
=
True
}
mergeArg
(
ConvertLhsStyle
lhsStyle
)
convertSpec
mergeArg
(
ConvertLhsStyle
lhsStyle
)
convertSpec
|
Just
previousLhsStyle
<-
convertLhsStyle
convertSpec
,
|
Just
previousLhsStyle
<-
convertLhsStyle
convertSpec
,
previousLhsStyle
/=
fmap
T
.
pack
lhsStyle
=
error
$
printf
previousLhsStyle
/=
fmap
T
.
pack
lhsStyle
"Conflicting lhs styles requested: <%s> and <%s>"
=
error
$
printf
"Conflicting lhs styles requested: <%s> and <%s>"
(
show
lhsStyle
)
(
show
lhsStyle
)
(
show
previousLhsStyle
)
(
show
previousLhsStyle
)
|
otherwise
=
convertSpec
{
convertLhsStyle
=
Just
(
T
.
pack
<$>
lhsStyle
)
}
|
otherwise
=
convertSpec
{
convertLhsStyle
=
Just
(
T
.
pack
<$>
lhsStyle
)
}
mergeArg
(
ConvertFrom
inputFile
)
convertSpec
mergeArg
(
ConvertFrom
inputFile
)
convertSpec
|
Just
previousInputFile
<-
convertInput
convertSpec
,
|
Just
previousInputFile
<-
convertInput
convertSpec
,
previousInputFile
/=
inputFile
=
error
$
printf
"Multiple input files specified: <%s> and <%s>"
previousInputFile
/=
inputFile
inputFile
previousInputFile
=
error
$
printf
"Multiple input files specified: <%s> and <%s>"
inputFile
previousInputFile
|
otherwise
=
convertSpec
{
|
otherwise
=
convertSpec
convertInput
=
Just
inputFile
,
{
convertInput
=
Just
inputFile
convertToIpynb
=
case
(
convertToIpynb
convertSpec
,
fromExt
inputFile
)
of
,
convertToIpynb
=
case
(
convertToIpynb
convertSpec
,
fromExt
inputFile
)
of
(
prev
,
Nothing
)
->
prev
(
prev
,
Nothing
)
->
prev
(
prev
@
(
Just
_
),
_
)
->
prev
(
prev
@
(
Just
_
),
_
)
->
prev
(
Nothing
,
format
)
->
fmap
(
==
LhsMarkdown
)
format
(
Nothing
,
format
)
->
fmap
(
==
LhsMarkdown
)
format
}
}
mergeArg
(
ConvertTo
outputFile
)
convertSpec
mergeArg
(
ConvertTo
outputFile
)
convertSpec
|
Just
previousOutputFile
<-
convertOutput
convertSpec
,
|
Just
previousOutputFile
<-
convertOutput
convertSpec
,
previousOutputFile
/=
outputFile
=
error
$
printf
"Multiple output files specified: <%s> and <%s>"
previousOutputFile
/=
outputFile
outputFile
previousOutputFile
=
error
$
printf
"Multiple output files specified: <%s> and <%s>"
outputFile
previousOutputFile
|
otherwise
=
convertSpec
{
|
otherwise
=
convertSpec
convertOutput
=
Just
outputFile
,
{
convertOutput
=
Just
outputFile
convertToIpynb
=
case
(
convertToIpynb
convertSpec
,
fromExt
outputFile
)
of
,
convertToIpynb
=
case
(
convertToIpynb
convertSpec
,
fromExt
outputFile
)
of
(
prev
,
Nothing
)
->
prev
(
prev
,
Nothing
)
->
prev
(
prev
@
(
Just
_
),
_
)
->
prev
(
prev
@
(
Just
_
),
_
)
->
prev
(
Nothing
,
format
)
->
fmap
(
==
IpynbFile
)
format
(
Nothing
,
format
)
->
fmap
(
==
IpynbFile
)
format
}
}
mergeArg
unexpectedArg
_
=
error
$
"IHaskell.Convert.mergeArg: impossible argument: "
mergeArg
unexpectedArg
_
=
error
$
"IHaskell.Convert.mergeArg: impossible argument: "
++
show
unexpectedArg
++
show
unexpectedArg
-- | Guess the format based on the file extension.
-- | Guess the format based on the file extension.
fromExt
::
FilePath
->
Maybe
NotebookFormat
fromExt
::
FilePath
->
Maybe
NotebookFormat
fromExt
s
=
case
map
toLower
(
takeExtension
s
)
of
fromExt
s
=
".lhs"
->
Just
LhsMarkdown
case
map
toLower
(
takeExtension
s
)
of
".ipynb"
->
Just
IpynbFile
".lhs"
->
Just
LhsMarkdown
_
->
Nothing
".ipynb"
->
Just
IpynbFile
_
->
Nothing
src/IHaskell/Convert/IpynbToLhs.hs
View file @
7ba7c4d1
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables #-}
module
IHaskell.Convert.IpynbToLhs
(
ipynbToLhs
)
where
module
IHaskell.Convert.IpynbToLhs
(
ipynbToLhs
)
where
import
Control.Applicative
((
<$>
))
import
Control.Applicative
((
<$>
))
import
Data.Aeson
(
decode
,
Object
,
Value
(
Array
,
Object
,
String
))
import
Data.Aeson
(
decode
,
Object
,
Value
(
Array
,
Object
,
String
))
import
qualified
Data.ByteString.Lazy
as
L
(
readFile
)
import
qualified
Data.ByteString.Lazy
as
L
(
readFile
)
import
qualified
Data.HashMap.Strict
as
M
(
lookup
)
import
qualified
Data.HashMap.Strict
as
M
(
lookup
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Monoid
((
<>
),
Monoid
(
mempty
))
import
Data.Monoid
((
<>
),
Monoid
(
mempty
))
import
qualified
Data.Text.Lazy
as
T
(
concat
,
fromStrict
,
Text
,
unlines
)
import
qualified
Data.Text.Lazy
as
T
(
concat
,
fromStrict
,
Text
,
unlines
)
import
qualified
Data.Text.Lazy.IO
as
T
(
writeFile
)
import
qualified
Data.Text.Lazy.IO
as
T
(
writeFile
)
import
Data.Vector
(
Vector
)
import
Data.Vector
(
Vector
)
import
qualified
Data.Vector
as
V
(
map
,
mapM
,
toList
)
import
qualified
Data.Vector
as
V
(
map
,
mapM
,
toList
)
import
IHaskell.Flags
(
LhsStyle
(
lhsBeginCode
,
lhsBeginOutput
,
lhsCodePrefix
,
lhsEndCode
,
lhsEndOutput
,
lhsOutputPrefix
))
import
IHaskell.Flags
(
LhsStyle
(
..
))
ipynbToLhs
::
LhsStyle
T
.
Text
ipynbToLhs
::
LhsStyle
T
.
Text
->
FilePath
-- ^ the filename of an ipython notebook
->
FilePath
-- ^ the filename of an ipython notebook
->
FilePath
-- ^ the filename of the literate haskell to write
->
FilePath
-- ^ the filename of the literate haskell to write
->
IO
()
->
IO
()
ipynbToLhs
sty
from
to
=
do
ipynbToLhs
sty
from
to
=
do
Just
(
js
::
Object
)
<-
decode
<$>
L
.
readFile
from
Just
(
js
::
Object
)
<-
decode
<$>
L
.
readFile
from
case
M
.
lookup
"cells"
js
of
case
M
.
lookup
"cells"
js
of
Just
(
Array
cells
)
->
Just
(
Array
cells
)
->
T
.
writeFile
to
$
T
.
unlines
$
V
.
toList
T
.
writeFile
to
$
T
.
unlines
$
V
.
toList
$
V
.
map
(
\
(
Object
y
)
->
convCell
sty
y
)
cells
$
V
.
map
(
\
(
Object
y
)
->
convCell
sty
y
)
cells
_
->
error
"IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
_
->
error
"IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix
::
T
.
Text
-- ^ the prefix to add to every line
concatWithPrefix
::
T
.
Text
-- ^ the prefix to add to every line
->
Vector
Value
-- ^ a json array of text lines
->
Vector
Value
-- ^ a json array of text lines
->
Maybe
T
.
Text
->
Maybe
T
.
Text
concatWithPrefix
p
arr
=
T
.
concat
.
map
(
p
<>
)
.
V
.
toList
<$>
V
.
mapM
toStr
arr
concatWithPrefix
p
arr
=
T
.
concat
.
map
(
p
<>
)
.
V
.
toList
<$>
V
.
mapM
toStr
arr
toStr
::
Value
->
Maybe
T
.
Text
toStr
::
Value
->
Maybe
T
.
Text
toStr
(
String
x
)
=
Just
(
T
.
fromStrict
x
)
toStr
(
String
x
)
=
Just
(
T
.
fromStrict
x
)
toStr
_
=
Nothing
toStr
_
=
Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable
-- | @convCell sty cell@ converts a single cell in JSON into text suitable
for the type of lhs file
--
for the type of lhs file
described by the @sty@
-- described by the @sty@
convCell
::
LhsStyle
T
.
Text
->
Object
->
T
.
Text
convCell
::
LhsStyle
T
.
Text
->
Object
->
T
.
Text
convCell
_sty
object
convCell
_sty
object
|
Just
(
String
"markdown"
)
<-
M
.
lookup
"cell_type"
object
,
|
Just
(
String
"markdown"
)
<-
M
.
lookup
"cell_type"
object
,
Just
(
Array
xs
)
<-
M
.
lookup
"source"
object
,
Just
(
Array
xs
)
<-
M
.
lookup
"source"
object
,
~
(
Just
s
)
<-
concatWithPrefix
""
xs
=
s
~
(
Just
s
)
<-
concatWithPrefix
""
xs
=
s
convCell
sty
object
convCell
sty
object
|
Just
(
String
"code"
)
<-
M
.
lookup
"cell_type"
object
,
|
Just
(
String
"code"
)
<-
M
.
lookup
"cell_type"
object
,
Just
(
Array
i
)
<-
M
.
lookup
"source"
object
,
Just
(
Array
i
)
<-
M
.
lookup
"source"
object
,
Just
(
Array
o
)
<-
M
.
lookup
"outputs"
object
,
Just
(
Array
o
)
<-
M
.
lookup
"outputs"
object
,
~
(
Just
i
)
<-
concatWithPrefix
(
lhsCodePrefix
sty
)
i
,
~
(
Just
i
)
<-
concatWithPrefix
(
lhsCodePrefix
sty
)
i
,
o
<-
fromMaybe
mempty
(
convOutputs
sty
o
)
=
"
\n
"
<>
o
<-
fromMaybe
mempty
(
convOutputs
sty
o
)
lhsBeginCode
sty
<>
i
<>
lhsEndCode
sty
<>
"
\n
"
<>
o
<>
"
\n
"
=
"
\n
"
<>
lhsBeginCode
sty
<>
i
<>
lhsEndCode
sty
<>
"
\n
"
<>
o
<>
"
\n
"
convCell
_
_
=
"IHaskell.Convert.convCell: unknown cell"
convCell
_
_
=
"IHaskell.Convert.convCell: unknown cell"
convOutputs
::
LhsStyle
T
.
Text
convOutputs
::
LhsStyle
T
.
Text
->
Vector
Value
-- ^ JSON array of output lines containing text or markup
->
Vector
Value
-- ^ JSON array of output lines containing text or markup
->
Maybe
T
.
Text
->
Maybe
T
.
Text
convOutputs
sty
array
=
do
convOutputs
sty
array
=
do
outputLines
<-
V
.
mapM
(
getTexts
(
lhsOutputPrefix
sty
))
array
outputLines
<-
V
.
mapM
(
getTexts
(
lhsOutputPrefix
sty
))
array
return
$
lhsBeginOutput
sty
<>
T
.
concat
(
V
.
toList
outputLines
)
<>
lhsEndOutput
sty
return
$
lhsBeginOutput
sty
<>
T
.
concat
(
V
.
toList
outputLines
)
<>
lhsEndOutput
sty
getTexts
::
T
.
Text
->
Value
->
Maybe
T
.
Text
getTexts
::
T
.
Text
->
Value
->
Maybe
T
.
Text
getTexts
p
(
Object
object
)
getTexts
p
(
Object
object
)
|
Just
(
Array
text
)
<-
M
.
lookup
"text"
object
=
concatWithPrefix
p
text
|
Just
(
Array
text
)
<-
M
.
lookup
"text"
object
=
concatWithPrefix
p
text
getTexts
_
_
=
Nothing
getTexts
_
_
=
Nothing
src/IHaskell/Convert/LhsToIpynb.hs
View file @
7ba7c4d1
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-}
module
IHaskell.Convert.LhsToIpynb
(
lhsToIpynb
)
where
module
IHaskell.Convert.LhsToIpynb
(
lhsToIpynb
)
where
import
Control.Applicative
((
<$>
))
import
Control.Applicative
((
<$>
))
import
Control.Monad
(
mplus
)
import
Control.Monad
(
mplus
)
import
Data.Aeson
((
.=
),
encode
,
object
,
Value
(
Array
,
Bool
,
Number
,
String
,
Null
))
import
Data.Aeson
((
.=
),
encode
,
object
,
Value
(
Array
,
Bool
,
Number
,
String
,
Null
))
import
qualified
Data.ByteString.Lazy
as
L
(
writeFile
)
import
qualified
Data.ByteString.Lazy
as
L
(
writeFile
)
import
Data.Char
(
isSpace
)
import
Data.Char
(
isSpace
)
import
Data.Monoid
(
Monoid
(
mempty
))
import
Data.Monoid
(
Monoid
(
mempty
))
import
qualified
Data.Text
as
TS
(
Text
)
import
qualified
Data.Text
as
TS
(
Text
)
import
qualified
Data.Text.Lazy
as
T
(
dropWhile
,
lines
,
stripPrefix
,
Text
,
toStrict
,
snoc
,
strip
)
import
qualified
Data.Text.Lazy
as
T
(
dropWhile
,
lines
,
stripPrefix
,
Text
,
toStrict
,
snoc
,
strip
)
import
qualified
Data.Text.Lazy.IO
as
T
(
readFile
)
import
qualified
Data.Text.Lazy.IO
as
T
(
readFile
)
import
qualified
Data.Vector
as
V
(
fromList
,
singleton
)
import
qualified
Data.Vector
as
V
(
fromList
,
singleton
)
import
IHaskell.Flags
(
LhsStyle
(
LhsStyle
))
import
IHaskell.Flags
(
LhsStyle
(
LhsStyle
))
lhsToIpynb
::
LhsStyle
T
.
Text
->
FilePath
->
FilePath
->
IO
()
lhsToIpynb
::
LhsStyle
T
.
Text
->
FilePath
->
FilePath
->
IO
()
lhsToIpynb
sty
from
to
=
do
lhsToIpynb
sty
from
to
=
do
classed
<-
classifyLines
sty
.
T
.
lines
<$>
T
.
readFile
from
classed
<-
classifyLines
sty
.
T
.
lines
<$>
T
.
readFile
from
L
.
writeFile
to
.
encode
.
encodeCells
$
groupClassified
classed
L
.
writeFile
to
.
encode
.
encodeCells
$
groupClassified
classed
data
CellLine
a
=
CodeLine
a
|
OutputLine
a
|
MarkdownLine
a
data
CellLine
a
=
CodeLine
a
deriving
Show
|
OutputLine
a
|
MarkdownLine
a
deriving
Show
isCode
::
CellLine
t
->
Bool
isCode
::
CellLine
t
->
Bool
isCode
(
CodeLine
_
)
=
True
isCode
(
CodeLine
_
)
=
True
isCode
_
=
False
isCode
_
=
False
isOutput
::
CellLine
t
->
Bool
isOutput
::
CellLine
t
->
Bool
isOutput
(
OutputLine
_
)
=
True
isOutput
(
OutputLine
_
)
=
True
isOutput
_
=
False
isOutput
_
=
False
isMD
::
CellLine
t
->
Bool
isMD
::
CellLine
t
->
Bool
isMD
(
MarkdownLine
_
)
=
True
isMD
(
MarkdownLine
_
)
=
True
isMD
_
=
False
isMD
_
=
False
isEmptyMD
::
(
Eq
a
,
Monoid
a
)
=>
CellLine
a
->
Bool
isEmptyMD
::
(
Eq
a
,
Monoid
a
)
=>
CellLine
a
->
Bool
isEmptyMD
(
MarkdownLine
a
)
=
a
==
mempty
isEmptyMD
(
MarkdownLine
a
)
=
a
==
mempty
isEmptyMD
_
=
False
isEmptyMD
_
=
False
untag
::
CellLine
t
->
t
untag
::
CellLine
t
->
t
untag
(
CodeLine
a
)
=
a
untag
(
CodeLine
a
)
=
a
untag
(
OutputLine
a
)
=
a
untag
(
OutputLine
a
)
=
a
untag
(
MarkdownLine
a
)
=
a
untag
(
MarkdownLine
a
)
=
a
data
Cell
a
=
Code
a
a
|
Markdown
a
data
Cell
a
=
Code
a
a
deriving
(
Show
)
|
Markdown
a
deriving
Show
encodeCells
::
[
Cell
[
T
.
Text
]]
->
Value
encodeCells
::
[
Cell
[
T
.
Text
]]
->
Value
encodeCells
xs
=
object
$
encodeCells
xs
=
object
$
[
"cells"
.=
Array
(
V
.
fromList
(
map
cellToVal
xs
))
]
[
"cells"
.=
Array
(
V
.
fromList
(
map
cellToVal
xs
))
]
++
boilerplate
++
boilerplate
cellToVal
::
Cell
[
T
.
Text
]
->
Value
cellToVal
::
Cell
[
T
.
Text
]
->
Value
cellToVal
(
Code
i
o
)
=
object
$
cellToVal
(
Code
i
o
)
=
object
$
[
"cell_type"
.=
String
"code"
,
[
"cell_type"
.=
String
"code"
"execution_count"
.=
Null
,
,
"execution_count"
.=
Null
"metadata"
.=
object
[
"collapsed"
.=
Bool
False
],
,
"metadata"
.=
object
[
"collapsed"
.=
Bool
False
]
"source"
.=
arrayFromTxt
i
,
,
"source"
.=
arrayFromTxt
i
"outputs"
.=
Array
,
"outputs"
.=
Array
(
V
.
fromList
(
(
V
.
fromList
[
object
[
"text"
.=
arrayFromTxt
o
,
([
object
"metadata"
.=
object
[]
,
[
"text"
.=
arrayFromTxt
o
"output_type"
.=
String
"display_data"
]
,
"metadata"
.=
object
[]
|
_
<-
take
1
o
]))
]
,
"output_type"
.=
String
"display_data"
]
|
_
<-
take
1
o
]))
]
cellToVal
(
Markdown
txt
)
=
object
$
cellToVal
(
Markdown
txt
)
=
object
$
[
"cell_type"
.=
String
"markdown"
,
[
"cell_type"
.=
String
"markdown"
"metadata"
.=
object
[
"hidden"
.=
Bool
False
],
,
"metadata"
.=
object
[
"hidden"
.=
Bool
False
]
"source"
.=
arrayFromTxt
txt
]
,
"source"
.=
arrayFromTxt
txt
]
-- | arrayFromTxt makes a JSON array of string s
-- | arrayFromTxt makes a JSON array of string s
arrayFromTxt
::
[
T
.
Text
]
->
Value
arrayFromTxt
::
[
T
.
Text
]
->
Value
arrayFromTxt
i
=
Array
(
V
.
fromList
$
map
stringify
i
)
arrayFromTxt
i
=
Array
(
V
.
fromList
$
map
stringify
i
)
where
where
stringify
=
String
.
T
.
toStrict
.
flip
T
.
snoc
'
\n
'
stringify
=
String
.
T
.
toStrict
.
flip
T
.
snoc
'
\n
'
-- | ihaskell needs this boilerplate at the upper level to interpret the
-- | ihaskell needs this boilerplate at the upper level to interpret the
json describing cells and
--
json describing cells and
output correctly.
-- output correctly.
boilerplate
::
[(
TS
.
Text
,
Value
)]
boilerplate
::
[(
TS
.
Text
,
Value
)]
boilerplate
=
boilerplate
=
[
"metadata"
.=
object
[
kernelspec
,
lang
]
[
"metadata"
.=
object
[
kernelspec
,
lang
],
"nbformat"
.=
Number
4
,
"nbformat_minor"
.=
Number
0
]
,
"nbformat"
.=
Number
4
,
"nbformat_minor"
.=
Number
0
]
where
where
kernelspec
=
"kernelspec"
.=
object
[
kernelspec
=
"kernelspec"
.=
object
"display_name"
.=
String
"Haskell"
[
"display_name"
.=
String
"Haskell"
,
"language"
.=
String
"haskell"
,
"language"
.=
String
"haskell"
,
"name"
.=
String
"haskell"
,
"name"
.=
String
"haskell"
]
]
lang
=
"language_info"
.=
object
[
lang
=
"language_info"
.=
object
[
"name"
.=
String
"haskell"
,
"version"
.=
String
VERSION_ghc
]
"name"
.=
String
"haskell"
,
"version"
.=
String
VERSION_ghc
]
groupClassified
::
[
CellLine
T
.
Text
]
->
[
Cell
[
T
.
Text
]]
groupClassified
::
[
CellLine
T
.
Text
]
->
[
Cell
[
T
.
Text
]]
groupClassified
(
CodeLine
a
:
x
)
groupClassified
(
CodeLine
a
:
x
)
|
(
c
,
x
)
<-
span
isCode
x
,
|
(
c
,
x
)
<-
span
isCode
x
,
(
_
,
x
)
<-
span
isEmptyMD
x
,
(
_
,
x
)
<-
span
isEmptyMD
x
,
(
o
,
x
)
<-
span
isOutput
x
=
Code
(
a
:
map
untag
c
)
(
map
untag
o
)
:
groupClassified
x
(
o
,
x
)
<-
span
isOutput
x
groupClassified
(
MarkdownLine
a
:
x
)
=
Code
(
a
:
map
untag
c
)
(
map
untag
o
)
:
groupClassified
x
|
(
m
,
x
)
<-
span
isMD
x
=
Markdown
(
a
:
map
untag
m
)
:
groupClassified
x
groupClassified
(
MarkdownLine
a
:
x
)
groupClassified
(
OutputLine
a
:
x
)
=
Markdown
[
a
]
:
groupClassified
x
|
(
m
,
x
)
<-
span
isMD
x
=
Markdown
(
a
:
map
untag
m
)
:
groupClassified
x
groupClassified
(
OutputLine
a
:
x
)
=
Markdown
[
a
]
:
groupClassified
x
groupClassified
[]
=
[]
groupClassified
[]
=
[]
classifyLines
::
LhsStyle
T
.
Text
->
[
T
.
Text
]
->
[
CellLine
T
.
Text
]
classifyLines
::
LhsStyle
T
.
Text
->
[
T
.
Text
]
->
[
CellLine
T
.
Text
]
classifyLines
sty
@
(
LhsStyle
c
o
_
_
_
_
)
(
l
:
ls
)
=
case
(
sp
c
,
sp
o
)
of
classifyLines
sty
@
(
LhsStyle
c
o
_
_
_
_
)
(
l
:
ls
)
=
(
Just
a
,
Nothing
)
->
CodeLine
a
:
classifyLines
sty
ls
case
(
sp
c
,
sp
o
)
of
(
Nothing
,
Just
a
)
->
OutputLine
a
:
classifyLines
sty
ls
(
Just
a
,
Nothing
)
->
CodeLine
a
:
classifyLines
sty
ls
(
Nothing
,
Nothing
)
->
MarkdownLine
l
:
classifyLines
sty
ls
(
Nothing
,
Just
a
)
->
OutputLine
a
:
classifyLines
sty
ls
_
->
error
"IHaskell.Convert.classifyLines"
(
Nothing
,
Nothing
)
->
MarkdownLine
l
:
classifyLines
sty
ls
_
->
error
"IHaskell.Convert.classifyLines"
where
where
sp
x
=
T
.
stripPrefix
(
dropSpace
x
)
(
dropSpace
l
)
`
mplus
`
blankCodeLine
x
sp
x
=
T
.
stripPrefix
(
dropSpace
x
)
(
dropSpace
l
)
`
mplus
`
blankCodeLine
x
blankCodeLine
x
=
if
T
.
strip
x
==
T
.
strip
l
then
Just
""
else
Nothing
blankCodeLine
x
=
if
T
.
strip
x
==
T
.
strip
l
then
Just
""
else
Nothing
dropSpace
=
T
.
dropWhile
isSpace
dropSpace
=
T
.
dropWhile
isSpace
classifyLines
_
[]
=
[]
classifyLines
_
[]
=
[]
src/IHaskell/Display.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
-- | If you are interested in the IHaskell library for the purpose of
-- | If you are interested in the IHaskell library for the purpose of
augmenting the IHaskell
--
augmenting the IHaskell notebook or writing your own display mechanism
s
--
notebook or writing your own display mechanisms and widgets, this module contains all function
s
--
and widgets, this module contains all functions you need.
--
you need.
--
--
-- In order to create a display mechanism for a particular data type, write
-- In order to create a display mechanism for a particular data type, write a module named (for
-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@.
-- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the
-- (Note the capitalization - it's important!) Then, in that module, add an
-- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for
-- instance of @IHaskellDisplay@ for your data type. Similarly, to create
-- your data type. Similarly, to create a widget, add an instance of @IHaskellWidget@.
-- a widget, add an instance of @IHaskellWidget@.
--
--
-- An example of creating a display is provided in the <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.
-- An example of creating a display is provided in the
-- <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.
--
--
module
IHaskell.Display
(
module
IHaskell.Display
(
-- * Rich display and interactive display typeclasses and types
-- * Rich display and interactive display typeclasses and types
IHaskellDisplay
(
..
),
IHaskellDisplay
(
..
),
Display
(
..
),
Display
(
..
),
DisplayData
(
..
),
DisplayData
(
..
),
IHaskellWidget
(
..
),
IHaskellWidget
(
..
),
-- ** Interactive use functions
-- ** Interactive use functions
printDisplay
,
printDisplay
,
-- * Constructors for displays
-- * Constructors for displays
plain
,
html
,
png
,
jpg
,
svg
,
latex
,
javascript
,
many
,
plain
,
html
,
-- ** Image and data encoding functions
png
,
Width
,
Height
,
Base64
(
..
),
jpg
,
encode64
,
base64
,
svg
,
latex
,
-- ** Utilities
javascript
,
switchToTmpDir
,
many
,
-- * Internal only use
-- ** Image and data encoding functions
displayFromChan
,
Width
,
serializeDisplay
,
Height
,
Widget
(
..
),
Base64
(
..
),
)
where
encode64
,
base64
,
import
ClassyPrelude
import
Data.Serialize
as
Serialize
-- ** Utilities
import
Data.ByteString
hiding
(
map
,
pack
)
switchToTmpDir
,
import
Data.String.Utils
(
rstrip
)
-- * Internal only use
displayFromChan
,
serializeDisplay
,
Widget
(
..
),
)
where
import
ClassyPrelude
import
Data.Serialize
as
Serialize
import
Data.ByteString
hiding
(
map
,
pack
)
import
Data.String.Utils
(
rstrip
)
import
qualified
Data.ByteString.Base64
as
Base64
import
qualified
Data.ByteString.Base64
as
Base64
import
qualified
Data.ByteString.Char8
as
Char
import
qualified
Data.ByteString.Char8
as
Char
import
Data.Aeson
(
Value
)
import
Data.Aeson
(
Value
)
import
System.Directory
(
getTemporaryDirectory
,
setCurrentDirectory
)
import
System.Directory
(
getTemporaryDirectory
,
setCurrentDirectory
)
import
Control.Concurrent.STM.TChan
import
Control.Concurrent.STM.TChan
import
System.IO.Unsafe
(
unsafePerformIO
)
import
System.IO.Unsafe
(
unsafePerformIO
)
import
IHaskell.Types
import
IHaskell.Types
type
Base64
=
Text
type
Base64
=
Text
...
@@ -61,8 +71,7 @@ type Base64 = Text
...
@@ -61,8 +71,7 @@ type Base64 = Text
-- > IO [Display]
-- > IO [Display]
-- > IO (IO Display)
-- > IO (IO Display)
--
--
-- be run the IO and get rendered (if the frontend allows it) in the pretty
-- be run the IO and get rendered (if the frontend allows it) in the pretty form.
-- form.
instance
IHaskellDisplay
a
=>
IHaskellDisplay
(
IO
a
)
where
instance
IHaskellDisplay
a
=>
IHaskellDisplay
(
IO
a
)
where
display
=
(
display
=<<
)
display
=
(
display
=<<
)
...
@@ -101,15 +110,15 @@ latex = DisplayData MimeLatex . pack
...
@@ -101,15 +110,15 @@ latex = DisplayData MimeLatex . pack
javascript
::
String
->
DisplayData
javascript
::
String
->
DisplayData
javascript
=
DisplayData
MimeJavascript
.
pack
javascript
=
DisplayData
MimeJavascript
.
pack
-- | Generate a PNG display of the given width and height. Data must be
-- | Generate a PNG display of the given width and height. Data must be
provided in a Base64 encoded
--
provided in a Base64 encoded manner, suitable for embedding into HTML.
--
manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
--
The @base64@ function may be used to encode data into
this format.
-- this format.
png
::
Width
->
Height
->
Base64
->
DisplayData
png
::
Width
->
Height
->
Base64
->
DisplayData
png
width
height
=
DisplayData
(
MimePng
width
height
)
png
width
height
=
DisplayData
(
MimePng
width
height
)
-- | Generate a JPG display of the given width and height. Data must be
-- | Generate a JPG display of the given width and height. Data must be
provided in a Base64 encoded
--
provided in a Base64 encoded manner, suitable for embedding into HTML.
--
manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
--
The @base64@ function may be used to encode data into
this format.
-- this format.
jpg
::
Width
->
Height
->
Base64
->
DisplayData
jpg
::
Width
->
Height
->
Base64
->
DisplayData
jpg
width
height
=
DisplayData
(
MimeJpg
width
height
)
jpg
width
height
=
DisplayData
(
MimeJpg
width
height
)
...
@@ -121,42 +130,37 @@ encode64 str = base64 $ Char.pack str
...
@@ -121,42 +130,37 @@ encode64 str = base64 $ Char.pack str
base64
::
ByteString
->
Base64
base64
::
ByteString
->
Base64
base64
=
decodeUtf8
.
Base64
.
encode
base64
=
decodeUtf8
.
Base64
.
encode
-- | For internal use within IHaskell.
-- | For internal use within IHaskell. Serialize displays to a ByteString.
-- Serialize displays to a ByteString.
serializeDisplay
::
Display
->
ByteString
serializeDisplay
::
Display
->
ByteString
serializeDisplay
=
Serialize
.
encode
serializeDisplay
=
Serialize
.
encode
-- | Items written to this chan will be included in the output sent
-- | Items written to this chan will be included in the output sent to the frontend (ultimately the
-- to the frontend (ultimately the browser), the next time IHaskell
-- browser), the next time IHaskell has an item to display.
-- has an item to display.
{-# NOINLINE displayChan #-}
{-# NOINLINE displayChan #-}
displayChan
::
TChan
Display
displayChan
::
TChan
Display
displayChan
=
unsafePerformIO
newTChanIO
displayChan
=
unsafePerformIO
newTChanIO
-- | Take everything that was put into the 'displayChan' at that point
-- | Take everything that was put into the 'displayChan' at that point
out, and make a 'Display' out
-- o
ut, and make a 'Display' out o
f it.
-- of it.
displayFromChan
::
IO
(
Maybe
Display
)
displayFromChan
::
IO
(
Maybe
Display
)
displayFromChan
=
displayFromChan
=
Just
.
many
<$>
unfoldM
(
atomically
$
tryReadTChan
displayChan
)
Just
.
many
<$>
unfoldM
(
atomically
$
tryReadTChan
displayChan
)
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- until it return Nothing, and puts all the Justs in a list.
-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- If you find yourself using more functionality from monad-loops, just add
-- just add the package dependency instead of copying more code from it.
-- the package dependency instead of copying more code from it.
unfoldM
::
IO
(
Maybe
a
)
->
IO
[
a
]
unfoldM
::
IO
(
Maybe
a
)
->
IO
[
a
]
unfoldM
f
=
maybe
(
return
[]
)
(
\
r
->
(
r
:
)
<$>
unfoldM
f
)
=<<
f
unfoldM
f
=
maybe
(
return
[]
)
(
\
r
->
(
r
:
)
<$>
unfoldM
f
)
=<<
f
-- | Write to the display channel. The contents will be displayed in the
-- | Write to the display channel. The contents will be displayed in the
notebook once the current
--
notebook once the current
execution call ends.
-- execution call ends.
printDisplay
::
IHaskellDisplay
a
=>
a
->
IO
()
printDisplay
::
IHaskellDisplay
a
=>
a
->
IO
()
printDisplay
disp
=
display
disp
>>=
atomically
.
writeTChan
displayChan
printDisplay
disp
=
display
disp
>>=
atomically
.
writeTChan
displayChan
-- | Convenience function for client libraries. Switch to a temporary
-- | Convenience function for client libraries. Switch to a temporary directory so that any files we
-- directory so that any files we create aren't visible. On Unix, this is
-- create aren't visible. On Unix, this is usually /tmp.
-- usually /tmp.
switchToTmpDir
=
void
(
try
switchDir
::
IO
(
Either
SomeException
()
))
switchToTmpDir
=
void
(
try
switchDir
::
IO
(
Either
SomeException
()
))
where
where
switchDir
=
switchDir
=
getTemporaryDirectory
>>=
getTemporaryDirectory
>>=
setCurrentDirectory
setCurrentDirectory
src/IHaskell/Eval/Completion.hs
View file @
7ba7c4d1
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{- |
{- |
Description: Generates tab completion options.
Description: Generates tab completion options.
...
@@ -12,64 +13,66 @@ This has a limited amount of context sensitivity. It distinguishes between four
...
@@ -12,64 +13,66 @@ This has a limited amount of context sensitivity. It distinguishes between four
-}
-}
module
IHaskell.Eval.Completion
(
complete
,
completionTarget
,
completionType
,
CompletionType
(
..
))
where
module
IHaskell.Eval.Completion
(
complete
,
completionTarget
,
completionType
,
CompletionType
(
..
))
where
import
ClassyPrelude
hiding
(
init
,
last
,
head
,
liftIO
)
import
ClassyPrelude
hiding
(
init
,
last
,
head
,
liftIO
)
--import Prelude
import
Control.Applicative
((
<$>
))
import
Control.Applicative
((
<$>
))
import
Data.ByteString.UTF8
hiding
(
drop
,
take
,
lines
,
length
)
import
Data.ByteString.UTF8
hiding
(
drop
,
take
,
lines
,
length
)
import
Data.Char
import
Data.Char
import
Data.List
(
nub
,
init
,
last
,
head
,
elemIndex
)
import
Data.List
(
nub
,
init
,
last
,
head
,
elemIndex
)
import
Data.List.Split
import
Data.List.Split
import
Data.List.Split.Internals
import
Data.List.Split.Internals
import
Data.Maybe
(
fromJust
)
import
Data.Maybe
(
fromJust
)
import
Data.String.Utils
(
strip
,
startswith
,
endswith
,
replace
)
import
Data.String.Utils
(
strip
,
startswith
,
endswith
,
replace
)
import
qualified
Data.String.Utils
as
StringUtils
import
qualified
Data.String.Utils
as
StringUtils
import
System.Environment
(
getEnv
)
import
System.Environment
(
getEnv
)
import
GHC
hiding
(
Qualified
)
import
GHC
hiding
(
Qualified
)
#
if
MIN_VERSION_ghc
(
7
,
10
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
10
,
0
)
import
GHC.PackageDb
(
ExposedModule
(
exposedName
))
import
GHC.PackageDb
(
ExposedModule
(
exposedName
))
#
endif
#
endif
import
DynFlags
import
DynFlags
import
GhcMonad
import
GhcMonad
import
PackageConfig
import
PackageConfig
import
Outputable
(
showPpr
)
import
Outputable
(
showPpr
)
import
System.Directory
import
System.Directory
import
System.FilePath
import
System.FilePath
import
MonadUtils
(
MonadIO
)
import
MonadUtils
(
MonadIO
)
import
System.Console.Haskeline.Completion
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
)
import
IHaskell.Eval.ParseShell
(
parseShell
)
data
CompletionType
=
Empty
data
CompletionType
|
Identifier
String
=
Empty
|
DynFlag
String
|
Identifier
String
|
Qualified
String
String
|
DynFlag
String
|
ModuleName
String
String
|
Qualified
String
String
|
HsFilePath
String
String
|
ModuleName
String
String
|
FilePath
String
String
|
HsFilePath
String
String
|
KernelOption
String
|
FilePath
String
String
|
Extension
String
|
KernelOption
String
deriving
(
Show
,
Eq
)
|
Extension
String
#
if
MIN_VERSION_ghc
(
7
,
10
,
0
)
deriving
(
Show
,
Eq
)
extName
(
FlagSpec
{
flagSpecName
=
name
})
=
name
#
else
extName
(
name
,
_
,
_
)
=
name
exposedName
=
id
#
endif
complete
::
String
->
Int
->
Interpreter
(
String
,
[
String
])
complete
::
String
->
Int
->
Interpreter
(
String
,
[
String
])
complete
code
posOffset
=
do
complete
code
posOffset
=
do
-- Get the line of code which is being completed and offset within that line
-- Get the line of code which is being completed and offset within that line
let
findLine
offset
(
first
:
rest
)
=
let
findLine
offset
(
first
:
rest
)
=
if
offset
<=
length
first
if
offset
<=
length
first
then
(
offset
,
first
)
then
(
offset
,
first
)
else
findLine
(
offset
-
length
first
-
1
)
rest
else
findLine
(
offset
-
length
first
-
1
)
rest
findLine
_
[]
=
error
$
"Could not find line: "
++
show
(
map
length
$
lines
code
,
posOffset
)
findLine
_
[]
=
error
$
"Could not find line: "
++
show
(
map
length
$
lines
code
,
posOffset
)
(
pos
,
line
)
=
findLine
posOffset
(
lines
code
)
(
pos
,
line
)
=
findLine
posOffset
(
lines
code
)
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
rdrNames
<-
map
(
showPpr
flags
)
<$>
getRdrNamesInScope
rdrNames
<-
map
(
showPpr
flags
)
<$>
getRdrNamesInScope
...
@@ -78,10 +81,6 @@ complete code posOffset = do
...
@@ -78,10 +81,6 @@ complete code posOffset = do
unqualNames
=
nub
$
filter
(
not
.
isQualified
)
rdrNames
unqualNames
=
nub
$
filter
(
not
.
isQualified
)
rdrNames
qualNames
=
nub
$
scopeNames
++
filter
isQualified
rdrNames
qualNames
=
nub
$
scopeNames
++
filter
isQualified
rdrNames
#
if
!
MIN_VERSION_ghc
(
7
,
10
,
0
)
let
exposedName
=
id
#
endif
let
Just
db
=
pkgDatabase
flags
let
Just
db
=
pkgDatabase
flags
getNames
=
map
(
moduleNameString
.
exposedName
)
.
exposedModules
getNames
=
map
(
moduleNameString
.
exposedName
)
.
exposedModules
moduleNames
=
nub
$
concatMap
getNames
db
moduleNames
=
nub
$
concatMap
getNames
db
...
@@ -89,69 +88,63 @@ complete code posOffset = do
...
@@ -89,69 +88,63 @@ complete code posOffset = do
let
target
=
completionTarget
line
pos
let
target
=
completionTarget
line
pos
completion
=
completionType
line
pos
target
completion
=
completionType
line
pos
target
let
matchedText
=
case
completion
of
let
matchedText
=
HsFilePath
_
match
->
match
FilePath
_
match
->
match
otherwise
->
intercalate
"."
target
#
if
MIN_VERSION_ghc
(
7
,
10
,
0
)
let
extName
(
FlagSpec
{
flagSpecName
=
name
})
=
name
#
else
let
extName
(
name
,
_
,
_
)
=
name
#
endif
options
<-
case
completion
of
case
completion
of
Empty
->
return
[]
HsFilePath
_
match
->
match
FilePath
_
match
->
match
otherwise
->
intercalate
"."
target
options
<-
case
completion
of
Empty
->
return
[]
Identifier
candidate
->
Identifier
candidate
->
return
$
filter
(
candidate
`
isPrefixOf
`)
unqualNames
return
$
filter
(
candidate
`
isPrefixOf
`)
unqualNames
Qualified
moduleName
candidate
->
do
Qualified
moduleName
candidate
->
do
trueName
<-
getTrueModuleName
moduleName
trueName
<-
getTrueModuleName
moduleName
let
prefix
=
intercalate
"."
[
trueName
,
candidate
]
let
prefix
=
intercalate
"."
[
trueName
,
candidate
]
completions
=
filter
(
prefix
`
isPrefixOf
`)
qualNames
completions
=
filter
(
prefix
`
isPrefixOf
`)
qualNames
falsifyName
=
replace
trueName
moduleName
falsifyName
=
replace
trueName
moduleName
return
$
map
falsifyName
completions
return
$
map
falsifyName
completions
ModuleName
previous
candidate
->
do
ModuleName
previous
candidate
->
do
let
prefix
=
if
null
previous
let
prefix
=
if
null
previous
then
candidate
then
candidate
else
intercalate
"."
[
previous
,
candidate
]
else
intercalate
"."
[
previous
,
candidate
]
return
$
filter
(
prefix
`
isPrefixOf
`)
moduleNames
return
$
filter
(
prefix
`
isPrefixOf
`)
moduleNames
DynFlag
ext
->
do
DynFlag
ext
->
do
-- Possibly leave out the fLangFlags? The
-- Possibly leave out the fLangFlags? The -XUndecidableInstances vs. obsolete
-- -XUndecidableInstances vs. obsolete
-- -fallow-undecidable-instances.
-- -fallow-undecidable-instances.
let
kernelOptNames
=
concatMap
getSetName
kernelOpts
let
kernelOptNames
=
concatMap
getSetName
kernelOpts
otherNames
=
[
"-package"
,
"-Wall"
,
"-w"
]
otherNames
=
[
"-package"
,
"-Wall"
,
"-w"
]
fNames
=
map
extName
fFlags
++
fNames
=
map
extName
fFlags
++
map
extName
fWarningFlags
++
map
extName
fWarningFlags
++
map
extName
fLangFlags
map
extName
fLangFlags
fNoNames
=
map
(
"no"
++
)
fNames
fNoNames
=
map
(
"no"
++
)
fNames
fAllNames
=
map
(
"-f"
++
)
(
fNames
++
fNoNames
)
fAllNames
=
map
(
"-f"
++
)
(
fNames
++
fNoNames
)
xNames
=
map
extName
xFlags
xNames
=
map
extName
xFlags
xNoNames
=
map
(
"No"
++
)
xNames
xNoNames
=
map
(
"No"
++
)
xNames
xAllNames
=
map
(
"-X"
++
)
(
xNames
++
xNoNames
)
xAllNames
=
map
(
"-X"
++
)
(
xNames
++
xNoNames
)
allNames
=
xAllNames
++
otherNames
++
fAllNames
allNames
=
xAllNames
++
otherNames
++
fAllNames
return
$
filter
(
ext
`
isPrefixOf
`)
allNames
return
$
filter
(
ext
`
isPrefixOf
`)
allNames
Extension
ext
->
do
Extension
ext
->
do
let
xNames
=
map
extName
xFlags
let
xNames
=
map
extName
xFlags
xNoNames
=
map
(
"No"
++
)
xNames
xNoNames
=
map
(
"No"
++
)
xNames
return
$
filter
(
ext
`
isPrefixOf
`)
$
xNames
++
xNoNames
return
$
filter
(
ext
`
isPrefixOf
`)
$
xNames
++
xNoNames
HsFilePath
lineUpToCursor
match
->
completePathWithExtensions
[
".hs"
,
".lhs"
]
lineUpToCursor
HsFilePath
lineUpToCursor
match
->
completePathWithExtensions
[
".hs"
,
".lhs"
]
lineUpToCursor
FilePath
lineUpToCursor
match
->
completePath
lineUpToCursor
FilePath
lineUpToCursor
match
->
completePath
lineUpToCursor
KernelOption
str
->
return
$
KernelOption
str
->
return
$
filter
(
str
`
isPrefixOf
`)
(
concatMap
getOptionName
kernelOpts
)
filter
(
str
`
isPrefixOf
`)
(
concatMap
getOptionName
kernelOpts
)
return
(
matchedText
,
options
)
return
(
matchedText
,
options
)
...
@@ -164,116 +157,118 @@ getTrueModuleName name = do
...
@@ -164,116 +157,118 @@ getTrueModuleName name = do
-- Get all imports that we use.
-- Get all imports that we use.
imports
<-
ClassyPrelude
.
catMaybes
<$>
map
onlyImportDecl
<$>
getContext
imports
<-
ClassyPrelude
.
catMaybes
<$>
map
onlyImportDecl
<$>
getContext
-- Find the ones that have a qualified name attached.
-- Find the ones that have a qualified name attached.
If this name isn't one of them, it already is
--
If this name isn't one of them, it already is
the true name.
-- the true name.
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
let
qualifiedImports
=
filter
(
isJust
.
ideclAs
)
imports
let
qualifiedImports
=
filter
(
isJust
.
ideclAs
)
imports
hasName
imp
=
name
==
(
showPpr
flags
.
fromJust
.
ideclAs
)
imp
hasName
imp
=
name
==
(
showPpr
flags
.
fromJust
.
ideclAs
)
imp
case
find
hasName
qualifiedImports
of
case
find
hasName
qualifiedImports
of
Nothing
->
return
name
Nothing
->
return
name
Just
trueImp
->
return
$
showPpr
flags
$
unLoc
$
ideclName
trueImp
Just
trueImp
->
return
$
showPpr
flags
$
unLoc
$
ideclName
trueImp
-- | Get which type of completion this is from the surrounding context.
-- | Get which type of completion this is from the surrounding context.
completionType
::
String
-- ^ The line on which the completion is being done.
completionType
::
String
-- ^ The line on which the completion is being done.
->
Int
-- ^ Location of the cursor in the line.
->
Int
-- ^ Location of the cursor in the line.
->
[
String
]
-- ^ The identifier being completed (pieces separated by dots).
->
[
String
]
-- ^ The identifier being completed (pieces separated by dots).
->
CompletionType
->
CompletionType
completionType
line
loc
target
completionType
line
loc
target
-- File and directory completions are special
-- File and directory completions are special
|
startswith
":!"
stripped
|
startswith
":!"
stripped
=
=
fileComplete
FilePath
fileComplete
FilePath
|
startswith
":l"
stripped
|
startswith
":l"
stripped
=
=
fileComplete
HsFilePath
fileComplete
HsFilePath
-- Complete :set, :opt, and :ext
-- Complete :set, :opt, and :ext
|
startswith
":s"
stripped
|
startswith
":s"
stripped
=
=
DynFlag
candidate
DynFlag
candidate
|
startswith
":o"
stripped
|
startswith
":o"
stripped
=
=
KernelOption
candidate
KernelOption
candidate
|
startswith
":e"
stripped
|
startswith
":e"
stripped
=
=
Extension
candidate
Extension
candidate
-- 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
Empty
=
Empty
-- When in a string, complete filenames.
-- When in a string, complete filenames.
|
cursorInString
line
loc
|
cursorInString
line
loc
=
=
FilePath
(
getStringTarget
lineUpToCursor
)
(
getStringTarget
lineUpToCursor
)
FilePath
(
getStringTarget
lineUpToCursor
)
(
getStringTarget
lineUpToCursor
)
-- Complete module names in imports and elsewhere.
-- Complete module names in imports and elsewhere.
|
startswith
"import"
stripped
&&
isModName
|
startswith
"import"
stripped
&&
isModName
=
=
ModuleName
dotted
candidate
ModuleName
dotted
candidate
|
isModName
&&
(
not
.
null
.
init
)
target
|
isModName
&&
(
not
.
null
.
init
)
target
=
=
Qualified
dotted
candidate
Qualified
dotted
candidate
-- Default to completing identifiers.
-- Default to completing identifiers.
|
otherwise
|
otherwise
=
=
Identifier
candidate
Identifier
candidate
where
stripped
=
strip
line
where
dotted
=
dots
target
stripped
=
strip
line
candidate
|
null
target
=
""
dotted
=
dots
target
|
otherwise
=
last
target
candidate
dots
=
intercalate
"."
.
init
|
null
target
=
""
isModName
=
all
isCapitalized
(
init
target
)
|
otherwise
=
last
target
dots
=
intercalate
"."
.
init
isCapitalized
[]
=
False
isModName
=
all
isCapitalized
(
init
target
)
isCapitalized
(
x
:
_
)
=
isUpper
x
isCapitalized
[]
=
False
lineUpToCursor
=
take
loc
line
isCapitalized
(
x
:
_
)
=
isUpper
x
fileComplete
filePath
=
case
parseShell
lineUpToCursor
of
Right
xs
->
filePath
lineUpToCursor
$
lineUpToCursor
=
take
loc
line
if
endswith
(
last
xs
)
lineUpToCursor
fileComplete
filePath
=
then
last
xs
case
parseShell
lineUpToCursor
of
else
[]
Right
xs
->
filePath
lineUpToCursor
$
Left
_
->
Empty
if
endswith
(
last
xs
)
lineUpToCursor
then
last
xs
cursorInString
str
loc
=
nquotes
(
take
loc
str
)
`
mod
`
2
/=
0
else
[]
Left
_
->
Empty
nquotes
(
'
\\
'
:
'"'
:
xs
)
=
nquotes
xs
nquotes
(
'"'
:
xs
)
=
1
+
nquotes
xs
cursorInString
str
loc
=
nquotes
(
take
loc
str
)
`
mod
`
2
/=
0
nquotes
(
_
:
xs
)
=
nquotes
xs
nquotes
[]
=
0
nquotes
(
'
\\
'
:
'"'
:
xs
)
=
nquotes
xs
nquotes
(
'"'
:
xs
)
=
1
+
nquotes
xs
-- Get the bit of a string that might be a filename completion.
nquotes
(
_
:
xs
)
=
nquotes
xs
-- Logic is a bit convoluted, but basically go backwards from the
nquotes
[]
=
0
-- end, stopping at any quote or space, unless they are escaped.
getStringTarget
::
String
->
String
-- Get the bit of a string that might be a filename completion. Logic is a bit convoluted, but
getStringTarget
=
go
""
.
reverse
-- basically go backwards from the end, stopping at any quote or space, unless they are escaped.
where
getStringTarget
::
String
->
String
go
acc
rest
=
case
rest
of
getStringTarget
=
go
""
.
reverse
'"'
:
'
\\
'
:
rem
->
go
(
'"'
:
acc
)
rem
where
'"'
:
rem
->
acc
go
acc
rest
=
' '
:
'
\\
'
:
rem
->
go
(
' '
:
acc
)
rem
case
rest
of
' '
:
rem
->
acc
'"'
:
'
\\
'
:
rem
->
go
(
'"'
:
acc
)
rem
x
:
rem
->
go
(
x
:
acc
)
rem
'"'
:
rem
->
acc
[]
->
acc
' '
:
'
\\
'
:
rem
->
go
(
' '
:
acc
)
rem
' '
:
rem
->
acc
x
:
rem
->
go
(
x
:
acc
)
rem
[]
->
acc
-- | 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
where
where
pieceToComplete
=
map
fst
<$>
find
(
elem
cursor
.
map
snd
)
pieces
pieceToComplete
=
map
fst
<$>
find
(
elem
cursor
.
map
snd
)
pieces
pieces
=
splitAlongCursor
$
split
splitter
$
zip
code
[
1
..
]
pieces
=
splitAlongCursor
$
split
splitter
$
zip
code
[
1
..
]
splitter
=
defaultSplitter
{
splitter
=
defaultSplitter
-- Split using only the characters, which are the first elements of
{
-- the (char, index) tuple
--
Split using only the characters, which are the first elements of
the (char, index) tuple
delimiter
=
Delimiter
[
uncurry
isDelim
]
,
delimiter
=
Delimiter
[
uncurry
isDelim
]
-- Condense multiple delimiters into one and then drop them.
-- Condense multiple delimiters into one and then drop them.
condensePolicy
=
Condense
,
,
condensePolicy
=
Condense
delimPolicy
=
Drop
,
delimPolicy
=
Drop
}
}
isDelim
::
Char
->
Int
->
Bool
isDelim
::
Char
->
Int
->
Bool
isDelim
char
idx
=
char
`
elem
`
neverIdent
||
isSymbol
char
isDelim
char
idx
=
char
`
elem
`
neverIdent
||
isSymbol
char
splitAlongCursor
::
[[(
Char
,
Int
)]]
->
[[(
Char
,
Int
)]]
splitAlongCursor
::
[[(
Char
,
Int
)]]
->
[[(
Char
,
Int
)]]
splitAlongCursor
[]
=
[]
splitAlongCursor
[]
=
[]
splitAlongCursor
(
x
:
xs
)
=
splitAlongCursor
(
x
:
xs
)
=
case
elemIndex
cursor
$
map
snd
x
of
case
elemIndex
cursor
$
map
snd
x
of
Nothing
->
x
:
splitAlongCursor
xs
Nothing
->
x
:
splitAlongCursor
xs
Just
idx
->
take
(
idx
+
1
)
x
:
drop
(
idx
+
1
)
x
:
splitAlongCursor
xs
Just
idx
->
take
(
idx
+
1
)
x
:
drop
(
idx
+
1
)
x
:
splitAlongCursor
xs
-- These are never part of an identifier.
-- These are never part of an identifier.
neverIdent
::
String
neverIdent
::
String
...
@@ -284,10 +279,11 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
...
@@ -284,10 +279,11 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
getHome
::
IO
String
getHome
::
IO
String
getHome
=
do
getHome
=
do
homeEither
<-
try
$
getEnv
"HOME"
::
IO
(
Either
SomeException
String
)
homeEither
<-
try
$
getEnv
"HOME"
::
IO
(
Either
SomeException
String
)
return
$
case
homeEither
of
return
$
Left
_
->
"~"
case
homeEither
of
Right
home
->
home
Left
_
->
"~"
Right
home
->
home
dirExpand
::
String
->
IO
String
dirExpand
::
String
->
IO
String
dirExpand
str
=
do
dirExpand
str
=
do
...
@@ -301,7 +297,8 @@ unDirExpand str = do
...
@@ -301,7 +297,8 @@ unDirExpand str = do
completePath
::
String
->
Interpreter
[
String
]
completePath
::
String
->
Interpreter
[
String
]
completePath
line
=
completePathFilter
acceptAll
acceptAll
line
""
completePath
line
=
completePathFilter
acceptAll
acceptAll
line
""
where
acceptAll
=
const
True
where
acceptAll
=
const
True
completePathWithExtensions
::
[
String
]
->
String
->
Interpreter
[
String
]
completePathWithExtensions
::
[
String
]
->
String
->
Interpreter
[
String
]
completePathWithExtensions
extensions
line
=
completePathWithExtensions
extensions
line
=
...
@@ -309,7 +306,8 @@ completePathWithExtensions extensions line =
...
@@ -309,7 +306,8 @@ completePathWithExtensions extensions line =
where
where
acceptAll
=
const
True
acceptAll
=
const
True
extensionIsOneOf
exts
str
=
any
correctEnding
exts
extensionIsOneOf
exts
str
=
any
correctEnding
exts
where
correctEnding
ext
=
endswith
ext
str
where
correctEnding
ext
=
endswith
ext
str
completePathFilter
::
(
String
->
Bool
)
-- ^ File filter: test whether to include this file.
completePathFilter
::
(
String
->
Bool
)
-- ^ File filter: test whether to include this file.
->
(
String
->
Bool
)
-- ^ Directory filter: test whether to include this directory.
->
(
String
->
Bool
)
-- ^ Directory filter: test whether to include this directory.
...
@@ -321,21 +319,19 @@ completePathFilter includeFile includeDirectory left right = liftIO $ do
...
@@ -321,21 +319,19 @@ completePathFilter includeFile includeDirectory left right = liftIO $ do
expanded
<-
dirExpand
left
expanded
<-
dirExpand
left
completions
<-
map
replacement
<$>
snd
<$>
completeFilename
(
reverse
expanded
,
right
)
completions
<-
map
replacement
<$>
snd
<$>
completeFilename
(
reverse
expanded
,
right
)
-- Split up into files and directories.
-- Split up into files and directories. Filter out ones we don't want.
-- Filter out ones we don't want.
areDirs
<-
mapM
doesDirectoryExist
completions
areDirs
<-
mapM
doesDirectoryExist
completions
let
dirs
=
filter
includeDirectory
$
map
fst
$
filter
snd
$
zip
completions
areDirs
let
dirs
=
filter
includeDirectory
$
map
fst
$
filter
snd
$
zip
completions
areDirs
files
=
filter
includeFile
$
map
fst
$
filter
(
not
.
snd
)
$
zip
completions
areDirs
files
=
filter
includeFile
$
map
fst
$
filter
(
not
.
snd
)
$
zip
completions
areDirs
-- Return directories before files. However, stick everything that starts
-- Return directories before files. However, stick everything that starts with a dot after
-- with a dot after everything else. If we wanted to keep original
-- everything else. If we wanted to keep original order, we could instead use
-- order, we could instead use
-- filter (`elem` (dirs ++ files)) completions
-- filter (`elem` (dirs ++ files)) completions
suggestions
<-
mapM
unDirExpand
$
dirs
++
files
suggestions
<-
mapM
unDirExpand
$
dirs
++
files
let
isHidden
str
=
startswith
"."
.
last
.
StringUtils
.
split
"/"
$
let
isHidden
str
=
startswith
"."
.
last
.
StringUtils
.
split
"/"
$
if
endswith
"/"
str
if
endswith
"/"
str
then
init
str
then
init
str
else
str
else
str
visible
=
filter
(
not
.
isHidden
)
suggestions
visible
=
filter
(
not
.
isHidden
)
suggestions
hidden
=
filter
isHidden
suggestions
hidden
=
filter
isHidden
suggestions
return
$
visible
++
hidden
return
$
visible
++
hidden
src/IHaskell/Eval/Evaluate.hs
View file @
7ba7c4d1
...
@@ -6,87 +6,101 @@
...
@@ -6,87 +6,101 @@
This module exports all functions used for evaluation of IHaskell input.
This module exports all functions used for evaluation of IHaskell input.
-}
-}
module
IHaskell.Eval.Evaluate
(
module
IHaskell.Eval.Evaluate
(
interpret
,
evaluate
,
Interpreter
,
liftIO
,
typeCleaner
,
globalImports
interpret
,
)
where
evaluate
,
Interpreter
,
import
ClassyPrelude
hiding
(
init
,
last
,
liftIO
,
head
,
hGetContents
,
tail
,
try
)
liftIO
,
import
Control.Concurrent
(
forkIO
,
threadDelay
)
typeCleaner
,
import
Prelude
(
putChar
,
head
,
tail
,
last
,
init
,
(
!!
))
globalImports
,
import
Data.List.Utils
)
where
import
Data.List
(
findIndex
,
and
,
foldl1
)
import
Data.String.Utils
import
ClassyPrelude
hiding
(
init
,
last
,
liftIO
,
head
,
hGetContents
,
tail
,
try
)
import
Text.Printf
import
Control.Concurrent
(
forkIO
,
threadDelay
)
import
Data.Char
as
Char
import
Prelude
(
putChar
,
head
,
tail
,
last
,
init
,
(
!!
))
import
Data.Dynamic
import
Data.List.Utils
import
Data.Typeable
import
Data.List
(
findIndex
,
and
,
foldl1
)
import
Data.String.Utils
import
Text.Printf
import
Data.Char
as
Char
import
Data.Dynamic
import
Data.Typeable
import
qualified
Data.Serialize
as
Serialize
import
qualified
Data.Serialize
as
Serialize
import
System.Directory
import
System.Directory
import
Filesystem.Path.CurrentOS
(
encodeString
)
import
Filesystem.Path.CurrentOS
(
encodeString
)
#
if
!
MIN_VERSION_base
(
4
,
8
,
0
)
#
if
!
MIN_VERSION_base
(
4
,
8
,
0
)
import
System.Posix.IO
(
createPipe
)
import
System.Posix.IO
(
createPipe
)
#
endif
#
endif
import
System.Posix.IO
(
fdToHandle
)
import
System.Posix.IO
(
fdToHandle
)
import
System.IO
(
hGetChar
,
hFlush
)
import
System.IO
(
hGetChar
,
hFlush
)
import
System.Random
(
getStdGen
,
randomRs
)
import
System.Random
(
getStdGen
,
randomRs
)
import
Unsafe.Coerce
import
Unsafe.Coerce
import
Control.Monad
(
guard
)
import
Control.Monad
(
guard
)
import
System.Process
import
System.Process
import
System.Exit
import
System.Exit
import
Data.Maybe
(
fromJust
)
import
Data.Maybe
(
fromJust
)
import
qualified
Control.Monad.IO.Class
as
MonadIO
(
MonadIO
,
liftIO
)
import
qualified
Control.Monad.IO.Class
as
MonadIO
(
MonadIO
,
liftIO
)
import
qualified
MonadUtils
(
MonadIO
,
liftIO
)
import
qualified
MonadUtils
(
MonadIO
,
liftIO
)
import
System.Environment
(
getEnv
)
import
System.Environment
(
getEnv
)
import
qualified
Data.Map
as
Map
import
qualified
Data.Map
as
Map
import
NameSet
import
NameSet
import
Name
import
Name
import
PprTyThing
import
PprTyThing
import
InteractiveEval
import
InteractiveEval
import
DynFlags
import
DynFlags
import
Type
import
Type
import
Exception
(
gtry
)
import
Exception
(
gtry
)
import
HscTypes
import
HscTypes
import
HscMain
import
HscMain
import
qualified
Linker
import
qualified
Linker
import
TcType
import
TcType
import
Unify
import
Unify
import
InstEnv
import
InstEnv
import
GhcMonad
(
liftIO
,
withSession
)
import
GhcMonad
(
liftIO
,
withSession
)
import
GHC
hiding
(
Stmt
,
TypeSig
)
import
GHC
hiding
(
Stmt
,
TypeSig
)
import
Exception
hiding
(
evaluate
)
import
Exception
hiding
(
evaluate
)
import
Outputable
hiding
((
<>
))
import
Outputable
hiding
((
<>
))
import
Packages
import
Packages
import
Module
hiding
(
Module
)
import
Module
hiding
(
Module
)
import
qualified
Pretty
import
qualified
Pretty
import
FastString
import
FastString
import
Bag
import
Bag
import
ErrUtils
(
errMsgShortDoc
,
errMsgExtraInfo
)
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.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
IHaskell.Eval.Util
import
IHaskell.BrokenPackages
import
IHaskell.BrokenPackages
import
qualified
IHaskell.IPython.Message.UUID
as
UUID
import
qualified
IHaskell.IPython.Message.UUID
as
UUID
import
Paths_ihaskell
(
version
)
import
Paths_ihaskell
(
version
)
import
Data.Version
(
versionBranch
)
import
Data.Version
(
versionBranch
)
data
ErrorOccurred
=
Success
|
Failure
deriving
(
Show
,
Eq
)
data
ErrorOccurred
=
Success
|
Failure
deriving
(
Show
,
Eq
)
-- | Set GHC's verbosity for debugging
-- | Set GHC's verbosity for debugging
ghcVerbosity
::
Maybe
Int
ghcVerbosity
::
Maybe
Int
ghcVerbosity
=
Nothing
-- Just 5
ghcVerbosity
=
Nothing
-- Just 5
ignoreTypePrefixes
::
[
String
]
ignoreTypePrefixes
::
[
String
]
ignoreTypePrefixes
=
[
"GHC.Types"
,
"GHC.Base"
,
"GHC.Show"
,
"System.IO"
,
ignoreTypePrefixes
=
[
"GHC.Types"
"GHC.Float"
,
":Interactive"
,
"GHC.Num"
,
"GHC.IO"
,
,
"GHC.Base"
"GHC.Integer.Type"
]
,
"GHC.Show"
,
"System.IO"
,
"GHC.Float"
,
":Interactive"
,
"GHC.Num"
,
"GHC.IO"
,
"GHC.Integer.Type"
]
typeCleaner
::
String
->
String
typeCleaner
::
String
->
String
typeCleaner
=
useStringType
.
foldl'
(
.
)
id
(
map
(`
replace
`
""
)
fullPrefixes
)
typeCleaner
=
useStringType
.
foldl'
(
.
)
id
(
map
(`
replace
`
""
)
fullPrefixes
)
...
@@ -98,14 +112,12 @@ write :: GhcMonad m => KernelState -> String -> m ()
...
@@ -98,14 +112,12 @@ write :: GhcMonad m => KernelState -> String -> m ()
write
state
x
=
when
(
kernelDebug
state
)
$
liftIO
$
hPutStrLn
stderr
$
"DEBUG: "
++
x
write
state
x
=
when
(
kernelDebug
state
)
$
liftIO
$
hPutStrLn
stderr
$
"DEBUG: "
++
x
type
Interpreter
=
Ghc
type
Interpreter
=
Ghc
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
-- GHC 7.8 exports a MonadIO instance for Ghc
-- GHC 7.8 exports a MonadIO instance for Ghc
#
else
#
else
instance
MonadIO
.
MonadIO
Interpreter
where
instance
MonadIO
.
MonadIO
Interpreter
where
liftIO
=
MonadUtils
.
liftIO
liftIO
=
MonadUtils
.
liftIO
#
endif
#
endif
globalImports
::
[
String
]
globalImports
::
[
String
]
globalImports
=
globalImports
=
[
"import IHaskell.Display()"
[
"import IHaskell.Display()"
...
@@ -118,23 +130,23 @@ globalImports =
...
@@ -118,23 +130,23 @@ globalImports =
,
"import qualified Language.Haskell.TH as IHaskellTH"
,
"import qualified Language.Haskell.TH as IHaskellTH"
]
]
-- | Run an interpreting action. This is effectively runGhc with
-- | Run an interpreting action. This is effectively runGhc with
initialization and importing. First
--
initialization and importing. First argument indicates whether `stdin`
--
argument indicates whether `stdin` is handled specially, which cannot be done in a testing
--
is handled specially, which cannot be done in a testing
environment.
-- environment.
interpret
::
String
->
Bool
->
Interpreter
a
->
IO
a
interpret
::
String
->
Bool
->
Interpreter
a
->
IO
a
interpret
libdir
allowedStdin
action
=
runGhc
(
Just
libdir
)
$
do
interpret
libdir
allowedStdin
action
=
runGhc
(
Just
libdir
)
$
do
-- If we're in a sandbox, add the relevant package database
-- If we're in a sandbox, add the relevant package database
sandboxPackages
<-
liftIO
getSandboxPackageConf
sandboxPackages
<-
liftIO
getSandboxPackageConf
initGhci
sandboxPackages
initGhci
sandboxPackages
case
ghcVerbosity
of
case
ghcVerbosity
of
Just
verb
->
do
dflags
<-
getSessionDynFlags
Just
verb
->
do
void
$
setSessionDynFlags
$
dflags
{
verbosity
=
verb
}
dflags
<-
getSessionDynFlags
Nothing
->
return
()
void
$
setSessionDynFlags
$
dflags
{
verbosity
=
verb
}
Nothing
->
return
()
initializeImports
initializeImports
-- 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
dir
<-
liftIO
getIHaskellDir
let
cmd
=
printf
"IHaskell.IPython.Stdin.fixStdin
\"
%s
\"
"
dir
let
cmd
=
printf
"IHaskell.IPython.Stdin.fixStdin
\"
%s
\"
"
dir
when
allowedStdin
$
void
$
when
allowedStdin
$
void
$
...
@@ -144,50 +156,53 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do
...
@@ -144,50 +156,53 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do
-- Run the rest of the interpreter
-- Run the rest of the interpreter
action
action
#
if
MIN_VERSION_ghc
(
7
,
10
,
0
)
packageIdString'
dflags
=
packageKeyPackageIdString
dflags
#
else
packageIdString'
dflags
=
packageIdString
#
endif
-- | Initialize our GHC session with imports and a value for 'it'.
-- | Initialize our GHC session with imports and a value for 'it'.
initializeImports
::
Interpreter
()
initializeImports
::
Interpreter
()
initializeImports
=
do
initializeImports
=
do
-- Load packages that start with ihaskell-*, aren't just IHaskell,
-- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right
-- and depend directly on the right version of the ihaskell library.
-- version of the ihaskell library. Also verify that the packages we load are not broken.
-- Also verify that the packages we load are not broken.
dflags
<-
getSessionDynFlags
dflags
<-
getSessionDynFlags
broken
<-
liftIO
getBrokenPackages
broken
<-
liftIO
getBrokenPackages
displayPackages
<-
liftIO
$
do
displayPackages
<-
liftIO
$
do
(
dflags
,
_
)
<-
initPackages
dflags
(
dflags
,
_
)
<-
initPackages
dflags
let
Just
db
=
pkgDatabase
dflags
let
Just
db
=
pkgDatabase
dflags
#
if
MIN_VERSION_ghc
(
7
,
10
,
0
)
packageNames
=
map
(
packageIdString'
dflags
.
packageConfigId
)
db
packageIdString
=
packageKeyPackageIdString
dflags
#
endif
initStr
=
"ihaskell-"
packageNames
=
map
(
packageIdString
.
packageConfigId
)
db
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
initStr
=
"ihaskell-
"
iHaskellPkgName
=
initStr
++
intercalate
".
"
(
map
show
(
versionBranch
version
))
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
iHaskellPkgName
=
initStr
++
intercalate
"."
(
map
show
(
versionBranch
version
))
dependsOnRight
pkg
=
not
$
null
$
do
pkg
<-
db
dependsOnRight
pkg
=
not
$
null
$
do
depId
<-
depends
pkg
pkg
<-
db
dep
<-
filter
((
==
depId
)
.
installedPackageId
)
db
depId
<-
depends
pkg
guard
dep
<-
filter
((
==
depId
)
.
installedPackageId
)
db
(
iHaskellPkgName
`
isPrefixOf
`
packageIdString
(
packageConfigId
dep
))
guard
(
iHaskellPkgName
`
isPrefixOf
`
packageIdString
(
packageConfigId
dep
))
-- ideally the Paths_ihaskell module could provide a way to get the hash too
-- ideally the Paths_ihaskell module could provide a way to get the
-- (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), for now. Things will end badly if you also
-- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9),
-- happen to have an ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.
-- for now. Things will end badly if you also happen to have an
iHaskellPkg
=
-- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.
case
filter
(
==
iHaskellPkgName
)
packageNames
of
iHaskellPkg
=
case
filter
(
==
iHaskellPkgName
)
packageNames
of
[
x
]
->
x
[
x
]
->
x
[]
->
error
[]
->
error
(
"cannot find required haskell library: "
++
iHaskellPkgName
)
(
"cannot find required haskell library: "
++
iHaskellPkgName
)
_
->
error
(
"multiple haskell packages "
++
iHaskellPkgName
++
" found"
)
_
->
error
(
"multiple haskell packages "
++
iHaskellPkgName
++
" found"
)
displayPkgs
=
[
pkgName
|
pkgName
<-
packageNames
,
displayPkgs
=
[
pkgName
|
pkgName
<-
packageNames
Just
(
x
:
_
)
<-
[
stripPrefix
initStr
pkgName
],
,
Just
(
x
:
_
)
<-
[
stripPrefix
initStr
pkgName
]
pkgName
`
notElem
`
broken
,
,
pkgName
`
notElem
`
broken
isAlpha
x
]
,
isAlpha
x
]
return
displayPkgs
return
displayPkgs
-- Generate import statements all Display modules.
-- Generate import statements all Display modules.
let
capitalize
::
String
->
String
let
capitalize
::
String
->
String
...
@@ -214,25 +229,28 @@ initializeImports = do
...
@@ -214,25 +229,28 @@ initializeImports = do
-- | Give a value for the `it` variable.
-- | Give a value for the `it` variable.
initializeItVariable
::
Interpreter
()
initializeItVariable
::
Interpreter
()
initializeItVariable
=
do
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,
--
statements - if it doesn't exist,
the first statement will fail.
-- the first statement will fail.
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 this output is final
--
this output is final
(true) or intermediate (false).
-- (true) or intermediate (false).
type
Publisher
=
(
EvaluationResult
->
IO
()
)
type
Publisher
=
(
EvaluationResult
->
IO
()
)
-- | Output of a command evaluation.
-- | Output of a command evaluation.
data
EvalOut
=
EvalOut
{
data
EvalOut
=
evalStatus
::
ErrorOccurred
,
EvalOut
evalResult
::
Display
,
{
evalStatus
::
ErrorOccurred
evalState
::
KernelState
,
,
evalResult
::
Display
evalPager
::
String
,
,
evalState
::
KernelState
evalComms
::
[
CommInfo
]
,
evalPager
::
String
}
,
evalComms
::
[
CommInfo
]
}
cleanString
::
String
->
String
cleanString
::
String
->
String
cleanString
x
=
if
allBrackets
then
clean
else
str
cleanString
x
=
if
allBrackets
then
clean
else
str
where
where
str
=
strip
x
str
=
strip
x
l
=
lines
str
l
=
lines
str
...
@@ -242,7 +260,7 @@ cleanString x = if allBrackets then clean else str
...
@@ -242,7 +260,7 @@ cleanString x = if allBrackets then clean else str
removeBracket
(
'>'
:
xs
)
=
xs
removeBracket
(
'>'
:
xs
)
=
xs
removeBracket
[]
=
[]
removeBracket
[]
=
[]
-- should never happen:
-- should never happen:
removeBracket
other
=
error
$
"Expected bracket as first char, but got string: "
++
other
removeBracket
other
=
error
$
"Expected bracket as first char, but got string: "
++
other
-- | Evaluate some IPython input code.
-- | Evaluate some IPython input code.
evaluate
::
KernelState
-- ^ The kernel state.
evaluate
::
KernelState
-- ^ The kernel state.
...
@@ -259,24 +277,23 @@ evaluate kernelState code output = do
...
@@ -259,24 +277,23 @@ evaluate kernelState code output = do
errs
=
mapMaybe
(
justError
.
unloc
)
cmds
errs
=
mapMaybe
(
justError
.
unloc
)
cmds
updated
<-
case
errs
of
updated
<-
case
errs
of
-- Only run things if there are no parse errors.
-- Only run things if there are no parse errors.
[]
->
do
[]
->
do
when
(
getLintStatus
kernelState
/=
LintOff
)
$
liftIO
$
do
when
(
getLintStatus
kernelState
/=
LintOff
)
$
liftIO
$
do
lintSuggestions
<-
lint
cmds
lintSuggestions
<-
lint
cmds
unless
(
noResults
lintSuggestions
)
$
unless
(
noResults
lintSuggestions
)
$
output
$
FinalResult
lintSuggestions
""
[]
output
$
FinalResult
lintSuggestions
""
[]
runUntilFailure
kernelState
(
map
unloc
cmds
++
[
storeItCommand
execCount
])
runUntilFailure
kernelState
(
map
unloc
cmds
++
[
storeItCommand
execCount
])
-- Print all parse errors.
-- Print all parse errors.
errs
->
do
errs
->
do
forM_
errs
$
\
err
->
do
forM_
errs
$
\
err
->
do
out
<-
evalCommand
output
err
kernelState
out
<-
evalCommand
output
err
kernelState
liftIO
$
output
$
FinalResult
(
evalResult
out
)
""
[]
liftIO
$
output
$
FinalResult
(
evalResult
out
)
""
[]
return
kernelState
return
kernelState
return
updated
{
return
updated
{
getExecutionCounter
=
execCount
+
1
}
getExecutionCounter
=
execCount
+
1
}
where
where
noResults
(
Display
res
)
=
null
res
noResults
(
Display
res
)
=
null
res
noResults
(
ManyDisplay
res
)
=
all
noResults
res
noResults
(
ManyDisplay
res
)
=
all
noResults
res
...
@@ -286,13 +303,12 @@ evaluate kernelState code output = do
...
@@ -286,13 +303,12 @@ evaluate kernelState code output = do
runUntilFailure
state
(
cmd
:
rest
)
=
do
runUntilFailure
state
(
cmd
:
rest
)
=
do
evalOut
<-
evalCommand
output
cmd
state
evalOut
<-
evalCommand
output
cmd
state
-- Get displayed channel outputs.
-- Get displayed channel outputs. Merge them with normal display outputs.
-- Merge them with normal display outputs.
dispsIO
<-
extractValue
"IHaskell.Display.displayFromChan"
dispsIO
<-
extractValue
"IHaskell.Display.displayFromChan"
dispsMay
<-
liftIO
dispsIO
dispsMay
<-
liftIO
dispsIO
let
result
=
let
result
=
case
dispsMay
of
case
dispsMay
of
Nothing
->
evalResult
evalOut
Nothing
->
evalResult
evalOut
Just
disps
->
evalResult
evalOut
<>
disps
Just
disps
->
evalResult
evalOut
<>
disps
helpStr
=
evalPager
evalOut
helpStr
=
evalPager
evalOut
...
@@ -314,7 +330,7 @@ evaluate kernelState code output = do
...
@@ -314,7 +330,7 @@ evaluate kernelState code output = do
extractValue
expr
=
do
extractValue
expr
=
do
compiled
<-
dynCompileExpr
expr
compiled
<-
dynCompileExpr
expr
case
fromDynamic
compiled
of
case
fromDynamic
compiled
of
Nothing
->
error
"Expecting value!"
Nothing
->
error
"Expecting value!"
Just
result
->
return
result
Just
result
->
return
result
safely
::
KernelState
->
Interpreter
EvalOut
->
Interpreter
EvalOut
safely
::
KernelState
->
Interpreter
EvalOut
->
Interpreter
EvalOut
...
@@ -322,46 +338,49 @@ safely state = ghandle handler . ghandle sourceErrorHandler
...
@@ -322,46 +338,49 @@ safely state = ghandle handler . ghandle sourceErrorHandler
where
where
handler
::
SomeException
->
Interpreter
EvalOut
handler
::
SomeException
->
Interpreter
EvalOut
handler
exception
=
handler
exception
=
return
EvalOut
{
return
evalStatus
=
Failure
,
EvalOut
evalResult
=
displayError
$
show
exception
,
{
evalStatus
=
Failure
evalState
=
state
,
,
evalResult
=
displayError
$
show
exception
evalPager
=
""
,
,
evalState
=
state
evalComms
=
[]
,
evalPager
=
""
}
,
evalComms
=
[]
}
sourceErrorHandler
::
SourceError
->
Interpreter
EvalOut
sourceErrorHandler
::
SourceError
->
Interpreter
EvalOut
sourceErrorHandler
srcerr
=
do
sourceErrorHandler
srcerr
=
do
let
msgs
=
bagToList
$
srcErrorMessages
srcerr
let
msgs
=
bagToList
$
srcErrorMessages
srcerr
errStrs
<-
forM
msgs
$
\
msg
->
do
errStrs
<-
forM
msgs
$
\
msg
->
do
shortStr
<-
doc
$
errMsgShortDoc
msg
shortStr
<-
doc
$
errMsgShortDoc
msg
contextStr
<-
doc
$
errMsgExtraInfo
msg
contextStr
<-
doc
$
errMsgExtraInfo
msg
return
$
unlines
[
shortStr
,
contextStr
]
return
$
unlines
[
shortStr
,
contextStr
]
let
fullErr
=
unlines
errStrs
let
fullErr
=
unlines
errStrs
return
EvalOut
{
return
evalStatus
=
Failure
,
EvalOut
evalResult
=
displayError
fullErr
,
{
evalStatus
=
Failure
evalState
=
state
,
,
evalResult
=
displayError
fullErr
evalPager
=
""
,
,
evalState
=
state
evalComms
=
[]
,
evalPager
=
""
}
,
evalComms
=
[]
}
wrapExecution
::
KernelState
wrapExecution
::
KernelState
->
Interpreter
Display
->
Interpreter
Display
->
Interpreter
EvalOut
->
Interpreter
EvalOut
wrapExecution
state
exec
=
safely
state
$
exec
>>=
\
res
->
wrapExecution
state
exec
=
safely
state
$
return
EvalOut
{
exec
>>=
\
res
->
evalStatus
=
Success
,
return
evalResult
=
res
,
EvalOut
evalState
=
state
,
{
evalStatus
=
Success
evalPager
=
""
,
,
evalResult
=
res
evalComms
=
[]
,
evalState
=
state
}
,
evalPager
=
""
,
evalComms
=
[]
-- | Return the display data for this command, as well as whether it
}
-- resulted in an error.
-- | Return the display data for this command, as well as whether it resulted in an error.
evalCommand
::
Publisher
->
CodeBlock
->
KernelState
->
Interpreter
EvalOut
evalCommand
::
Publisher
->
CodeBlock
->
KernelState
->
Interpreter
EvalOut
evalCommand
_
(
Import
importStr
)
state
=
wrapExecution
state
$
do
evalCommand
_
(
Import
importStr
)
state
=
wrapExecution
state
$
do
write
state
$
"Import: "
++
importStr
write
state
$
"Import: "
++
importStr
...
@@ -369,9 +388,9 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do
...
@@ -369,9 +388,9 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do
-- Warn about `it` variable.
-- Warn about `it` variable.
return
$
if
"Test.Hspec"
`
isInfixOf
`
importStr
return
$
if
"Test.Hspec"
`
isInfixOf
`
importStr
then
displayError
$
"Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639."
++
then
displayError
$
"Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639."
++
"
\n
The variable `it` is shadowed and cannot be accessed, even in qualified form."
"
\n
The variable `it` is shadowed and cannot be accessed, even in qualified form."
else
mempty
else
mempty
evalCommand
_
(
Module
contents
)
state
=
wrapExecution
state
$
do
evalCommand
_
(
Module
contents
)
state
=
wrapExecution
state
$
do
write
state
$
"Module:
\n
"
++
contents
write
state
$
"Module:
\n
"
++
contents
...
@@ -393,21 +412,21 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
...
@@ -393,21 +412,21 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
-- Remember which modules we've loaded before.
-- Remember which modules we've loaded before.
importedModules
<-
getContext
importedModules
<-
getContext
let
-- Get the dot-delimited pieces of the module name.
let
-- Get the dot-delimited pieces of the module name.
moduleNameOf
::
InteractiveImport
->
[
String
]
moduleNameOf
::
InteractiveImport
->
[
String
]
moduleNameOf
(
IIDecl
decl
)
=
split
"."
.
moduleNameString
.
unLoc
.
ideclName
$
decl
moduleNameOf
(
IIDecl
decl
)
=
split
"."
.
moduleNameString
.
unLoc
.
ideclName
$
decl
moduleNameOf
(
IIModule
imp
)
=
split
"."
.
moduleNameString
$
imp
moduleNameOf
(
IIModule
imp
)
=
split
"."
.
moduleNameString
$
imp
-- Return whether this module prevents the loading of the one we're
-- Return whether this module prevents the loading of the one we're trying to load. If a module B
-- trying to load. If a module B exist, we cannot load A.B. All
-- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).
-- modules must have unique last names (where A.B has last name B).
-- However, we *can* just reload a module.
-- However, we *can* just reload a module.
preventsLoading
mod
=
preventsLoading
mod
=
let
pieces
=
moduleNameOf
mod
in
let
pieces
=
moduleNameOf
mod
last
namePieces
==
last
pieces
&&
namePieces
/=
pieces
in
last
namePieces
==
last
pieces
&&
namePieces
/=
pieces
-- If we've loaded anything with the same last name, we can't use this.
-- If we've loaded anything with the same last name, we can't use this.
Otherwise, GHC tries to load
--
Otherwise, GHC tries to load
the original *.hs fails and then fails.
-- the original *.hs fails and then fails.
case
find
preventsLoading
importedModules
of
case
find
preventsLoading
importedModules
of
-- If something prevents loading this module, return an error.
-- If something prevents loading this module, return an error.
Just
previous
->
do
Just
previous
->
do
...
@@ -425,7 +444,8 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
...
@@ -425,7 +444,8 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
-- Find which flags are IHaskell flags, and which are GHC flags
-- Find which flags are IHaskell flags, and which are GHC flags
let
flags
=
words
flagsStr
let
flags
=
words
flagsStr
-- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell flags.
-- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell
-- flags.
ihaskellFlagUpdater
::
String
->
Maybe
(
KernelState
->
KernelState
)
ihaskellFlagUpdater
::
String
->
Maybe
(
KernelState
->
KernelState
)
ihaskellFlagUpdater
flag
=
getUpdateKernelState
<$>
find
(
elem
flag
.
getSetName
)
kernelOpts
ihaskellFlagUpdater
flag
=
getUpdateKernelState
<$>
find
(
elem
flag
.
getSetName
)
kernelOpts
...
@@ -435,41 +455,47 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
...
@@ -435,41 +455,47 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
write
state
$
"GHC Flags: "
++
unwords
ghcFlags
write
state
$
"GHC Flags: "
++
unwords
ghcFlags
if
null
flags
if
null
flags
then
do
then
do
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
return
EvalOut
{
return
evalStatus
=
Success
,
EvalOut
evalResult
=
Display
[
plain
$
showSDoc
flags
$
vcat
[
pprDynFlags
False
flags
,
pprLanguages
False
flags
]],
{
evalStatus
=
Success
evalState
=
state
,
,
evalResult
=
Display
evalPager
=
""
,
[
plain
$
showSDoc
flags
$
vcat
evalComms
=
[]
[
pprDynFlags
False
flags
}
,
pprLanguages
False
flags
else
do
]
-- Apply all IHaskell flag updaters to the state to get the new state
]
let
state'
=
(
foldl'
(
.
)
id
(
map
(
fromJust
.
ihaskellFlagUpdater
)
ihaskellFlags
))
state
,
evalState
=
state
errs
<-
setFlags
ghcFlags
,
evalPager
=
""
let
display
=
case
errs
of
,
evalComms
=
[]
[]
->
mempty
}
_
->
displayError
$
intercalate
"
\n
"
errs
else
do
-- Apply all IHaskell flag updaters to the state to get the new state
-- For -XNoImplicitPrelude, remove the Prelude import.
let
state'
=
(
foldl'
(
.
)
id
(
map
(
fromJust
.
ihaskellFlagUpdater
)
ihaskellFlags
))
state
-- For -XImplicitPrelude, add it back in.
errs
<-
setFlags
ghcFlags
if
"-XNoImplicitPrelude"
`
elem
`
flags
let
display
=
then
evalImport
"import qualified Prelude as Prelude"
case
errs
of
else
[]
->
mempty
when
(
"-XImplicitPrelude"
`
elem
`
flags
)
$
do
_
->
displayError
$
intercalate
"
\n
"
errs
importDecl
<-
parseImportDecl
"import Prelude"
let
implicitPrelude
=
importDecl
{
ideclImplicit
=
True
}
-- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in.
imports
<-
getContext
if
"-XNoImplicitPrelude"
`
elem
`
flags
setContext
$
IIDecl
implicitPrelude
:
imports
then
evalImport
"import qualified Prelude as Prelude"
else
when
(
"-XImplicitPrelude"
`
elem
`
flags
)
$
do
return
EvalOut
{
importDecl
<-
parseImportDecl
"import Prelude"
evalStatus
=
Success
,
let
implicitPrelude
=
importDecl
{
ideclImplicit
=
True
}
evalResult
=
display
,
imports
<-
getContext
evalState
=
state'
,
setContext
$
IIDecl
implicitPrelude
:
imports
evalPager
=
""
,
evalComms
=
[]
return
}
EvalOut
{
evalStatus
=
Success
,
evalResult
=
display
,
evalState
=
state'
,
evalPager
=
""
,
evalComms
=
[]
}
evalCommand
output
(
Directive
SetExtension
opts
)
state
=
do
evalCommand
output
(
Directive
SetExtension
opts
)
state
=
do
write
state
$
"Extension: "
++
opts
write
state
$
"Extension: "
++
opts
...
@@ -483,12 +509,11 @@ evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
...
@@ -483,12 +509,11 @@ evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
case
firstChar
of
case
firstChar
of
'+'
->
(
words
remainder
,
False
)
'+'
->
(
words
remainder
,
False
)
'-'
->
(
words
remainder
,
True
)
'-'
->
(
words
remainder
,
True
)
_
->
(
words
stripped
,
False
)
_
->
(
words
stripped
,
False
)
forM_
modules
$
\
modl
->
forM_
modules
$
\
modl
->
if
removeModule
if
removeModule
then
removeImport
modl
then
removeImport
modl
else
evalImport
$
"import "
++
modl
else
evalImport
$
"import "
++
modl
return
mempty
return
mempty
...
@@ -496,25 +521,26 @@ evalCommand a (Directive SetOption opts) state = do
...
@@ -496,25 +521,26 @@ evalCommand a (Directive SetOption opts) state = do
write
state
$
"Option: "
++
opts
write
state
$
"Option: "
++
opts
let
(
existing
,
nonExisting
)
=
partition
optionExists
$
words
opts
let
(
existing
,
nonExisting
)
=
partition
optionExists
$
words
opts
if
not
$
null
nonExisting
if
not
$
null
nonExisting
then
then
let
err
=
"No such options: "
++
intercalate
", "
nonExisting
let
err
=
"No such options: "
++
intercalate
", "
nonExisting
in
in
return
return
EvalOut
{
EvalOut
evalStatus
=
Failure
,
{
evalStatus
=
Failure
evalResult
=
displayError
err
,
,
evalResult
=
displayError
err
evalState
=
state
,
,
evalState
=
state
evalPager
=
""
,
,
evalPager
=
""
evalComms
=
[]
,
evalComms
=
[]
}
}
else
else
let
options
=
mapMaybe
findOption
$
words
opts
let
options
=
mapMaybe
findOption
$
words
opts
updater
=
foldl'
(
.
)
id
$
map
getUpdateKernelState
options
updater
=
foldl'
(
.
)
id
$
map
getUpdateKernelState
options
in
in
return
return
EvalOut
{
EvalOut
evalStatus
=
Success
,
{
evalStatus
=
Success
evalResult
=
mempty
,
,
evalResult
=
mempty
evalState
=
updater
state
,
,
evalState
=
updater
state
evalPager
=
""
,
,
evalPager
=
""
evalComms
=
[]
,
evalComms
=
[]
}
}
where
where
optionExists
=
isJust
.
findOption
optionExists
=
isJust
.
findOption
findOption
opt
=
findOption
opt
=
...
@@ -522,7 +548,7 @@ evalCommand a (Directive SetOption opts) state = do
...
@@ -522,7 +548,7 @@ evalCommand a (Directive SetOption opts) state = do
evalCommand
_
(
Directive
GetType
expr
)
state
=
wrapExecution
state
$
do
evalCommand
_
(
Directive
GetType
expr
)
state
=
wrapExecution
state
$
do
write
state
$
"Type: "
++
expr
write
state
$
"Type: "
++
expr
formatType
<$>
((
expr
++
" :: "
)
++
)
<$>
getType
expr
formatType
<$>
((
expr
++
" :: "
)
++
)
<$>
getType
expr
evalCommand
_
(
Directive
GetKind
expr
)
state
=
wrapExecution
state
$
do
evalCommand
_
(
Directive
GetKind
expr
)
state
=
wrapExecution
state
$
do
write
state
$
"Kind: "
++
expr
write
state
$
"Kind: "
++
expr
...
@@ -535,8 +561,8 @@ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
...
@@ -535,8 +561,8 @@ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
write
state
$
"Load: "
++
name
write
state
$
"Load: "
++
name
let
filename
=
if
endswith
".hs"
name
let
filename
=
if
endswith
".hs"
name
then
name
then
name
else
name
++
".hs"
else
name
++
".hs"
contents
<-
readFile
$
fpFromString
filename
contents
<-
readFile
$
fpFromString
filename
modName
<-
intercalate
"."
<$>
getModuleName
contents
modName
<-
intercalate
"."
<$>
getModuleName
contents
doLoadModule
filename
modName
doLoadModule
filename
modName
...
@@ -546,123 +572,130 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
...
@@ -546,123 +572,130 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
"cd"
:
dirs
->
do
"cd"
:
dirs
->
do
-- Get home so we can replace '~` with it.
-- Get home so we can replace '~` with it.
homeEither
<-
liftIO
(
try
$
getEnv
"HOME"
::
IO
(
Either
SomeException
String
))
homeEither
<-
liftIO
(
try
$
getEnv
"HOME"
::
IO
(
Either
SomeException
String
))
let
home
=
case
homeEither
of
let
home
=
Left
_
->
"~"
case
homeEither
of
Right
val
->
val
Left
_
->
"~"
Right
val
->
val
let
directory
=
replace
"~"
home
$
unwords
dirs
let
directory
=
replace
"~"
home
$
unwords
dirs
exists
<-
liftIO
$
doesDirectoryExist
directory
exists
<-
liftIO
$
doesDirectoryExist
directory
if
exists
if
exists
then
do
then
do
-- Set the directory in IHaskell native code, for future shell
-- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for
-- commands. This doesn't set it for
user code, though.
--
user code, though.
liftIO
$
setCurrentDirectory
directory
liftIO
$
setCurrentDirectory
directory
-- Set the directory for user code.
-- Set the directory for user code.
let
cmd
=
printf
"IHaskellDirectory.setCurrentDirectory
\"
%s
\"
"
$
let
cmd
=
printf
"IHaskellDirectory.setCurrentDirectory
\"
%s
\"
"
$
replace
" "
"
\\
"
$
replace
" "
"
\\
"
$
replace
"
\"
"
"
\\\"
"
directory
replace
"
\"
"
"
\\\"
"
directory
runStmt
cmd
RunToCompletion
runStmt
cmd
RunToCompletion
return
mempty
return
mempty
else
else
return
$
displayError
$
printf
"No such directory: '%s'"
directory
return
$
displayError
$
printf
"No such directory: '%s'"
directory
cmd
->
liftIO
$
do
cmd
->
liftIO
$
do
#
if
MIN_VERSION_base
(
4
,
8
,
0
)
(
pipe
,
handle
)
<-
createPipe'
(
pipe
,
handle
)
<-
createPipe
#
else
(
readEnd
,
writeEnd
)
<-
createPipe
handle
<-
fdToHandle
writeEnd
pipe
<-
fdToHandle
readEnd
#
endif
let
initProcSpec
=
shell
$
unwords
cmd
let
initProcSpec
=
shell
$
unwords
cmd
procSpec
=
initProcSpec
{
procSpec
=
initProcSpec
std_in
=
Inherit
,
{
std_in
=
Inherit
std_out
=
UseHandle
handle
,
,
std_out
=
UseHandle
handle
std_err
=
UseHandle
handle
,
std_err
=
UseHandle
handle
}
}
(
_
,
_
,
_
,
process
)
<-
createProcess
procSpec
(
_
,
_
,
_
,
process
)
<-
createProcess
procSpec
-- Accumulate output from the process.
-- Accumulate output from the process.
outputAccum
<-
liftIO
$
newMVar
""
outputAccum
<-
liftIO
$
newMVar
""
-- Start a loop to publish intermediate results.
-- Start a loop to publish intermediate results.
let
let
-- Compute how long to wait between reading pieces of the output.
-- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
-- `threadDelay` takes an argument of microseconds.
-- argument of microseconds.
ms
=
1000
ms
=
1000
delay
=
100
*
ms
delay
=
100
*
ms
-- Maximum size of the output (after which we truncate).
-- Maximum size of the output (after which we truncate).
maxSize
=
100
*
1000
maxSize
=
100
*
1000
incSize
=
200
incSize
=
200
output
str
=
publish
$
IntermediateResult
$
Display
[
plain
str
]
output
str
=
publish
$
IntermediateResult
$
Display
[
plain
str
]
loop
=
do
loop
=
do
-- Wait and then check if the computation is done.
-- Wait and then check if the computation is done.
threadDelay
delay
threadDelay
delay
-- Read next chunk and append to accumulator.
-- Read next chunk and append to accumulator.
nextChunk
<-
readChars
pipe
"
\n
"
incSize
nextChunk
<-
readChars
pipe
"
\n
"
incSize
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
-- Check if we're done.
exitCode
<-
getProcessExitCode
process
let
computationDone
=
isJust
exitCode
when
computationDone
$
do
nextChunk
<-
readChars
pipe
""
maxSize
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
if
not
computationDone
-- Check if we're done.
then
do
exitCode
<-
getProcessExitCode
process
-- Write to frontend and repeat.
let
computationDone
=
isJust
exitCode
readMVar
outputAccum
>>=
output
loop
when
computationDone
$
do
else
do
nextChunk
<-
readChars
pipe
""
maxSize
out
<-
readMVar
outputAccum
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
case
fromJust
exitCode
of
ExitSuccess
->
return
$
Display
[
plain
out
]
if
not
computationDone
ExitFailure
code
->
do
then
do
let
errMsg
=
"Process exited with error code "
++
show
code
-- Write to frontend and repeat.
htmlErr
=
printf
"<span class='err-msg'>%s</span>"
errMsg
readMVar
outputAccum
>>=
output
return
$
Display
[
plain
$
out
++
"
\n
"
++
errMsg
,
loop
html
$
printf
"<span class='mono'>%s</span>"
out
++
htmlErr
]
else
do
out
<-
readMVar
outputAccum
case
fromJust
exitCode
of
ExitSuccess
->
return
$
Display
[
plain
out
]
ExitFailure
code
->
do
let
errMsg
=
"Process exited with error code "
++
show
code
htmlErr
=
printf
"<span class='err-msg'>%s</span>"
errMsg
return
$
Display
[
plain
$
out
++
"
\n
"
++
errMsg
,
html
$
printf
"<span class='mono'>%s</span>"
out
++
htmlErr
]
loop
loop
where
#
if
MIN_VERSION_base
(
4
,
8
,
0
)
createPipe'
=
createPipe
#
else
createPipe'
=
do
(
readEnd
,
writeEnd
)
<-
createPipe
handle
<-
fdToHandle
writeEnd
pipe
<-
fdToHandle
readEnd
return
(
pipe
,
handle
)
#
endif
-- This is taken largely from GHCi's info section in InteractiveUI.
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand
_
(
Directive
GetHelp
_
)
state
=
do
evalCommand
_
(
Directive
GetHelp
_
)
state
=
do
write
state
"Help via :help or :?."
write
state
"Help via :help or :?."
return
EvalOut
{
return
evalStatus
=
Success
,
EvalOut
evalResult
=
Display
[
out
],
{
evalStatus
=
Success
evalState
=
state
,
,
evalResult
=
Display
[
out
]
evalPager
=
""
,
,
evalState
=
state
evalComms
=
[]
,
evalPager
=
""
}
,
evalComms
=
[]
where
out
=
plain
$
intercalate
"
\n
"
}
[
"The following commands are available:"
,
" :extension <Extension> - Enable a GHC extension."
where
,
" :extension No<Extension> - Disable a GHC extension."
out
=
plain
$
intercalate
"
\n
"
,
" :type <expression> - Print expression type."
[
"The following commands are available:"
,
" :info <name> - Print all info for a name."
,
" :extension <Extension> - Enable a GHC extension."
,
" :hoogle <query> - Search for a query on Hoogle."
,
" :extension No<Extension> - Disable a GHC extension."
,
" :doc <ident> - Get documentation for an identifier via Hogole."
,
" :type <expression> - Print expression type."
,
" :set -XFlag -Wall - Set an option (like ghci)."
,
" :info <name> - Print all info for a name."
,
" :option <opt> - Set an option."
,
" :hoogle <query> - Search for a query on Hoogle."
,
" :option no-<opt> - Unset an option."
,
" :doc <ident> - Get documentation for an identifier via Hogole."
,
" :?, :help - Show this help text."
,
" :set -XFlag -Wall - Set an option (like ghci)."
,
""
,
" :option <opt> - Set an option."
,
"Any prefix of the commands will also suffice, e.g. use :ty for :type."
,
" :option no-<opt> - Unset an option."
,
""
,
" :?, :help - Show this help text."
,
"Options:"
,
""
,
" lint – enable or disable linting."
,
"Any prefix of the commands will also suffice, e.g. use :ty for :type."
,
" svg – use svg output (cannot be resized)."
,
""
,
" show-types – show types of all bound names"
,
"Options:"
,
" show-errors – display Show instance missing errors normally."
,
" lint – enable or disable linting."
,
" pager – use the pager to display results of :info, :doc, :hoogle, etc."
,
" svg – use svg output (cannot be resized)."
]
,
" show-types – show types of all bound names"
,
" show-errors – display Show instance missing errors normally."
,
" pager – use the pager to display results of :info, :doc, :hoogle, etc."
]
-- This is taken largely from GHCi's info section in InteractiveUI.
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand
_
(
Directive
GetInfo
str
)
state
=
safely
state
$
do
evalCommand
_
(
Directive
GetInfo
str
)
state
=
safely
state
$
do
...
@@ -673,18 +706,21 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
...
@@ -673,18 +706,21 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
-- TODO: Make pager work without html by porting to newer architecture
-- TODO: Make pager work without html by porting to newer architecture
let
output
=
unlines
(
map
htmlify
strings
)
let
output
=
unlines
(
map
htmlify
strings
)
htmlify
str
=
htmlify
str
=
printf
"<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>"
str
printf
"<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>"
str
++
script
++
script
script
=
script
=
"<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>"
"<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>"
return
EvalOut
{
return
evalStatus
=
Success
,
EvalOut
evalResult
=
mempty
,
{
evalStatus
=
Success
evalState
=
state
,
,
evalResult
=
mempty
evalPager
=
output
,
,
evalState
=
state
evalComms
=
[]
,
evalPager
=
output
}
,
evalComms
=
[]
}
evalCommand
_
(
Directive
SearchHoogle
query
)
state
=
safely
state
$
do
evalCommand
_
(
Directive
SearchHoogle
query
)
state
=
safely
state
$
do
results
<-
liftIO
$
Hoogle
.
search
query
results
<-
liftIO
$
Hoogle
.
search
query
...
@@ -711,27 +747,24 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
...
@@ -711,27 +747,24 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
write
state
$
"Names: "
++
show
allNames
write
state
$
"Names: "
++
show
allNames
-- Display the types of all bound names if the option is on.
-- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
-- This is similar to GHCi :set +t.
if
not
$
useShowTypes
state
if
not
$
useShowTypes
state
then
return
$
Display
output
then
return
$
Display
output
else
do
else
do
-- Get all the type strings.
-- Get all the type strings.
types
<-
forM
nonItNames
$
\
name
->
do
types
<-
forM
nonItNames
$
\
name
->
do
theType
<-
showSDocUnqual
dflags
.
ppr
<$>
exprType
name
theType
<-
showSDocUnqual
dflags
.
ppr
<$>
exprType
name
return
$
name
++
" :: "
++
theType
return
$
name
++
" :: "
++
theType
let
joined
=
unlines
types
let
joined
=
unlines
types
htmled
=
unlines
$
map
formatGetType
types
htmled
=
unlines
$
map
formatGetType
types
return
$
case
extractPlain
output
of
return
$
""
->
Display
[
html
htmled
]
case
extractPlain
output
of
""
->
Display
[
html
htmled
]
-- Return plain and html versions.
-- Return plain and html versions. Previously there was only a plain version.
-- Previously there was only a plain version.
text
->
Display
[
plain
$
joined
++
"
\n
"
++
text
,
html
$
htmled
++
mono
text
]
text
->
Display
[
plain
$
joined
++
"
\n
"
++
text
,
html
$
htmled
++
mono
text
]
RunException
exception
->
throw
exception
RunException
exception
->
throw
exception
RunBreak
{}
->
error
"Should not break."
RunBreak
{}
->
error
"Should not break."
...
@@ -739,10 +772,9 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
...
@@ -739,10 +772,9 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
evalCommand
output
(
Expression
expr
)
state
=
do
evalCommand
output
(
Expression
expr
)
state
=
do
write
state
$
"Expression:
\n
"
++
expr
write
state
$
"Expression:
\n
"
++
expr
-- Try to use `display` to convert our type into the output
-- Try to use `display` to convert our type into the output Dislay If typechecking fails and there
-- Dislay If typechecking fails and there is no appropriate
-- is no appropriate typeclass instance, this will throw an exception and thus `attempt` will return
-- typeclass instance, this will throw an exception and thus `attempt` will
-- False, and we just resort to plaintext.
-- return False, and we just resort to plaintext.
let
displayExpr
=
printf
"(IHaskell.Display.display (%s))"
expr
::
String
let
displayExpr
=
printf
"(IHaskell.Display.display (%s))"
expr
::
String
canRunDisplay
<-
attempt
$
exprType
displayExpr
canRunDisplay
<-
attempt
$
exprType
displayExpr
...
@@ -751,68 +783,71 @@ evalCommand output (Expression expr) state = do
...
@@ -751,68 +783,71 @@ evalCommand output (Expression expr) state = do
isWidget
<-
attempt
$
exprType
widgetExpr
isWidget
<-
attempt
$
exprType
widgetExpr
-- Check if this is a template haskell declaration
-- Check if this is a template haskell declaration
let
declExpr
=
printf
"((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))"
expr
::
String
let
declExpr
=
printf
"((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))"
expr
::
String
let
anyExpr
=
printf
"((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))"
expr
::
String
let
anyExpr
=
printf
"((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))"
expr
::
String
isTHDeclaration
<-
liftM2
(
&&
)
(
attempt
$
exprType
declExpr
)
(
not
<$>
attempt
(
exprType
anyExpr
))
isTHDeclaration
<-
liftM2
(
&&
)
(
attempt
$
exprType
declExpr
)
(
not
<$>
attempt
(
exprType
anyExpr
))
write
state
$
"Can Display: "
++
show
canRunDisplay
write
state
$
"Can Display: "
++
show
canRunDisplay
write
state
$
"Is Widget: "
++
show
isWidget
write
state
$
"Is Widget: "
++
show
isWidget
write
state
$
"Is Declaration: "
++
show
isTHDeclaration
write
state
$
"Is Declaration: "
++
show
isTHDeclaration
if
isTHDeclaration
if
isTHDeclaration
-- If it typechecks as a DecsQ, we do not want to display the DecsQ,
then
-- we just want the declaration made.
-- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the
then
do
-- declaration made.
write
state
$
"Suppressing display for template haskell declaration"
do
GHC
.
runDecls
expr
write
state
$
"Suppressing display for template haskell declaration"
return
EvalOut
{
GHC
.
runDecls
expr
evalStatus
=
Success
,
return
evalResult
=
mempty
,
EvalOut
evalState
=
state
,
{
evalStatus
=
Success
evalPager
=
""
,
,
evalResult
=
mempty
evalComms
=
[]
,
evalState
=
state
}
,
evalPager
=
""
else
do
,
evalComms
=
[]
}
else
do
if
canRunDisplay
if
canRunDisplay
then
do
then
do
-- Use the display. As a result, `it` is set to the output.
-- Use the display. As a result, `it` is set to the output.
out
<-
useDisplay
displayExpr
out
<-
useDisplay
displayExpr
-- Register the `it` object as a widget.
-- Register the `it` object as a widget.
if
isWidget
if
isWidget
then
registerWidget
out
then
registerWidget
out
else
return
out
else
return
out
else
do
else
do
-- Evaluate this expression as though it's just a statement.
-- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can
-- The output is bound to 'it', so we can
then use it.
--
then use it.
evalOut
<-
evalCommand
output
(
Statement
expr
)
state
evalOut
<-
evalCommand
output
(
Statement
expr
)
state
let
out
=
evalResult
evalOut
let
out
=
evalResult
evalOut
showErr
=
isShowError
out
showErr
=
isShowError
out
-- If evaluation failed, return the failure. If it was successful, w
e
-- If evaluation failed, return the failure. If it was successful, we may be able to use th
e
-- may be able to use the
IHaskellDisplay typeclass.
--
IHaskellDisplay typeclass.
return
$
if
not
showErr
||
useShowErrors
state
return
$
if
not
showErr
||
useShowErrors
state
then
evalOut
then
evalOut
else
postprocessShowError
evalOut
else
postprocessShowError
evalOut
where
where
-- Try to evaluate an action. Return True if it succeeds and False if
-- Try to evaluate an action. Return True if it succeeds and False if
it throws an exception. The
--
it throws an exception. The
result of the action is discarded.
-- result of the action is discarded.
attempt
::
Interpreter
a
->
Interpreter
Bool
attempt
::
Interpreter
a
->
Interpreter
Bool
attempt
action
=
gcatch
(
action
>>
return
True
)
failure
attempt
action
=
gcatch
(
action
>>
return
True
)
failure
where
failure
::
SomeException
->
Interpreter
Bool
where
failure
_
=
return
False
failure
::
SomeException
->
Interpreter
Bool
failure
_
=
return
False
-- Check if the error is due to trying to print something that doesn't
-- Check if the error is due to trying to print something that doesn't implement the Show typeclass.
-- implement the Show typeclass.
isShowError
(
ManyDisplay
_
)
=
False
isShowError
(
ManyDisplay
_
)
=
False
isShowError
(
Display
errs
)
=
isShowError
(
Display
errs
)
=
-- Note that we rely on this error message being 'type cleaned', so
-- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as
-- that `Show` is not displayed as GHC.Show.Show. This is also very fragile!
-- GHC.Show.Show. This is also very fragile!
startswith
"No instance for (Show"
msg
&&
startswith
"No instance for (Show"
msg
&&
isInfixOf
"print it"
msg
isInfixOf
"print it"
msg
where
msg
=
extractPlain
errs
where
msg
=
extractPlain
errs
isSvg
(
DisplayData
mime
_
)
=
mime
==
MimeSvg
isSvg
(
DisplayData
mime
_
)
=
mime
==
MimeSvg
...
@@ -821,20 +856,16 @@ evalCommand output (Expression expr) state = do
...
@@ -821,20 +856,16 @@ evalCommand output (Expression expr) state = do
removeSvg
(
ManyDisplay
disps
)
=
ManyDisplay
$
map
removeSvg
disps
removeSvg
(
ManyDisplay
disps
)
=
ManyDisplay
$
map
removeSvg
disps
useDisplay
displayExpr
=
do
useDisplay
displayExpr
=
do
-- If there are instance matches, convert the object into
-- If there are instance matches, convert the object into a Display. We also serialize it into a
-- a Display. We also serialize it into a bytestring. We get
-- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring,
-- the bytestring IO action as a dynamic and then convert back to
-- which we promptly unserialize. Note that attempting to do this without the serialization to
-- a bytestring, which we promptly unserialize. Note that
-- binary and back gives very strange errors - all the types match but it refuses to decode back
-- attempting to do this without the serialization to binary and
-- into a Display. Suppress output, so as not to mess up console. First, evaluate the expression in
-- back gives very strange errors - all the types match but it
-- such a way that we have access to `it`.
-- refuses to decode back into a Display.
-- Suppress output, so as not to mess up console.
-- First, evaluate the expression in such a way that we have access to `it`.
io
<-
isIO
expr
io
<-
isIO
expr
let
stmtTemplate
=
if
io
let
stmtTemplate
=
if
io
then
"it <- (%s)"
then
"it <- (%s)"
else
"let { it = %s }"
else
"let { it = %s }"
evalOut
<-
evalCommand
output
(
Statement
$
printf
stmtTemplate
expr
)
state
evalOut
<-
evalCommand
output
(
Statement
$
printf
stmtTemplate
expr
)
state
case
evalStatus
evalOut
of
case
evalStatus
evalOut
of
Failure
->
return
evalOut
Failure
->
return
evalOut
...
@@ -853,8 +884,8 @@ evalCommand output (Expression expr) state = do
...
@@ -853,8 +884,8 @@ evalCommand output (Expression expr) state = do
Right
display
->
Right
display
->
return
$
return
$
if
useSvg
state
if
useSvg
state
then
display
::
Display
then
display
::
Display
else
removeSvg
display
else
removeSvg
display
registerWidget
::
EvalOut
->
Ghc
EvalOut
registerWidget
::
EvalOut
->
Ghc
EvalOut
registerWidget
evalOut
=
registerWidget
evalOut
=
...
@@ -872,10 +903,11 @@ evalCommand output (Expression expr) state = do
...
@@ -872,10 +903,11 @@ evalCommand output (Expression expr) state = do
state'
=
state
{
openComms
=
newComms
}
state'
=
state
{
openComms
=
newComms
}
-- Store the fact that we should start this comm.
-- Store the fact that we should start this comm.
return
evalOut
{
return
evalComms
=
CommInfo
widget
uuid
(
targetName
widget
)
:
evalComms
evalOut
,
evalOut
evalState
=
state'
{
evalComms
=
CommInfo
widget
uuid
(
targetName
widget
)
:
evalComms
evalOut
}
,
evalState
=
state'
}
isIO
expr
=
attempt
$
exprType
$
printf
"((
\\
x -> x) :: IO a -> IO a) (%s)"
expr
isIO
expr
=
attempt
$
exprType
$
printf
"((
\\
x -> x) :: IO a -> IO a) (%s)"
expr
...
@@ -885,17 +917,22 @@ evalCommand output (Expression expr) state = do
...
@@ -885,17 +917,22 @@ evalCommand output (Expression expr) state = do
Display
disps
=
evalResult
evalOut
Display
disps
=
evalResult
evalOut
text
=
extractPlain
disps
text
=
extractPlain
disps
postprocess
(
DisplayData
MimeHtml
_
)
=
html
$
printf
fmt
unshowableType
(
formatErrorWithClass
"err-msg collapse"
text
)
script
postprocess
(
DisplayData
MimeHtml
_
)
=
html
$
printf
fmt
unshowableType
(
formatErrorWithClass
"err-msg collapse"
text
)
script
where
where
fmt
=
"<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
fmt
=
"<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
script
=
unlines
[
script
=
unlines
"$('#unshowable').on('click', function(e) {"
,
[
"$('#unshowable').on('click', function(e) {"
" e.preventDefault();"
,
,
" e.preventDefault();"
" var $this = $(this);"
,
,
" var $this = $(this);"
" var $collapse = $this.closest('.collapse-group').find('.err-msg');"
,
,
" var $collapse = $this.closest('.collapse-group').find('.err-msg');"
" $collapse.collapse('toggle');"
,
,
" $collapse.collapse('toggle');"
"});"
,
"});"
]
]
postprocess
other
=
other
postprocess
other
=
other
...
@@ -906,9 +943,8 @@ evalCommand output (Expression expr) state = do
...
@@ -906,9 +943,8 @@ evalCommand output (Expression expr) state = do
firstChar
<-
headMay
after
firstChar
<-
headMay
after
return
$
if
firstChar
==
'('
return
$
if
firstChar
==
'('
then
init
$
tail
after
then
init
$
tail
after
else
after
else
after
evalCommand
_
(
Declaration
decl
)
state
=
wrapExecution
state
$
do
evalCommand
_
(
Declaration
decl
)
state
=
wrapExecution
state
$
do
...
@@ -916,80 +952,75 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do
...
@@ -916,80 +952,75 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do
boundNames
<-
evalDeclarations
decl
boundNames
<-
evalDeclarations
decl
let
nonDataNames
=
filter
(
not
.
isUpper
.
head
)
boundNames
let
nonDataNames
=
filter
(
not
.
isUpper
.
head
)
boundNames
-- Display the types of all bound names if the option is on.
-- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
-- This is similar to GHCi :set +t.
if
not
$
useShowTypes
state
if
not
$
useShowTypes
state
then
return
mempty
then
return
mempty
else
do
else
do
-- Get all the type strings.
-- Get all the type strings.
dflags
<-
getSessionDynFlags
dflags
<-
getSessionDynFlags
types
<-
forM
nonDataNames
$
\
name
->
do
types
<-
forM
nonDataNames
$
\
name
->
do
theType
<-
showSDocUnqual
dflags
.
ppr
<$>
exprType
name
theType
<-
showSDocUnqual
dflags
.
ppr
<$>
exprType
name
return
$
name
++
" :: "
++
theType
return
$
name
++
" :: "
++
theType
return
$
Display
[
html
$
unlines
$
map
formatGetType
types
]
return
$
Display
[
html
$
unlines
$
map
formatGetType
types
]
evalCommand
_
(
TypeSignature
sig
)
state
=
wrapExecution
state
$
evalCommand
_
(
TypeSignature
sig
)
state
=
wrapExecution
state
$
-- We purposefully treat this as a "success" because that way execution
-- We purposefully treat this as a "success" because that way execution continues. Empty type
-- continues. Empty type signatures are likely due to a parse error later
-- signatures are likely due to a parse error later on, and we want that to be displayed.
-- on, and we want that to be displayed.
return
$
displayError
$
"The type signature "
++
sig
++
"
\n
lacks an accompanying binding."
return
$
displayError
$
"The type signature "
++
sig
++
"
\n
lacks an accompanying binding."
evalCommand
_
(
ParseError
loc
err
)
state
=
do
evalCommand
_
(
ParseError
loc
err
)
state
=
do
write
state
"Parse Error."
write
state
"Parse Error."
return
EvalOut
{
return
evalStatus
=
Failure
,
EvalOut
evalResult
=
displayError
$
formatParseError
loc
err
,
{
evalStatus
=
Failure
evalState
=
state
,
,
evalResult
=
displayError
$
formatParseError
loc
err
evalPager
=
""
,
,
evalState
=
state
evalComms
=
[]
,
evalPager
=
""
}
,
evalComms
=
[]
}
evalCommand
_
(
Pragma
(
PragmaUnsupported
pragmaType
)
pragmas
)
state
=
wrapExecution
state
$
evalCommand
_
(
Pragma
(
PragmaUnsupported
pragmaType
)
pragmas
)
state
=
wrapExecution
state
$
return
$
displayError
$
"Pragmas of type "
++
pragmaType
++
return
$
displayError
$
"Pragmas of type "
++
pragmaType
++
"
\n
are not supported."
"
\n
are not supported."
evalCommand
output
(
Pragma
PragmaLanguage
pragmas
)
state
=
do
evalCommand
output
(
Pragma
PragmaLanguage
pragmas
)
state
=
do
write
state
$
"Got LANGUAGE pragma "
++
show
pragmas
write
state
$
"Got LANGUAGE pragma "
++
show
pragmas
evalCommand
output
(
Directive
SetExtension
$
unwords
pragmas
)
state
evalCommand
output
(
Directive
SetExtension
$
unwords
pragmas
)
state
hoogleResults
::
KernelState
->
[
Hoogle
.
HoogleResult
]
->
EvalOut
hoogleResults
::
KernelState
->
[
Hoogle
.
HoogleResult
]
->
EvalOut
hoogleResults
state
results
=
EvalOut
{
hoogleResults
state
results
=
evalStatus
=
Success
,
EvalOut
evalResult
=
mempty
,
{
evalStatus
=
Success
evalState
=
state
,
,
evalResult
=
mempty
evalPager
=
output
,
,
evalState
=
state
evalComms
=
[]
,
evalPager
=
output
}
,
evalComms
=
[]
}
where
where
-- TODO: Make pager work with plaintext
-- TODO: Make pager work with plaintext
fmt
=
Hoogle
.
HTML
fmt
=
Hoogle
.
HTML
output
=
unlines
$
map
(
Hoogle
.
render
fmt
)
results
output
=
unlines
$
map
(
Hoogle
.
render
fmt
)
results
-- Read from a file handle until we hit a delimiter or until we've read
-- Read from a file handle until we hit a delimiter or until we've read
as many characters as
--
as many characters as
requested
-- requested
readChars
::
Handle
->
String
->
Int
->
IO
String
readChars
::
Handle
->
String
->
Int
->
IO
String
-- If we're done reading, return nothing.
-- If we're done reading, return nothing.
readChars
handle
delims
0
=
return
[]
readChars
handle
delims
0
=
return
[]
readChars
handle
delims
nchars
=
do
readChars
handle
delims
nchars
=
do
-- Try reading a single character. It will throw an exception if the
-- Try reading a single character. It will throw an exception if the handle is already closed.
-- handle is already closed.
tryRead
<-
gtry
$
hGetChar
handle
::
IO
(
Either
SomeException
Char
)
tryRead
<-
gtry
$
hGetChar
handle
::
IO
(
Either
SomeException
Char
)
case
tryRead
of
case
tryRead
of
Right
char
->
Right
char
->
-- If this is a delimiter, stop reading.
-- If this is a delimiter, stop reading.
if
char
`
elem
`
delims
if
char
`
elem
`
delims
then
return
[
char
]
then
return
[
char
]
else
do
else
do
next
<-
readChars
handle
delims
(
nchars
-
1
)
next
<-
readChars
handle
delims
(
nchars
-
1
)
return
$
char
:
next
return
$
char
:
next
-- An error occurs at the end of the stream, so just stop reading.
-- An error occurs at the end of the stream, so just stop reading.
Left
_
->
return
[]
Left
_
->
return
[]
doLoadModule
::
String
->
String
->
Ghc
Display
doLoadModule
::
String
->
String
->
Ghc
Display
doLoadModule
name
modName
=
do
doLoadModule
name
modName
=
do
-- Remember which modules we've loaded before.
-- Remember which modules we've loaded before.
...
@@ -998,13 +1029,7 @@ doLoadModule name modName = do
...
@@ -998,13 +1029,7 @@ doLoadModule name modName = do
flip
gcatch
(
unload
importedModules
)
$
do
flip
gcatch
(
unload
importedModules
)
$
do
-- Compile loaded modules.
-- Compile loaded modules.
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
setSessionDynFlags
flags
{
hscTarget
=
objTarget
flags
}
let
objTarget
=
defaultObjectTarget
platform
platform
=
targetPlatform
flags
#
else
let
objTarget
=
defaultObjectTarget
#
endif
setSessionDynFlags
flags
{
hscTarget
=
objTarget
}
-- Clear old targets to be sure.
-- Clear old targets to be sure.
setTargets
[]
setTargets
[]
...
@@ -1025,11 +1050,12 @@ doLoadModule name modName = do
...
@@ -1025,11 +1050,12 @@ doLoadModule name modName = do
-- Switch back to interpreted mode.
-- Switch back to interpreted mode.
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
setSessionDynFlags
flags
{
hscTarget
=
HscInterpreted
}
setSessionDynFlags
flags
{
hscTarget
=
HscInterpreted
}
case
result
of
case
result
of
Succeeded
->
return
mempty
Succeeded
->
return
mempty
Failed
->
return
$
displayError
$
"Failed to load module "
++
modName
Failed
->
return
$
displayError
$
"Failed to load module "
++
modName
where
where
unload
::
[
InteractiveImport
]
->
SomeException
->
Ghc
Display
unload
::
[
InteractiveImport
]
->
SomeException
->
Ghc
Display
unload
imported
exception
=
do
unload
imported
exception
=
do
...
@@ -1040,14 +1066,18 @@ doLoadModule name modName = do
...
@@ -1040,14 +1066,18 @@ doLoadModule name modName = do
-- Switch to interpreted mode!
-- Switch to interpreted mode!
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
setSessionDynFlags
flags
{
hscTarget
=
HscInterpreted
}
setSessionDynFlags
flags
{
hscTarget
=
HscInterpreted
}
-- Return to old context, make sure we have `it`.
-- Return to old context, make sure we have `it`.
setContext
imported
setContext
imported
initializeItVariable
initializeItVariable
return
$
displayError
$
"Failed to load module "
++
modName
++
": "
++
show
exception
return
$
displayError
$
"Failed to load module "
++
modName
++
": "
++
show
exception
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
objTarget
flags
=
defaultObjectTarget
$
targetPlatform
flags
#
else
objTarget
flags
=
defaultObjectTarget
#
endif
keepingItVariable
::
Interpreter
a
->
Interpreter
a
keepingItVariable
::
Interpreter
a
->
Interpreter
a
keepingItVariable
act
=
do
keepingItVariable
act
=
do
-- Generate the it variable temp name
-- Generate the it variable temp name
...
@@ -1066,89 +1096,84 @@ capturedStatement :: (String -> IO ()) -- ^ Function used to publish int
...
@@ -1066,89 +1096,84 @@ capturedStatement :: (String -> IO ()) -- ^ Function used to publish int
->
String
-- ^ Statement to evaluate.
->
String
-- ^ Statement to evaluate.
->
Interpreter
(
String
,
RunResult
)
-- ^ Return the output and result.
->
Interpreter
(
String
,
RunResult
)
-- ^ Return the output and result.
capturedStatement
output
stmt
=
do
capturedStatement
output
stmt
=
do
-- Generate random variable names to use so that we cannot accidentally
-- Generate random variable names to use so that we cannot accidentally
override the variables by
--
override the variables by
using the right names in the terminal.
-- using the right names in the terminal.
gen
<-
liftIO
getStdGen
gen
<-
liftIO
getStdGen
let
let
-- Variable names generation.
-- Variable names generation.
rand
=
take
20
$
randomRs
(
'0'
,
'9'
)
gen
rand
=
take
20
$
randomRs
(
'0'
,
'9'
)
gen
var
name
=
name
++
rand
var
name
=
name
++
rand
-- Variables for the pipe input and outputs.
-- Variables for the pipe input and outputs.
readVariable
=
var
"file_read_var_"
readVariable
=
var
"file_read_var_"
writeVariable
=
var
"file_write_var_"
writeVariable
=
var
"file_write_var_"
-- Variable where to store old stdout.
-- Variable where to store old stdout.
oldVariable
=
var
"old_var_"
oldVariable
=
var
"old_var_"
-- Variable used to store true `it` value.
-- Variable used to store true `it` value.
itVariable
=
var
"it_var_"
itVariable
=
var
"it_var_"
voidpf
str
=
printf
$
str
++
" IHaskellPrelude.>> IHaskellPrelude.return ()"
voidpf
str
=
printf
$
str
++
" IHaskellPrelude.>> IHaskellPrelude.return ()"
-- Statements run before the thing we're evaluating.
-- Statements run before the thing we're evaluating.
initStmts
=
initStmts
=
[
printf
"let %s = it"
itVariable
[
printf
"let %s = it"
itVariable
,
printf
"(%s, %s) <- IHaskellIO.createPipe"
readVariable
writeVariable
,
printf
"(%s, %s) <- IHaskellIO.createPipe"
readVariable
writeVariable
,
printf
"%s <- IHaskellIO.dup IHaskellIO.stdOutput"
oldVariable
,
printf
"%s <- IHaskellIO.dup IHaskellIO.stdOutput"
oldVariable
,
voidpf
"IHaskellIO.dupTo %s IHaskellIO.stdOutput"
writeVariable
,
voidpf
"IHaskellIO.dupTo %s IHaskellIO.stdOutput"
writeVariable
,
voidpf
"IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering"
,
voidpf
"IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering"
,
printf
"let it = %s"
itVariable
,
printf
"let it = %s"
itVariable
]
]
-- Statements run after evaluation.
-- Statements run after evaluation.
postStmts
=
postStmts
=
[
printf
"let %s = it"
itVariable
[
printf
"let %s = it"
itVariable
,
voidpf
"IHaskellSysIO.hFlush IHaskellSysIO.stdout"
,
voidpf
"IHaskellSysIO.hFlush IHaskellSysIO.stdout"
,
voidpf
"IHaskellIO.dupTo %s IHaskellIO.stdOutput"
oldVariable
,
voidpf
"IHaskellIO.dupTo %s IHaskellIO.stdOutput"
oldVariable
,
voidpf
"IHaskellIO.closeFd %s"
writeVariable
,
voidpf
"IHaskellIO.closeFd %s"
writeVariable
,
printf
"let it = %s"
itVariable
,
printf
"let it = %s"
itVariable
]
]
pipeExpr
=
printf
"let %s = %s"
(
var
"pipe_var_"
)
readVariable
pipeExpr
=
printf
"let %s = %s"
(
var
"pipe_var_"
)
readVariable
goStmt
::
String
->
Ghc
RunResult
goStmt
::
String
->
Ghc
RunResult
goStmt
s
=
runStmt
s
RunToCompletion
goStmt
s
=
runStmt
s
RunToCompletion
-- Initialize evaluation context.
-- Initialize evaluation context.
void
$
forM
initStmts
goStmt
void
$
forM
initStmts
goStmt
-- Get the pipe to read printed output from.
-- Get the pipe to read printed output from. This is effectively the source code of dynCompileExpr
-- This is effectively the source code of dynCompileExpr from GHC API's
-- from GHC API's InteractiveEval. However, instead of using a `Dynamic` as an intermediary, it just
-- InteractiveEval. However, instead of using a `Dynamic` as an
-- directly reads the value. This is incredibly unsafe! However, for some reason the `getContext`
-- intermediary, it just directly reads the value. This is incredibly
-- and `setContext` required by dynCompileExpr (to import and clear Data.Dynamic) cause issues with
-- unsafe! However, for some reason the `getContext` and `setContext`
-- data declarations being updated (e.g. it drops newer versions of data declarations for older ones
-- required by dynCompileExpr (to import and clear Data.Dynamic) cause
-- for unknown reasons). First, compile down to an HValue.
-- issues with data declarations being updated (e.g. it drops newer
-- versions of data declarations for older ones for unknown reasons).
-- First, compile down to an HValue.
Just
(
_
,
hValues
,
_
)
<-
withSession
$
liftIO
.
flip
hscStmt
pipeExpr
Just
(
_
,
hValues
,
_
)
<-
withSession
$
liftIO
.
flip
hscStmt
pipeExpr
-- Then convert the HValue into an executable bit, and read the value.
-- Then convert the HValue into an executable bit, and read the value.
pipe
<-
liftIO
$
do
pipe
<-
liftIO
$
do
fd
<-
head
<$>
unsafeCoerce
hValues
fd
<-
head
<$>
unsafeCoerce
hValues
fdToHandle
fd
fdToHandle
fd
-- Read from a file handle until we hit a delimiter or until we've read
-- Read from a file handle until we hit a delimiter or until we've read as many characters as
-- as many characters as requested
-- requested
let
let
readChars
::
Handle
->
String
->
Int
->
IO
String
readChars
::
Handle
->
String
->
Int
->
IO
String
-- If we're done reading, return nothing.
-- If we're done reading, return nothing.
readChars
handle
delims
0
=
return
[]
readChars
handle
delims
0
=
return
[]
readChars
handle
delims
nchars
=
do
readChars
handle
delims
nchars
=
do
-- Try reading a single character. It will throw an exception if the handle is already closed.
-- Try reading a single character. It will throw an exception if the
tryRead
<-
gtry
$
hGetChar
handle
::
IO
(
Either
SomeException
Char
)
-- handle is already closed.
case
tryRead
of
tryRead
<-
gtry
$
hGetChar
handle
::
IO
(
Either
SomeException
Char
)
Right
char
->
case
tryRead
of
-- If this is a delimiter, stop reading.
Right
char
->
if
char
`
elem
`
delims
-- If this is a delimiter, stop reading.
then
return
[
char
]
if
char
`
elem
`
delims
else
do
then
return
[
char
]
next
<-
readChars
handle
delims
(
nchars
-
1
)
else
do
return
$
char
:
next
next
<-
readChars
handle
delims
(
nchars
-
1
)
-- An error occurs at the end of the stream, so just stop reading.
return
$
char
:
next
Left
_
->
return
[]
-- An error occurs at the end of the stream, so just stop reading.
Left
_
->
return
[]
-- Keep track of whether execution has completed.
-- Keep track of whether execution has completed.
...
@@ -1157,53 +1182,52 @@ capturedStatement output stmt = do
...
@@ -1157,53 +1182,52 @@ capturedStatement output stmt = do
outputAccum
<-
liftIO
$
newMVar
""
outputAccum
<-
liftIO
$
newMVar
""
-- Start a loop to publish intermediate results.
-- Start a loop to publish intermediate results.
let
let
-- Compute how long to wait between reading pieces of the output.
-- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
-- `threadDelay` takes an
argument of microseconds.
--
argument of microseconds.
ms
=
1000
ms
=
1000
delay
=
100
*
ms
delay
=
100
*
ms
-- How much to read each time.
-- How much to read each time.
chunkSize
=
100
chunkSize
=
100
-- Maximum size of the output (after which we truncate).
-- Maximum size of the output (after which we truncate).
maxSize
=
100
*
1000
maxSize
=
100
*
1000
loop
=
do
loop
=
do
-- Wait and then check if the computation is done.
-- Wait and then check if the computation is done.
threadDelay
delay
threadDelay
delay
computationDone
<-
readMVar
completed
computationDone
<-
readMVar
completed
if
not
computationDone
if
not
computationDone
then
do
then
do
-- Read next chunk and append to accumulator.
-- Read next chunk and append to accumulator.
nextChunk
<-
readChars
pipe
"
\n
"
100
nextChunk
<-
readChars
pipe
"
\n
"
100
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
-- Write to frontend and repeat.
-- Write to frontend and repeat.
readMVar
outputAccum
>>=
output
readMVar
outputAccum
>>=
output
loop
loop
else
do
else
do
-- Read remainder of output and accumulate it.
-- Read remainder of output and accumulate it.
nextChunk
<-
readChars
pipe
""
maxSize
nextChunk
<-
readChars
pipe
""
maxSize
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
modifyMVar_
outputAccum
(
return
.
(
++
nextChunk
))
-- We're done reading.
-- We're done reading.
putMVar
finishedReading
True
putMVar
finishedReading
True
liftIO
$
forkIO
loop
liftIO
$
forkIO
loop
result
<-
gfinally
(
goStmt
stmt
)
$
do
result
<-
gfinally
(
goStmt
stmt
)
$
do
-- Execution is done.
-- Execution is done.
liftIO
$
modifyMVar_
completed
(
const
$
return
True
)
liftIO
$
modifyMVar_
completed
(
const
$
return
True
)
-- Finalize evaluation context.
-- Finalize evaluation context.
void
$
forM
postStmts
goStmt
void
$
forM
postStmts
goStmt
-- Once context is finalized, reading can finish.
-- Once context is finalized, reading can finish. Wait for reading to finish to that the output
-- Wait for reading to finish to that the output accumulator is
-- accumulator is completely filled.
-- completely filled.
liftIO
$
takeMVar
finishedReading
liftIO
$
takeMVar
finishedReading
printedOutput
<-
liftIO
$
readMVar
outputAccum
printedOutput
<-
liftIO
$
readMVar
outputAccum
return
(
printedOutput
,
result
)
return
(
printedOutput
,
result
)
...
@@ -1213,14 +1237,14 @@ formatError = formatErrorWithClass "err-msg"
...
@@ -1213,14 +1237,14 @@ formatError = formatErrorWithClass "err-msg"
formatErrorWithClass
::
String
->
ErrMsg
->
String
formatErrorWithClass
::
String
->
ErrMsg
->
String
formatErrorWithClass
cls
=
formatErrorWithClass
cls
=
printf
"<span class='%s'>%s</span>"
cls
.
printf
"<span class='%s'>%s</span>"
cls
.
replace
"
\n
"
"<br/>"
.
replace
"
\n
"
"<br/>"
.
replace
useDashV
""
.
replace
useDashV
""
.
replace
"Ghci"
"IHaskell"
.
replace
"Ghci"
"IHaskell"
.
replace
"‘interactive:"
"‘"
.
replace
"‘interactive:"
"‘"
.
fixDollarSigns
.
fixDollarSigns
.
rstrip
.
rstrip
.
typeCleaner
typeCleaner
where
where
fixDollarSigns
=
replace
"$"
"<span>$</span>"
fixDollarSigns
=
replace
"$"
"<span>$</span>"
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."
...
@@ -1228,7 +1252,6 @@ formatErrorWithClass cls =
...
@@ -1228,7 +1252,6 @@ formatErrorWithClass cls =
startswith
"No instance for (Show"
err
&&
startswith
"No instance for (Show"
err
&&
isInfixOf
" arising from a use of `print'"
err
isInfixOf
" arising from a use of `print'"
err
formatParseError
::
StringLoc
->
String
->
ErrMsg
formatParseError
::
StringLoc
->
String
->
ErrMsg
formatParseError
(
Loc
line
col
)
=
formatParseError
(
Loc
line
col
)
=
printf
"Parse error (line %d, column %d): %s"
line
col
printf
"Parse error (line %d, column %d): %s"
line
col
...
@@ -1237,7 +1260,7 @@ formatGetType :: String -> String
...
@@ -1237,7 +1260,7 @@ formatGetType :: String -> String
formatGetType
=
printf
"<span class='get-type'>%s</span>"
formatGetType
=
printf
"<span class='get-type'>%s</span>"
formatType
::
String
->
Display
formatType
::
String
->
Display
formatType
typeStr
=
Display
[
plain
typeStr
,
html
$
formatGetType
typeStr
]
formatType
typeStr
=
Display
[
plain
typeStr
,
html
$
formatGetType
typeStr
]
displayError
::
ErrMsg
->
Display
displayError
::
ErrMsg
->
Display
displayError
msg
=
Display
[
plain
.
typeCleaner
$
msg
,
html
$
formatError
msg
]
displayError
msg
=
Display
[
plain
.
typeCleaner
$
msg
,
html
$
formatError
msg
]
...
...
src/IHaskell/Eval/Hoogle.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
module
IHaskell.Eval.Hoogle
(
module
IHaskell.Eval.Hoogle
(
search
,
search
,
document
,
document
,
render
,
render
,
OutputFormat
(
..
),
OutputFormat
(
..
),
HoogleResult
HoogleResult
,
)
where
)
where
import
ClassyPrelude
hiding
(
last
,
span
,
div
)
import
ClassyPrelude
hiding
(
last
,
span
,
div
)
import
Text.Printf
import
Text.Printf
import
Network.HTTP.Client
import
Network.HTTP.Client
import
Network.HTTP.Client.TLS
import
Network.HTTP.Client.TLS
import
Data.Aeson
import
Data.Aeson
import
Data.String.Utils
import
Data.String.Utils
import
Data.List
(
elemIndex
,
(
!!
),
last
)
import
Data.List
(
elemIndex
,
(
!!
),
last
)
import
Data.Char
(
isAscii
,
isAlphaNum
)
import
Data.Char
(
isAscii
,
isAlphaNum
)
import
qualified
Data.ByteString.Lazy.Char8
as
Char
import
qualified
Data.ByteString.Lazy.Char8
as
Char
import
qualified
Prelude
as
P
import
qualified
Prelude
as
P
import
IHaskell.IPython
import
IHaskell.IPython
-- | Types of formats to render output to.
-- | Types of formats to render output to.
data
OutputFormat
data
OutputFormat
=
Plain
-- ^ Render to plain text.
=
Plain
-- ^ Render to plain text.
|
HTML
-- ^ Render to HTML.
|
HTML
-- ^ Render to HTML.
data
HoogleResponse
=
HoogleResponse
{
location
::
String
,
self
::
String
,
docs
::
String
}
data
HoogleResponse
=
HoogleResponse
{
location
::
String
,
self
::
String
,
docs
::
String
}
deriving
(
Eq
,
Show
)
deriving
(
Eq
,
Show
)
data
HoogleResult
data
HoogleResult
=
SearchResult
HoogleResponse
=
SearchResult
HoogleResponse
|
DocResult
HoogleResponse
|
DocResult
HoogleResponse
|
NoResult
String
|
NoResult
String
deriving
Show
deriving
Show
instance
FromJSON
[
HoogleResponse
]
where
instance
FromJSON
[
HoogleResponse
]
where
parseJSON
(
Object
obj
)
=
do
parseJSON
(
Object
obj
)
=
do
...
@@ -48,81 +43,80 @@ instance FromJSON [HoogleResponse] where
...
@@ -48,81 +43,80 @@ instance FromJSON [HoogleResponse] where
instance
FromJSON
HoogleResponse
where
instance
FromJSON
HoogleResponse
where
parseJSON
(
Object
obj
)
=
parseJSON
(
Object
obj
)
=
HoogleResponse
<$>
HoogleResponse
<$>
obj
.:
"location"
<*>
obj
.:
"self"
<*>
obj
.:
"docs"
obj
.:
"location"
<*>
obj
.:
"self"
<*>
obj
.:
"docs"
parseJSON
_
=
fail
"Expected object with fields: location, self, docs"
parseJSON
_
=
fail
"Expected object with fields: location, self, docs"
-- | Query Hoogle for the given string.
-- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
-- This searches Hoogle using the internet. It returns either an error
-- an error message or the successful JSON result.
-- message or the successful JSON result.
query
::
String
->
IO
(
Either
String
String
)
query
::
String
->
IO
(
Either
String
String
)
query
str
=
do
query
str
=
do
request
<-
parseUrl
$
queryUrl
$
urlEncode
str
request
<-
parseUrl
$
queryUrl
$
urlEncode
str
response
<-
try
$
withManager
tlsManagerSettings
$
httpLbs
request
response
<-
try
$
withManager
tlsManagerSettings
$
httpLbs
request
return
$
case
response
of
return
$
Left
err
->
Left
$
show
(
err
::
SomeException
)
case
response
of
Right
resp
->
Right
$
Char
.
unpack
$
responseBody
resp
Left
err
->
Left
$
show
(
err
::
SomeException
)
Right
resp
->
Right
$
Char
.
unpack
$
responseBody
resp
where
where
queryUrl
::
String
->
String
queryUrl
::
String
->
String
queryUrl
=
printf
"https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
queryUrl
=
printf
"https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
-- | Copied from the HTTP package.
-- | Copied from the HTTP package.
urlEncode
::
String
->
String
urlEncode
::
String
->
String
urlEncode
[]
=
[]
urlEncode
[]
=
[]
urlEncode
(
ch
:
t
)
urlEncode
(
ch
:
t
)
|
(
isAscii
ch
&&
isAlphaNum
ch
)
||
ch
`
P
.
elem
`
"-_.~"
=
ch
:
urlEncode
t
|
(
isAscii
ch
&&
isAlphaNum
ch
)
||
ch
`
P
.
elem
`
"-_.~"
=
ch
:
urlEncode
t
|
not
(
isAscii
ch
)
=
P
.
foldr
escape
(
urlEncode
t
)
(
eightBs
[]
(
P
.
fromEnum
ch
))
|
not
(
isAscii
ch
)
=
P
.
foldr
escape
(
urlEncode
t
)
(
eightBs
[]
(
P
.
fromEnum
ch
))
|
otherwise
=
escape
(
P
.
fromEnum
ch
)
(
urlEncode
t
)
|
otherwise
=
escape
(
P
.
fromEnum
ch
)
(
urlEncode
t
)
where
where
escape
::
Int
->
String
->
String
escape
::
Int
->
String
->
String
escape
b
rs
=
'%'
:
showH
(
b
`
P
.
div
`
16
)
(
showH
(
b
`
mod
`
16
)
rs
)
escape
b
rs
=
'%'
:
showH
(
b
`
P
.
div
`
16
)
(
showH
(
b
`
mod
`
16
)
rs
)
showH
::
Int
->
String
->
String
showH
::
Int
->
String
->
String
showH
x
xs
showH
x
xs
|
x
<=
9
=
toEnum
(
o_0
+
x
)
:
xs
|
x
<=
9
=
toEnum
(
o_0
+
x
)
:
xs
|
otherwise
=
toEnum
(
o_A
+
(
x
-
10
))
:
xs
|
otherwise
=
toEnum
(
o_A
+
(
x
-
10
))
:
xs
where
where
o_0
=
P
.
fromEnum
'0'
o_0
=
P
.
fromEnum
'0'
o_A
=
P
.
fromEnum
'A'
o_A
=
P
.
fromEnum
'A'
eightBs
::
[
Int
]
->
Int
->
[
Int
]
eightBs
::
[
Int
]
->
Int
->
[
Int
]
eightBs
acc
x
eightBs
acc
x
|
x
<=
0xff
=
(
x
:
acc
)
|
x
<=
255
=
x
:
acc
|
otherwise
=
eightBs
((
x
`
mod
`
256
)
:
acc
)
(
x
`
P
.
div
`
256
)
|
otherwise
=
eightBs
((
x
`
mod
`
256
)
:
acc
)
(
x
`
P
.
div
`
256
)
-- | Search for a query on Hoogle.
-- | Search for a query on Hoogle. Return all search results.
-- Return all search results.
search
::
String
->
IO
[
HoogleResult
]
search
::
String
->
IO
[
HoogleResult
]
search
string
=
do
search
string
=
do
response
<-
query
string
response
<-
query
string
return
$
case
response
of
return
$
Left
err
->
[
NoResult
err
]
case
response
of
Right
json
->
Left
err
->
[
NoResult
err
]
case
eitherDecode
$
Char
.
pack
json
of
Right
json
->
Left
err
->
[
NoResult
err
]
case
eitherDecode
$
Char
.
pack
json
of
Right
results
->
Left
err
->
[
NoResult
err
]
case
map
SearchResult
results
of
Right
results
->
[]
->
[
NoResult
"no matching identifiers found."
]
case
map
SearchResult
results
of
res
->
res
[]
->
[
NoResult
"no matching identifiers found."
]
res
->
res
-- | Look up an identifier on Hoogle.
-- Return documentation for that identifier. If there are many
--
| Look up an identifier on Hoogle.
Return documentation for that identifier. If there are many
-- identifiers, include documentation for all of them.
-- identifiers, include documentation for all of them.
document
::
String
->
IO
[
HoogleResult
]
document
::
String
->
IO
[
HoogleResult
]
document
string
=
do
document
string
=
do
matchingResults
<-
filter
matches
<$>
search
string
matchingResults
<-
filter
matches
<$>
search
string
let
results
=
map
toDocResult
matchingResults
let
results
=
map
toDocResult
matchingResults
return
$
case
results
of
return
$
[]
->
[
NoResult
"no matching identifiers found."
]
case
results
of
res
->
res
[]
->
[
NoResult
"no matching identifiers found."
]
res
->
res
where
where
matches
(
SearchResult
resp
)
=
matches
(
SearchResult
resp
)
=
case
split
" "
$
self
resp
of
case
split
" "
$
self
resp
of
name
:
_
->
strip
string
==
strip
name
name
:
_
->
strip
string
==
strip
name
_
->
False
_
->
False
matches
_
=
False
matches
_
=
False
toDocResult
(
SearchResult
resp
)
=
DocResult
resp
toDocResult
(
SearchResult
resp
)
=
DocResult
resp
...
@@ -130,25 +124,18 @@ document string = do
...
@@ -130,25 +124,18 @@ document string = do
-- | Render a Hoogle search result into an output format.
-- | Render a Hoogle search result into an output format.
render
::
OutputFormat
->
HoogleResult
->
String
render
::
OutputFormat
->
HoogleResult
->
String
render
Plain
=
renderPlain
render
Plain
=
renderPlain
render
HTML
=
renderHtml
render
HTML
=
renderHtml
-- | Render a Hoogle result to plain text.
-- | Render a Hoogle result to plain text.
renderPlain
::
HoogleResult
->
String
renderPlain
::
HoogleResult
->
String
renderPlain
(
NoResult
res
)
=
renderPlain
(
NoResult
res
)
=
"No response available: "
++
res
"No response available: "
++
res
renderPlain
(
SearchResult
resp
)
=
renderPlain
(
SearchResult
resp
)
=
printf
"%s
\n
URL: %s
\n
%s"
printf
"%s
\n
URL: %s
\n
%s"
(
self
resp
)
(
location
resp
)
(
docs
resp
)
(
self
resp
)
(
location
resp
)
(
docs
resp
)
renderPlain
(
DocResult
resp
)
=
renderPlain
(
DocResult
resp
)
=
printf
"%s
\n
URL: %s
\n
%s"
printf
"%s
\n
URL: %s
\n
%s"
(
self
resp
)
(
location
resp
)
(
docs
resp
)
(
self
resp
)
(
location
resp
)
(
docs
resp
)
-- | Render a Hoogle result to HTML.
-- | Render a Hoogle result to HTML.
renderHtml
::
HoogleResult
->
String
renderHtml
::
HoogleResult
->
String
...
@@ -167,37 +154,37 @@ renderHtml (SearchResult resp) =
...
@@ -167,37 +154,37 @@ renderHtml (SearchResult resp) =
renderSelf
::
String
->
String
->
String
renderSelf
::
String
->
String
->
String
renderSelf
string
loc
renderSelf
string
loc
|
startswith
"package"
string
|
startswith
"package"
string
=
=
pkg
++
" "
++
span
"hoogle-package"
(
link
loc
$
extractPackage
string
)
pkg
++
" "
++
span
"hoogle-package"
(
link
loc
$
extractPackage
string
)
|
startswith
"module"
string
|
startswith
"module"
string
=
=
let
package
=
extractPackageName
loc
in
let
package
=
extractPackageName
loc
mod
++
" "
++
in
mod
++
" "
++
span
"hoogle-module"
(
link
loc
$
extractModule
string
)
++
span
"hoogle-module"
(
link
loc
$
extractModule
string
)
++
packageSub
package
packageSub
package
|
startswith
"class"
string
|
startswith
"class"
string
=
=
let
package
=
extractPackageName
loc
in
let
package
=
extractPackageName
loc
cls
++
" "
++
in
cls
++
" "
++
span
"hoogle-class"
(
link
loc
$
extractClass
string
)
++
span
"hoogle-class"
(
link
loc
$
extractClass
string
)
++
packageSub
package
packageSub
package
|
startswith
"data"
string
|
startswith
"data"
string
=
=
let
package
=
extractPackageName
loc
in
let
package
=
extractPackageName
loc
dat
++
" "
++
in
dat
++
" "
++
span
"hoogle-class"
(
link
loc
$
extractData
string
)
++
span
"hoogle-class"
(
link
loc
$
extractData
string
)
++
packageSub
package
packageSub
package
|
otherwise
|
otherwise
=
=
let
[
name
,
args
]
=
split
"::"
string
let
[
name
,
args
]
=
split
"::"
string
package
=
extractPackageName
loc
package
=
extractPackageName
loc
modname
=
extractModuleName
loc
in
modname
=
extractModuleName
loc
span
"hoogle-name"
(
unicodeReplace
$
in
span
"hoogle-name"
link
loc
(
strip
name
)
++
(
unicodeReplace
$
" :: "
++
link
loc
(
strip
name
)
++
strip
args
)
" :: "
++
++
packageAndModuleSub
package
modname
strip
args
)
++
packageAndModuleSub
package
modname
where
where
extractPackage
=
strip
.
replace
"package"
""
extractPackage
=
strip
.
replace
"package"
""
extractModule
=
strip
.
replace
"module"
""
extractModule
=
strip
.
replace
"module"
""
...
@@ -210,10 +197,10 @@ renderSelf string loc
...
@@ -210,10 +197,10 @@ renderSelf string loc
unicodeReplace
::
String
->
String
unicodeReplace
::
String
->
String
unicodeReplace
=
unicodeReplace
=
replace
"forall"
"∀"
.
replace
"forall"
"∀"
.
replace
"=>"
"⇒"
.
replace
"=>"
"⇒"
.
replace
"->"
"→"
.
replace
"->"
"→"
.
replace
"::"
"∷"
replace
"::"
"∷"
packageSub
Nothing
=
""
packageSub
Nothing
=
""
packageSub
(
Just
package
)
=
packageSub
(
Just
package
)
=
...
@@ -223,26 +210,25 @@ renderSelf string loc
...
@@ -223,26 +210,25 @@ renderSelf string loc
packageAndModuleSub
Nothing
_
=
""
packageAndModuleSub
Nothing
_
=
""
packageAndModuleSub
(
Just
package
)
Nothing
=
packageSub
(
Just
package
)
packageAndModuleSub
(
Just
package
)
Nothing
=
packageSub
(
Just
package
)
packageAndModuleSub
(
Just
package
)
(
Just
modname
)
=
packageAndModuleSub
(
Just
package
)
(
Just
modname
)
=
span
"hoogle-sub"
$
span
"hoogle-sub"
$
"("
++
pkg
++
" "
++
span
"hoogle-package"
package
++
"("
++
pkg
++
" "
++
span
"hoogle-package"
package
++
", "
++
mod
++
" "
++
span
"hoogle-module"
modname
++
")"
", "
++
mod
++
" "
++
span
"hoogle-module"
modname
++
")"
renderDocs
::
String
->
String
renderDocs
::
String
->
String
renderDocs
doc
=
renderDocs
doc
=
let
groups
=
groupBy
bothAreCode
$
lines
doc
let
groups
=
groupBy
bothAreCode
$
lines
doc
nonull
=
filter
(
not
.
null
.
strip
)
nonull
=
filter
(
not
.
null
.
strip
)
bothAreCode
s1
s2
=
bothAreCode
s1
s2
=
startswith
">"
(
strip
s1
)
&&
startswith
">"
(
strip
s1
)
&&
startswith
">"
(
strip
s2
)
startswith
">"
(
strip
s2
)
isCode
(
s
:
_
)
=
startswith
">"
$
strip
s
isCode
(
s
:
_
)
=
startswith
">"
$
strip
s
makeBlock
lines
=
makeBlock
lines
=
if
isCode
lines
if
isCode
lines
then
div
"hoogle-code"
$
unlines
$
nonull
lines
then
div
"hoogle-code"
$
unlines
$
nonull
lines
else
div
"hoogle-text"
$
unlines
$
nonull
lines
else
div
"hoogle-text"
$
unlines
$
nonull
lines
in
in
div
"hoogle-doc"
$
unlines
$
map
makeBlock
groups
div
"hoogle-doc"
$
unlines
$
map
makeBlock
groups
extractPackageName
::
String
->
Maybe
String
extractPackageName
::
String
->
Maybe
String
extractPackageName
link
=
do
extractPackageName
link
=
do
let
pieces
=
split
"/"
link
let
pieces
=
split
"/"
link
archiveLoc
<-
elemIndex
"archive"
pieces
archiveLoc
<-
elemIndex
"archive"
pieces
...
@@ -250,7 +236,7 @@ extractPackageName link = do
...
@@ -250,7 +236,7 @@ extractPackageName link = do
guard
$
latestLoc
-
archiveLoc
==
2
guard
$
latestLoc
-
archiveLoc
==
2
return
$
pieces
!!
(
latestLoc
-
1
)
return
$
pieces
!!
(
latestLoc
-
1
)
extractModuleName
::
String
->
Maybe
String
extractModuleName
::
String
->
Maybe
String
extractModuleName
link
=
do
extractModuleName
link
=
do
let
pieces
=
split
"/"
link
let
pieces
=
split
"/"
link
guard
$
not
$
null
pieces
guard
$
not
$
null
pieces
...
...
src/IHaskell/Eval/Info.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-}
module
IHaskell.Eval.Info
(
info
)
where
import
ClassyPrelude
hiding
(
liftIO
)
{- | Description : Inspect type and function information and documentation. -}
module
IHaskell.Eval.Info
(
info
)
where
import
IHaskell.Eval.Evaluate
(
typeCleaner
,
Interpreter
)
import
ClassyPrelude
hiding
(
liftIO
)
import
GHC
import
IHaskell.Eval.Evaluate
(
typeCleaner
,
Interpreter
)
import
Outputable
import
Exception
import
GHC
import
Outputable
import
Exception
info
::
String
->
Interpreter
String
info
::
String
->
Interpreter
String
info
name
=
ghandle
handler
$
do
info
name
=
ghandle
handler
$
do
dflags
<-
getSessionDynFlags
dflags
<-
getSessionDynFlags
result
<-
exprType
name
result
<-
exprType
name
return
$
typeCleaner
$
showPpr
dflags
result
return
$
typeCleaner
$
showPpr
dflags
result
where
where
handler
::
SomeException
->
Interpreter
String
handler
::
SomeException
->
Interpreter
String
handler
_
=
return
""
handler
_
=
return
""
src/IHaskell/Eval/Lint.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module
IHaskell.Eval.Lint
(
lint
module
IHaskell.Eval.Lint
(
lint
)
where
)
where
import
Data.String.Utils
(
replace
,
startswith
,
strip
,
split
)
import
Data.String.Utils
(
replace
,
startswith
,
strip
,
split
)
import
Prelude
(
head
,
tail
,
last
)
import
Prelude
(
head
,
tail
,
last
)
import
ClassyPrelude
hiding
(
last
)
import
ClassyPrelude
hiding
(
last
)
import
Control.Monad
import
Control.Monad
import
Data.List
(
findIndex
)
import
Data.List
(
findIndex
)
import
Text.Printf
import
Text.Printf
import
Data.String.Here
import
Data.String.Here
import
Data.Char
import
Data.Char
import
Data.Monoid
import
Data.Monoid
import
Data.Maybe
(
mapMaybe
)
import
Data.Maybe
(
mapMaybe
)
import
System.IO.Unsafe
(
unsafePerformIO
)
import
System.IO.Unsafe
(
unsafePerformIO
)
import
Language.Haskell.Exts.Annotated.Syntax
hiding
(
Module
)
import
Language.Haskell.Exts.Annotated.Syntax
hiding
(
Module
)
import
qualified
Language.Haskell.Exts.Annotated.Syntax
as
SrcExts
import
qualified
Language.Haskell.Exts.Annotated.Syntax
as
SrcExts
import
Language.Haskell.Exts.Annotated
(
parseFileContentsWithMode
)
import
Language.Haskell.Exts.Annotated
(
parseFileContentsWithMode
)
import
Language.Haskell.Exts.Annotated.Build
(
doE
)
import
Language.Haskell.Exts.Annotated.Build
(
doE
)
import
Language.Haskell.Exts.Annotated
hiding
(
Module
)
import
Language.Haskell.Exts.Annotated
hiding
(
Module
)
import
Language.Haskell.Exts.SrcLoc
import
Language.Haskell.Exts.SrcLoc
import
Language.Haskell.HLint
as
HLint
import
Language.Haskell.HLint
as
HLint
import
Language.Haskell.HLint2
import
Language.Haskell.HLint2
import
IHaskell.Types
import
IHaskell.Types
import
IHaskell.Display
import
IHaskell.Display
import
IHaskell.IPython
import
IHaskell.IPython
import
IHaskell.Eval.Parser
hiding
(
line
)
import
IHaskell.Eval.Parser
hiding
(
line
)
type
ExtsModule
=
SrcExts
.
Module
SrcSpanInfo
type
ExtsModule
=
SrcExts
.
Module
SrcSpanInfo
data
LintSuggestion
data
LintSuggestion
=
=
Suggest
{
Suggest
line
::
LineNumber
,
{
line
::
LineNumber
found
::
String
,
,
found
::
String
whyNot
::
String
,
,
whyNot
::
String
severity
::
Severity
,
,
severity
::
Severity
suggestion
::
String
,
suggestion
::
String
}
}
deriving
(
Eq
,
Show
)
deriving
(
Eq
,
Show
)
-- Store settings for Hlint once it's initialized.
-- Store settings for Hlint once it's initialized.
...
@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
...
@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
lintIdent
::
String
lintIdent
::
String
lintIdent
=
"lintIdentAEjlkQeh"
lintIdent
=
"lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable
-- | Given parsed code chunks, perform linting and output a displayable
report on linting warnings
--
report on linting warnings
and errors.
-- and errors.
lint
::
[
Located
CodeBlock
]
->
IO
Display
lint
::
[
Located
CodeBlock
]
->
IO
Display
lint
blocks
=
do
lint
blocks
=
do
-- Initialize hlint settings
-- Initialize hlint settings
...
@@ -66,63 +65,62 @@ lint blocks = do
...
@@ -66,63 +65,62 @@ lint blocks = do
-- create 'suggestions'
-- create 'suggestions'
let
modules
=
mapMaybe
(
createModule
mode
)
blocks
let
modules
=
mapMaybe
(
createModule
mode
)
blocks
ideas
=
applyHints
classify
hint
(
map
(
\
m
->
(
m
,
[]
))
modules
)
ideas
=
applyHints
classify
hint
(
map
(
\
m
->
(
m
,
[]
))
modules
)
suggestions
=
mapMaybe
showIdea
ideas
suggestions
=
mapMaybe
showIdea
ideas
return
$
Display
$
return
$
Display
$
if
null
suggestions
if
null
suggestions
then
[]
then
[]
else
else
[
plain
$
concatMap
plainSuggestion
suggestions
,
html
$
htmlSuggestions
suggestions
]
[
plain
$
concatMap
plainSuggestion
suggestions
,
html
$
htmlSuggestions
suggestions
]
showIdea
::
Idea
->
Maybe
LintSuggestion
showIdea
::
Idea
->
Maybe
LintSuggestion
showIdea
idea
=
showIdea
idea
=
case
ideaTo
idea
of
case
ideaTo
idea
of
Nothing
->
Nothing
Nothing
->
Nothing
Just
whyNot
->
Just
Suggest
{
Just
whyNot
->
Just
line
=
srcSpanStartLine
$
ideaSpan
idea
,
Suggest
found
=
showSuggestion
$
ideaFrom
idea
,
{
line
=
srcSpanStartLine
$
ideaSpan
idea
whyNot
=
showSuggestion
whyNot
,
,
found
=
showSuggestion
$
ideaFrom
idea
severity
=
ideaSeverity
idea
,
,
whyNot
=
showSuggestion
whyNot
suggestion
=
ideaHint
idea
,
severity
=
ideaSeverity
idea
}
,
suggestion
=
ideaHint
idea
}
createModule
::
ParseMode
->
Located
CodeBlock
->
Maybe
ExtsModule
createModule
::
ParseMode
->
Located
CodeBlock
->
Maybe
ExtsModule
createModule
mode
(
Located
line
block
)
=
createModule
mode
(
Located
line
block
)
=
case
block
of
case
block
of
Expression
expr
->
unparse
$
exprToModule
expr
Expression
expr
->
unparse
$
exprToModule
expr
Declaration
decl
->
unparse
$
declToModule
decl
Declaration
decl
->
unparse
$
declToModule
decl
Statement
stmt
->
unparse
$
stmtToModule
stmt
Statement
stmt
->
unparse
$
stmtToModule
stmt
Import
impt
->
unparse
$
imptToModule
impt
Import
impt
->
unparse
$
imptToModule
impt
Module
mod
->
unparse
$
parseModule
mod
Module
mod
->
unparse
$
parseModule
mod
_
->
Nothing
_
->
Nothing
where
where
blockStr
=
blockStr
=
case
block
of
case
block
of
Expression
expr
->
expr
Expression
expr
->
expr
Declaration
decl
->
decl
Declaration
decl
->
decl
Statement
stmt
->
stmt
Statement
stmt
->
stmt
Import
impt
->
impt
Import
impt
->
impt
Module
mod
->
mod
Module
mod
->
mod
unparse
::
ParseResult
a
->
Maybe
a
unparse
::
ParseResult
a
->
Maybe
a
unparse
(
ParseOk
a
)
=
Just
a
unparse
(
ParseOk
a
)
=
Just
a
unparse
_
=
Nothing
unparse
_
=
Nothing
srcSpan
::
SrcSpan
srcSpan
::
SrcSpan
srcSpan
=
SrcSpan
{
srcSpan
=
SrcSpan
srcSpanFilename
=
"<interactive>"
,
{
srcSpanFilename
=
"<interactive>"
srcSpanStartLine
=
line
,
,
srcSpanStartLine
=
line
srcSpanStartColumn
=
0
,
,
srcSpanStartColumn
=
0
srcSpanEndLine
=
line
+
length
(
lines
blockStr
),
,
srcSpanEndLine
=
line
+
length
(
lines
blockStr
)
srcSpanEndColumn
=
length
$
last
$
lines
blockStr
,
srcSpanEndColumn
=
length
$
last
$
lines
blockStr
}
}
loc
::
SrcSpanInfo
loc
::
SrcSpanInfo
loc
=
SrcSpanInfo
srcSpan
[]
loc
=
SrcSpanInfo
srcSpan
[]
moduleWithDecls
::
Decl
SrcSpanInfo
->
ExtsModule
moduleWithDecls
::
Decl
SrcSpanInfo
->
ExtsModule
moduleWithDecls
decl
=
SrcExts
.
Module
loc
Nothing
[]
[]
[
decl
]
moduleWithDecls
decl
=
SrcExts
.
Module
loc
Nothing
[]
[]
[
decl
]
parseModule
::
String
->
ParseResult
ExtsModule
parseModule
::
String
->
ParseResult
ExtsModule
...
@@ -135,9 +133,10 @@ createModule mode (Located line block) =
...
@@ -135,9 +133,10 @@ createModule mode (Located line block) =
exprToModule
exp
=
moduleWithDecls
<$>
SpliceDecl
loc
<$>
parseExpWithMode
mode
exp
exprToModule
exp
=
moduleWithDecls
<$>
SpliceDecl
loc
<$>
parseExpWithMode
mode
exp
stmtToModule
::
String
->
ParseResult
ExtsModule
stmtToModule
::
String
->
ParseResult
ExtsModule
stmtToModule
stmtStr
=
case
parseStmtWithMode
mode
stmtStr
of
stmtToModule
stmtStr
=
ParseOk
stmt
->
ParseOk
mod
case
parseStmtWithMode
mode
stmtStr
of
ParseFailed
a
b
->
ParseFailed
a
b
ParseOk
stmt
->
ParseOk
mod
ParseFailed
a
b
->
ParseFailed
a
b
where
where
mod
=
moduleWithDecls
decl
mod
=
moduleWithDecls
decl
...
@@ -157,35 +156,31 @@ createModule mode (Located line block) =
...
@@ -157,35 +156,31 @@ createModule mode (Located line block) =
imptToModule
=
parseFileContentsWithMode
mode
imptToModule
=
parseFileContentsWithMode
mode
plainSuggestion
::
LintSuggestion
->
String
plainSuggestion
::
LintSuggestion
->
String
plainSuggestion
suggest
=
plainSuggestion
suggest
=
printf
"Line %d: %s
\n
Found:
\n
%s
\n
Why not:
\n
%s"
printf
"Line %d: %s
\n
Found:
\n
%s
\n
Why not:
\n
%s"
(
line
suggest
)
(
suggestion
suggest
)
(
found
suggest
)
(
line
suggest
)
(
suggestion
suggest
)
(
found
suggest
)
(
whyNot
suggest
)
(
whyNot
suggest
)
htmlSuggestions
::
[
LintSuggestion
]
->
String
htmlSuggestions
::
[
LintSuggestion
]
->
String
htmlSuggestions
=
concatMap
toHtml
htmlSuggestions
=
concatMap
toHtml
where
where
toHtml
::
LintSuggestion
->
String
toHtml
::
LintSuggestion
->
String
toHtml
suggest
=
concat
toHtml
suggest
=
concat
[
[
named
$
suggestion
suggest
named
$
suggestion
suggest
,
,
floating
"left"
$
style
severityClass
"Found:"
++
floating
"left"
$
style
severityClass
"Found:"
++
-- Things that look like this get highlighted.
-- Things that look like this get highlighted.
styleId
"highlight-code"
"haskell"
(
found
suggest
)
styleId
"highlight-code"
"haskell"
(
found
suggest
),
,
floating
"left"
$
style
severityClass
"Why Not:"
++
floating
"left"
$
style
severityClass
"Why Not:"
++
-- Things that look like this get highlighted.
-- Things that look like this get highlighted.
styleId
"highlight-code"
"haskell"
(
whyNot
suggest
)
styleId
"highlight-code"
"haskell"
(
whyNot
suggest
)
]
]
where
where
severityClass
=
case
severity
suggest
of
severityClass
=
Error
->
"error"
case
severity
suggest
of
Warning
->
"warning"
Error
->
"error"
Warning
->
"warning"
-- Should not occur
-- Should not occur
_
->
"warning"
_
->
"warning"
style
::
String
->
String
->
String
style
::
String
->
String
->
String
style
cls
thing
=
[
i
|
<div class="suggestion-${cls}">${thing}</div>
|]
style
cls
thing
=
[
i
|
<div class="suggestion-${cls}">${thing}</div>
|]
...
@@ -195,37 +190,32 @@ htmlSuggestions = concatMap toHtml
...
@@ -195,37 +190,32 @@ htmlSuggestions = concatMap toHtml
styleId
::
String
->
String
->
String
->
String
styleId
::
String
->
String
->
String
->
String
styleId
cls
id
thing
=
[
i
|
<div class="${cls}" id="${id}">${thing}</div>
|]
styleId
cls
id
thing
=
[
i
|
<div class="${cls}" id="${id}">${thing}</div>
|]
floating
::
String
->
String
->
String
floating
::
String
->
String
->
String
floating
dir
thing
=
[
i
|
<div class="suggestion-row" style="float: ${dir};">${thing}</div>
|]
floating
dir
thing
=
[
i
|
<div class="suggestion-row" style="float: ${dir};">${thing}</div>
|]
showSuggestion
::
String
->
String
showSuggestion
::
String
->
String
showSuggestion
=
remove
lintIdent
.
dropDo
showSuggestion
=
remove
lintIdent
.
dropDo
where
where
remove
str
=
replace
str
""
remove
str
=
replace
str
""
-- Drop leading ' do ', and blank spaces following.
-- Drop leading ' do ', and blank spaces following.
dropDo
::
String
->
String
dropDo
::
String
->
String
dropDo
string
=
dropDo
string
=
-- If this is not a statement, we don't need to drop the do statement.
-- If this is not a statement, we don't need to drop the do statement.
if
lintIdent
`
isInfixOf
`
string
if
lintIdent
`
isInfixOf
`
string
then
unlines
.
clean
.
lines
$
string
then
unlines
.
clean
.
lines
$
string
else
string
else
string
clean
::
[
String
]
->
[
String
]
clean
::
[
String
]
->
[
String
]
-- If the first line starts with a `do`...
-- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
-- Note that hlint always indents by two spaces in its output.
-- output.
clean
((
stripPrefix
" do "
->
Just
a
)
:
as
)
=
clean
((
stripPrefix
" do "
->
Just
a
)
:
as
)
=
-- Take all indented lines and unindent them.
-- Take all indented lines and unindent them.
let
unindented
=
catMaybes
let
unindented
=
catMaybes
$
takeWhile
isJust
$
map
(
stripPrefix
" "
)
as
$
takeWhile
isJust
fullDo
=
a
:
unindented
$
map
(
stripPrefix
" "
)
as
afterDo
=
drop
(
length
unindented
)
as
fullDo
=
a
:
unindented
in
fullDo
++
clean
afterDo
afterDo
=
drop
(
length
unindented
)
as
in
--
fullDo
++
clean
afterDo
-- Ignore other list elements - just proceed onwards.
-- Ignore other list elements - just proceed onwards.
clean
(
x
:
xs
)
=
x
:
clean
xs
clean
(
x
:
xs
)
=
x
:
clean
xs
...
...
src/IHaskell/Eval/ParseShell.hs
View file @
7ba7c4d1
-- | This module splits a shell command line into a list of strings,
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
-- one for each command / filename
module
IHaskell.Eval.ParseShell
(
parseShell
)
where
module
IHaskell.Eval.ParseShell
(
parseShell
)
where
import
Prelude
hiding
(
words
)
import
Prelude
hiding
(
words
)
import
Text.ParserCombinators.Parsec
hiding
(
manyTill
)
import
Text.ParserCombinators.Parsec
hiding
(
manyTill
)
import
Control.Applicative
hiding
((
<|>
),
many
,
optional
)
import
Control.Applicative
hiding
((
<|>
),
many
,
optional
)
eol
::
Parser
Char
eol
::
Parser
Char
eol
=
oneOf
"
\n\r
"
<?>
"end of line"
eol
=
oneOf
"
\n\r
"
<?>
"end of line"
quote
::
Parser
Char
quote
::
Parser
Char
quote
=
char
'
\"
'
quote
=
char
'
\"
'
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
...
@@ -18,16 +17,17 @@ manyTill :: Parser a -> Parser [a] -> Parser [a]
...
@@ -18,16 +17,17 @@ manyTill :: Parser a -> Parser [a] -> Parser [a]
manyTill
p
end
=
scan
manyTill
p
end
=
scan
where
where
scan
=
end
<|>
do
scan
=
end
<|>
do
x
<-
p
x
<-
p
xs
<-
scan
xs
<-
scan
return
$
x
:
xs
return
$
x
:
xs
manyTill1
p
end
=
do
x
<-
p
manyTill1
p
end
=
do
xs
<-
manyTill
p
end
x
<-
p
return
$
x
:
xs
xs
<-
manyTill
p
end
return
$
x
:
xs
unescapedChar
::
Parser
Char
->
Parser
String
unescapedChar
::
Parser
Char
->
Parser
String
unescapedChar
p
=
try
$
do
unescapedChar
p
=
try
$
do
x
<-
noneOf
"
\\
"
x
<-
noneOf
"
\\
"
lookAhead
p
lookAhead
p
return
[
x
]
return
[
x
]
...
@@ -36,8 +36,9 @@ quotedString = do
...
@@ -36,8 +36,9 @@ quotedString = do
quote
<?>
"expected starting quote"
quote
<?>
"expected starting quote"
(
manyTill
anyChar
(
unescapedChar
quote
)
<*
quote
)
<?>
"unexpected in quoted String "
(
manyTill
anyChar
(
unescapedChar
quote
)
<*
quote
)
<?>
"unexpected in quoted String "
unquotedString
=
manyTill1
anyChar
end
unquotedString
=
manyTill1
anyChar
end
where
end
=
unescapedChar
space
where
end
=
unescapedChar
space
<|>
(
lookAhead
eol
>>
return
[]
)
<|>
(
lookAhead
eol
>>
return
[]
)
word
=
quotedString
<|>
unquotedString
<?>
"word"
word
=
quotedString
<|>
unquotedString
<?>
"word"
...
@@ -48,12 +49,12 @@ separator = many1 space <?> "separator"
...
@@ -48,12 +49,12 @@ separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n)
-- | Input must terminate in a space character (like a \n)
words
::
Parser
[
String
]
words
::
Parser
[
String
]
words
=
try
(
eof
*>
return
[]
)
<|>
do
words
=
try
(
eof
*>
return
[]
)
<|>
do
x
<-
word
x
<-
word
rest1
<-
lookAhead
(
many
anyToken
)
rest1
<-
lookAhead
(
many
anyToken
)
ss
<-
separator
ss
<-
separator
rest2
<-
lookAhead
(
many
anyToken
)
rest2
<-
lookAhead
(
many
anyToken
)
xs
<-
words
xs
<-
words
return
$
x
:
xs
return
$
x
:
xs
parseShell
::
String
->
Either
ParseError
[
String
]
parseShell
::
String
->
Either
ParseError
[
String
]
parseShell
string
=
parse
words
"shell"
(
string
++
"
\n
"
)
parseShell
string
=
parse
words
"shell"
(
string
++
"
\n
"
)
src/IHaskell/Eval/Parser.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module
IHaskell.Eval.Parser
(
module
IHaskell.Eval.Parser
(
parseString
,
parseString
,
CodeBlock
(
..
),
CodeBlock
(
..
),
...
@@ -14,56 +15,55 @@ module IHaskell.Eval.Parser (
...
@@ -14,56 +15,55 @@ module IHaskell.Eval.Parser (
PragmaType
(
..
),
PragmaType
(
..
),
)
where
)
where
import
ClassyPrelude
hiding
(
head
,
liftIO
,
maximumBy
)
import
ClassyPrelude
hiding
(
head
,
liftIO
,
maximumBy
)
import
Data.List
(
maximumBy
,
inits
)
import
Data.List
(
maximumBy
,
inits
)
import
Data.String.Utils
(
startswith
,
strip
,
split
)
import
Data.String.Utils
(
startswith
,
strip
,
split
)
import
Prelude
(
head
,
tail
)
import
Prelude
(
head
,
tail
)
import
Control.Monad
(
msum
)
import
Control.Monad
(
msum
)
import
GHC
hiding
(
Located
)
import
GHC
hiding
(
Located
)
import
Language.Haskell.GHC.Parser
import
Language.Haskell.GHC.Parser
import
IHaskell.Eval.Util
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,
-- Each block contains a single element - one declaration, statement,
-- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,
-- expression, etc. If parsing of the block failed, the block is instead
-- which has the error location and error message.
-- a ParseError, which has the error location and error message.
data
CodeBlock
=
Expression
String
-- ^ A Haskell expression.
data
CodeBlock
|
Declaration
String
-- ^ A data type or function declaration.
=
Expression
String
-- ^ A Haskell expression.
|
Statement
String
-- ^ A Haskell statement (as if in a `do` block).
|
Declaration
String
-- ^ A data type or function declaration.
|
Import
String
-- ^ An import statement.
|
Statement
String
-- ^ A Haskell statement (as if in a `do` block).
|
TypeSignature
String
-- ^ A lonely type signature (not above a function
|
Import
String
-- ^ An import statement.
-- declaration).
|
TypeSignature
String
-- ^ A lonely type signature (not above a function declaration).
|
Directive
DirectiveType
String
-- ^ An IHaskell directive.
|
Directive
DirectiveType
String
-- ^ An IHaskell directive.
|
Module
String
-- ^ A full Haskell module, to be compiled and loaded.
|
Module
String
-- ^ A full Haskell module, to be compiled and loaded.
|
ParseError
StringLoc
ErrMsg
-- ^ An error indicating that parsing the code block
|
ParseError
StringLoc
ErrMsg
-- ^ An error indicating that parsing the code block failed.
-- failed.
|
Pragma
PragmaType
[
String
]
-- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-} block)
|
Pragma
PragmaType
[
String
]
-- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-}
-- block)
deriving
(
Show
,
Eq
)
deriving
(
Show
,
Eq
)
-- | Directive types. Each directive is associated with a string in the
-- | Directive types. Each directive is associated with a string in the directive code block.
-- directive code block.
data
DirectiveType
=
GetType
-- ^ Get the type of an expression via ':type' (or unique prefixes)
data
DirectiveType
|
GetInfo
-- ^ Get info about the identifier via ':info' (or unique prefixes)
=
GetType
-- ^ Get the type of an expression via ':type' (or unique prefixes)
|
SetDynFlag
-- ^ Enable or disable an extensions, packages etc. via `:set`.
|
GetInfo
-- ^ Get info about the identifier via ':info' (or unique prefixes)
-- Emulates GHCi's `:set`
|
SetDynFlag
-- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set`
|
LoadFile
-- ^ Load a Haskell module.
|
LoadFile
-- ^ Load a Haskell module.
|
SetOption
-- ^ Set IHaskell kernel option `:option`.
|
SetOption
-- ^ Set IHaskell kernel option `:option`.
|
SetExtension
-- ^ `:extension Foo` is a shortcut for `:set -XFoo`
|
SetExtension
-- ^ `:extension Foo` is a shortcut for `:set -XFoo`
|
ShellCmd
-- ^ Execute a shell command.
|
ShellCmd
-- ^ Execute a shell command.
|
GetHelp
-- ^ General help via ':?' or ':help'.
|
GetHelp
-- ^ General help via ':?' or ':help'.
|
SearchHoogle
-- ^ Search for something via Hoogle.
|
SearchHoogle
-- ^ Search for something via Hoogle.
|
GetDoc
-- ^ Get documentation for an identifier via Hoogle.
|
GetDoc
-- ^ Get documentation for an identifier via Hoogle.
|
GetKind
-- ^ Get the kind of a type via ':kind'.
|
GetKind
-- ^ Get the kind of a type via ':kind'.
|
LoadModule
-- ^ Load and unload modules via ':module'.
|
LoadModule
-- ^ Load and unload modules via ':module'.
deriving
(
Show
,
Eq
)
deriving
(
Show
,
Eq
)
-- | Pragma types. Only LANGUAGE pragmas are currently supported.
-- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around
-- Other pragma types are kept around as a string for error reporting.
-- as a string for error reporting.
data
PragmaType
data
PragmaType
=
PragmaLanguage
=
PragmaLanguage
|
PragmaUnsupported
String
|
PragmaUnsupported
String
deriving
(
Show
,
Eq
)
deriving
(
Show
,
Eq
)
-- | Parse a string into code blocks.
-- | Parse a string into code blocks.
...
@@ -73,18 +73,18 @@ parseString codeString = do
...
@@ -73,18 +73,18 @@ parseString codeString = do
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
let
output
=
runParser
flags
parserModule
codeString
let
output
=
runParser
flags
parserModule
codeString
case
output
of
case
output
of
Parsed
mod
|
Just
_
<-
hsmodName
(
unLoc
mod
)
->
return
[
Located
1
$
Module
codeString
]
Parsed
mod
|
Just
_
<-
hsmodName
(
unLoc
mod
)
->
return
[
Located
1
$
Module
codeString
]
_
->
do
_
->
do
-- Split input into chunks based on indentation.
-- Split input into chunks based on indentation.
let
chunks
=
layoutChunks
$
removeComments
codeString
let
chunks
=
layoutChunks
$
removeComments
codeString
result
<-
joinFunctions
<$>
processChunks
[]
chunks
result
<-
joinFunctions
<$>
processChunks
[]
chunks
-- Return to previous flags. When parsing, flags can be set to make
-- Return to previous flags. When parsing, flags can be set to make sure parsing works properly. But
-- sure parsing works properly. But we don't want those flags to be
-- we don't want those flags to be set during evaluation until the right time.
-- set during evaluation until the right time.
_
<-
setSessionDynFlags
flags
_
<-
setSessionDynFlags
flags
return
result
return
result
otherwise
->
error
"parseString failed, output was neither Parsed nor Failure"
where
where
parseChunk
::
GhcMonad
m
=>
String
->
LineNumber
->
m
(
Located
CodeBlock
)
parseChunk
::
GhcMonad
m
=>
String
->
LineNumber
->
m
(
Located
CodeBlock
)
parseChunk
chunk
line
=
Located
line
<$>
handleChunk
chunk
line
parseChunk
chunk
line
=
Located
line
<$>
handleChunk
chunk
line
...
@@ -101,7 +101,7 @@ parseString codeString = do
...
@@ -101,7 +101,7 @@ parseString codeString = do
[]
->
return
$
reverse
accum
[]
->
return
$
reverse
accum
-- 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
activateExtensions
$
unloc
block
activateExtensions
$
unloc
block
processChunks
(
block
:
accum
)
remaining
processChunks
(
block
:
accum
)
remaining
...
@@ -119,7 +119,7 @@ activateExtensions (Directive SetExtension ext) = void $ setExtension ext
...
@@ -119,7 +119,7 @@ activateExtensions (Directive SetExtension ext) = void $ setExtension ext
activateExtensions
(
Directive
SetDynFlag
flags
)
=
activateExtensions
(
Directive
SetDynFlag
flags
)
=
case
stripPrefix
"-X"
flags
of
case
stripPrefix
"-X"
flags
of
Just
ext
->
void
$
setExtension
ext
Just
ext
->
void
$
setExtension
ext
Nothing
->
return
()
Nothing
->
return
()
activateExtensions
(
Pragma
PragmaLanguage
extensions
)
=
void
$
setAll
extensions
activateExtensions
(
Pragma
PragmaLanguage
extensions
)
=
void
$
setAll
extensions
where
where
setAll
::
GhcMonad
m
=>
[
String
]
->
m
(
Maybe
String
)
setAll
::
GhcMonad
m
=>
[
String
]
->
m
(
Maybe
String
)
...
@@ -131,20 +131,21 @@ activateExtensions _ = return ()
...
@@ -131,20 +131,21 @@ activateExtensions _ = 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
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
let
let
-- Try each parser in turn.
-- Try each parser in turn.
rawResults
=
map
(
tryParser
code
)
(
parsers
flags
)
rawResults
=
map
(
tryParser
code
)
(
parsers
flags
)
-- Convert statements into expressions where we can
-- Convert statements into expressions where we can
results
=
map
(
statementToExpression
flags
)
rawResults
in
results
=
map
(
statementToExpression
flags
)
rawResults
case
successes
results
of
case
successes
results
of
-- If none of them succeeded, choose the best error message to
-- If none of them succeeded, choose the best error message to display. Only one of the error
-- display. Only one of the error messages is actually relevant.
-- messages is actually relevant.
[]
->
return
$
bestError
$
failures
results
[]
->
return
$
bestError
$
failures
results
-- If one of the parsers succeeded
-- If one of the parsers succeeded
result
:
_
->
return
result
result
:
_
->
return
result
where
where
successes
::
[
ParseOutput
a
]
->
[
a
]
successes
::
[
ParseOutput
a
]
->
[
a
]
successes
[]
=
[]
successes
[]
=
[]
...
@@ -164,47 +165,50 @@ parseCodeChunk code startLine = do
...
@@ -164,47 +165,50 @@ parseCodeChunk code startLine = do
statementToExpression
::
DynFlags
->
ParseOutput
CodeBlock
->
ParseOutput
CodeBlock
statementToExpression
::
DynFlags
->
ParseOutput
CodeBlock
->
ParseOutput
CodeBlock
statementToExpression
flags
(
Parsed
(
Statement
stmt
))
=
Parsed
result
statementToExpression
flags
(
Parsed
(
Statement
stmt
))
=
Parsed
result
where
result
=
if
isExpr
flags
stmt
where
then
Expression
stmt
result
=
if
isExpr
flags
stmt
else
Statement
stmt
then
Expression
stmt
else
Statement
stmt
statementToExpression
_
other
=
other
statementToExpression
_
other
=
other
-- Check whether a string is a valid expression.
-- Check whether a string is a valid expression.
isExpr
::
DynFlags
->
String
->
Bool
isExpr
::
DynFlags
->
String
->
Bool
isExpr
flags
str
=
case
runParser
flags
parserExpression
str
of
isExpr
flags
str
=
Parsed
{}
->
True
case
runParser
flags
parserExpression
str
of
_
->
False
Parsed
{}
->
True
_
->
False
tryParser
::
String
->
(
String
->
CodeBlock
,
String
->
ParseOutput
String
)
->
ParseOutput
CodeBlock
tryParser
::
String
->
(
String
->
CodeBlock
,
String
->
ParseOutput
String
)
->
ParseOutput
CodeBlock
tryParser
string
(
blockType
,
parser
)
=
case
parser
string
of
tryParser
string
(
blockType
,
parser
)
=
Parsed
res
->
Parsed
(
blockType
res
)
case
parser
string
of
Failure
err
loc
->
Failure
err
loc
Parsed
res
->
Parsed
(
blockType
res
)
otherwise
->
error
"tryParser failed, output was neither Parsed nor Failure"
Failure
err
loc
->
Failure
err
loc
otherwise
->
error
"tryParser failed, output was neither Parsed nor Failure"
parsers
::
DynFlags
->
[(
String
->
CodeBlock
,
String
->
ParseOutput
String
)]
parsers
::
DynFlags
->
[(
String
->
CodeBlock
,
String
->
ParseOutput
String
)]
parsers
flags
=
parsers
flags
=
[
(
Import
,
unparser
parserImport
)
[
(
Import
,
unparser
parserImport
)
,
(
TypeSignature
,
unparser
parserTypeSignature
)
,
(
TypeSignature
,
unparser
parserTypeSignature
)
,
(
Statement
,
unparser
parserStatement
)
,
(
Statement
,
unparser
parserStatement
)
,
(
Declaration
,
unparser
parserDeclaration
)
,
(
Declaration
,
unparser
parserDeclaration
)
]
]
where
where
unparser
::
Parser
a
->
String
->
ParseOutput
String
unparser
::
Parser
a
->
String
->
ParseOutput
String
unparser
parser
code
=
unparser
parser
code
=
case
runParser
flags
parser
code
of
case
runParser
flags
parser
code
of
Parsed
out
->
Parsed
code
Parsed
out
->
Parsed
code
Partial
out
strs
->
Partial
code
strs
Partial
out
strs
->
Partial
code
strs
Failure
err
loc
->
Failure
err
loc
Failure
err
loc
->
Failure
err
loc
-- | Find consecutive declarations of the same function and join them into
-- | Find consecutive declarations of the same function and join them into
a single declaration.
--
a single declaration. These declarations may also include a type
--
These declarations may also include a type signature, which is also joined with the subsequent
--
signature, which is also joined with the subsequent
declarations.
-- declarations.
joinFunctions
::
[
Located
CodeBlock
]
->
[
Located
CodeBlock
]
joinFunctions
::
[
Located
CodeBlock
]
->
[
Located
CodeBlock
]
joinFunctions
[]
=
[]
joinFunctions
[]
=
[]
joinFunctions
blocks
=
joinFunctions
blocks
=
if
signatureOrDecl
$
unloc
$
head
blocks
if
signatureOrDecl
$
unloc
$
head
blocks
then
Located
lnum
(
conjoin
$
map
unloc
decls
)
:
joinFunctions
rest
then
Located
lnum
(
conjoin
$
map
unloc
decls
)
:
joinFunctions
rest
else
head
blocks
:
joinFunctions
(
tail
blocks
)
else
head
blocks
:
joinFunctions
(
tail
blocks
)
where
where
decls
=
takeWhile
(
signatureOrDecl
.
unloc
)
blocks
decls
=
takeWhile
(
signatureOrDecl
.
unloc
)
blocks
rest
=
drop
(
length
decls
)
blocks
rest
=
drop
(
length
decls
)
blocks
...
@@ -221,7 +225,6 @@ joinFunctions blocks =
...
@@ -221,7 +225,6 @@ joinFunctions blocks =
conjoin
::
[
CodeBlock
]
->
CodeBlock
conjoin
::
[
CodeBlock
]
->
CodeBlock
conjoin
=
Declaration
.
intercalate
"
\n
"
.
map
str
conjoin
=
Declaration
.
intercalate
"
\n
"
.
map
str
-- | Parse a pragma of the form {-# LANGUAGE ... #-}
-- | Parse a pragma of the form {-# LANGUAGE ... #-}
parsePragma
::
String
-- ^ Pragma string.
parsePragma
::
String
-- ^ Pragma string.
->
Int
-- ^ Line number at which the directive appears.
->
Int
-- ^ Line number at which the directive appears.
...
@@ -229,10 +232,11 @@ parsePragma :: String -- ^ Pragma string.
...
@@ -229,10 +232,11 @@ parsePragma :: String -- ^ Pragma string.
parsePragma
(
'{'
:
'-'
:
'#'
:
pragma
)
line
=
parsePragma
(
'{'
:
'-'
:
'#'
:
pragma
)
line
=
let
commaToSpace
::
Char
->
Char
let
commaToSpace
::
Char
->
Char
commaToSpace
','
=
' '
commaToSpace
','
=
' '
commaToSpace
x
=
x
commaToSpace
x
=
x
pragmas
=
words
$
takeWhile
(
/=
'#'
)
$
map
commaToSpace
pragma
in
pragmas
=
words
$
takeWhile
(
/=
'#'
)
$
map
commaToSpace
pragma
case
pragmas
of
in
case
pragmas
of
[]
->
Pragma
(
PragmaUnsupported
""
)
[]
--empty string pragmas are unsupported
--empty string pragmas are unsupported
[]
->
Pragma
(
PragmaUnsupported
""
)
[]
"LANGUAGE"
:
xs
->
Pragma
PragmaLanguage
xs
"LANGUAGE"
:
xs
->
Pragma
PragmaLanguage
xs
x
:
xs
->
Pragma
(
PragmaUnsupported
x
)
xs
x
:
xs
->
Pragma
(
PragmaUnsupported
x
)
xs
...
@@ -240,48 +244,50 @@ parsePragma ('{':'-':'#':pragma) line =
...
@@ -240,48 +244,50 @@ parsePragma ('{':'-':'#':pragma) line =
parseDirective
::
String
-- ^ Directive string.
parseDirective
::
String
-- ^ Directive string.
->
Int
-- ^ Line number at which the directive appears.
->
Int
-- ^ Line number at which the directive appears.
->
CodeBlock
-- ^ Directive code block or a parse error.
->
CodeBlock
-- ^ Directive code block or a parse error.
parseDirective
(
':'
:
'!'
:
directive
)
line
=
Directive
ShellCmd
$
'!'
:
directive
parseDirective
(
':'
:
'!'
:
directive
)
line
=
Directive
ShellCmd
$
'!'
:
directive
parseDirective
(
':'
:
directive
)
line
=
parseDirective
(
':'
:
directive
)
line
=
case
find
rightDirective
directives
of
case
find
rightDirective
directives
of
Just
(
directiveType
,
_
)
->
Directive
directiveType
arg
Just
(
directiveType
,
_
)
->
Directive
directiveType
arg
where
arg
=
unwords
restLine
where
arg
=
unwords
restLine
_
:
restLine
=
words
directive
_
:
restLine
=
words
directive
Nothing
->
Nothing
->
let
directiveStart
=
case
words
directive
of
let
directiveStart
=
[]
->
""
case
words
directive
of
first
:
_
->
first
in
[]
->
""
ParseError
(
Loc
line
1
)
$
"Unknown directive: '"
++
directiveStart
++
"'."
first
:
_
->
first
in
ParseError
(
Loc
line
1
)
$
"Unknown directive: '"
++
directiveStart
++
"'."
where
where
rightDirective
(
_
,
dirname
)
=
case
words
directive
of
rightDirective
(
_
,
dirname
)
=
[]
->
False
case
words
directive
of
dir
:
_
->
dir
`
elem
`
tail
(
inits
dirname
)
[]
->
False
dir
:
_
->
dir
`
elem
`
tail
(
inits
dirname
)
directives
=
directives
=
[
(
LoadModule
,
"module"
)
[
(
LoadModule
,
"module"
)
,
(
GetType
,
"type"
)
,
(
GetType
,
"type"
)
,
(
GetKind
,
"kind"
)
,
(
GetKind
,
"kind"
)
,
(
GetInfo
,
"info"
)
,
(
GetInfo
,
"info"
)
,
(
SearchHoogle
,
"hoogle"
)
,
(
SearchHoogle
,
"hoogle"
)
,
(
GetDoc
,
"documentation"
)
,
(
GetDoc
,
"documentation"
)
,
(
SetDynFlag
,
"set"
)
,
(
SetDynFlag
,
"set"
)
,
(
LoadFile
,
"load"
)
,
(
LoadFile
,
"load"
)
,
(
SetOption
,
"option"
)
,
(
SetOption
,
"option"
)
,
(
SetExtension
,
"extension"
)
,
(
SetExtension
,
"extension"
)
,
(
GetHelp
,
"?"
)
,
(
GetHelp
,
"?"
)
,
(
GetHelp
,
"help"
)
,
(
GetHelp
,
"help"
)
]
]
parseDirective
_
_
=
error
"Directive must start with colon!"
parseDirective
_
_
=
error
"Directive must start with colon!"
-- | Parse a module and return the name declared in the 'module X where'
-- | Parse a module and return the name declared in the 'module X where'
line. That line is
--
line. That line is required, and if it does not exist, this will error.
--
required, and if it does not exist, this will error. Names with periods in them are returned
--
Names with periods in them are returned
piece y piece.
-- piece y piece.
getModuleName
::
GhcMonad
m
=>
String
->
m
[
String
]
getModuleName
::
GhcMonad
m
=>
String
->
m
[
String
]
getModuleName
moduleSrc
=
do
getModuleName
moduleSrc
=
do
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
let
output
=
runParser
flags
parserModule
moduleSrc
let
output
=
runParser
flags
parserModule
moduleSrc
case
output
of
case
output
of
Failure
{}
->
error
"Module parsing failed."
Failure
{}
->
error
"Module parsing failed."
Parsed
mod
->
Parsed
mod
->
case
unLoc
<$>
hsmodName
(
unLoc
mod
)
of
case
unLoc
<$>
hsmodName
(
unLoc
mod
)
of
Nothing
->
error
"Module must have a name."
Nothing
->
error
"Module must have a name."
Just
name
->
return
$
split
"."
$
moduleNameString
name
Just
name
->
return
$
split
"."
$
moduleNameString
name
otherwise
->
error
"getModuleName failed, output was neither Parsed nor Failure"
otherwise
->
error
"getModuleName failed, output was neither Parsed nor Failure"
src/IHaskell/Eval/Util.hs
View file @
7ba7c4d1
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
module
IHaskell.Eval.Util
(
module
IHaskell.Eval.Util
(
-- * Initialization
-- * Initialization
initGhci
,
initGhci
,
-- * Flags and extensions
-- * Flags and extensions ** Set and unset flags.
-- ** Set and unset flags.
extensionFlag
,
extensionFlag
,
setExtension
,
setExtension
,
ExtFlag
(
..
),
ExtFlag
(
..
),
setFlags
,
setFlags
,
-- * Code Evaluation
-- * Code Evaluation
evalImport
,
evalImport
,
removeImport
,
removeImport
,
evalDeclarations
,
evalDeclarations
,
getType
,
getType
,
getDescription
,
getDescription
,
-- * Pretty printing
-- * Pretty printing
doc
,
doc
,
pprDynFlags
,
pprDynFlags
,
pprLanguages
pprLanguages
,
)
where
)
where
import
ClassyPrelude
hiding
((
<>
))
import
ClassyPrelude
hiding
((
<>
))
...
@@ -50,20 +51,17 @@ import Data.String.Utils (replace)
...
@@ -50,20 +51,17 @@ import Data.String.Utils (replace)
import
Data.List
(
nubBy
)
import
Data.List
(
nubBy
)
-- | A extension flag that can be set or unset.
-- | A extension flag that can be set or unset.
data
ExtFlag
data
ExtFlag
=
SetFlag
ExtensionFlag
=
SetFlag
ExtensionFlag
|
UnsetFlag
ExtensionFlag
|
UnsetFlag
ExtensionFlag
-- | Find the extension that corresponds to a given flag. Create the
-- | Find the extension that corresponds to a given flag. Create the corresponding 'ExtFlag' via
-- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@.
-- @SetFlag@ or @UnsetFlag@. If no such extension exist, yield @Nothing@.
-- If no such extension exist, yield @Nothing@.
extensionFlag
::
String
-- Extension name, such as @"DataKinds"@
extensionFlag
::
String
-- Extension name, such as @"DataKinds"@
->
Maybe
ExtFlag
->
Maybe
ExtFlag
extensionFlag
ext
=
extensionFlag
ext
=
case
find
(
flagMatches
ext
)
xFlags
of
case
find
(
flagMatches
ext
)
xFlags
of
Just
fs
->
Just
$
SetFlag
$
flagSpecFlag
fs
Just
fs
->
Just
$
SetFlag
$
flagSpecFlag
fs
-- If it doesn't match an extension name, try matching against
-- If it doesn't match an extension name, try matching against disabling an extension.
-- disabling an extension.
Nothing
->
Nothing
->
case
find
(
flagMatchesNo
ext
)
xFlags
of
case
find
(
flagMatchesNo
ext
)
xFlags
of
Just
fs
->
Just
$
UnsetFlag
$
flagSpecFlag
fs
Just
fs
->
Just
$
UnsetFlag
$
flagSpecFlag
fs
...
@@ -72,103 +70,95 @@ extensionFlag ext =
...
@@ -72,103 +70,95 @@ extensionFlag ext =
-- Check if a FlagSpec matches an extension name.
-- Check if a FlagSpec matches an extension name.
flagMatches
ext
fs
=
ext
==
flagSpecName
fs
flagMatches
ext
fs
=
ext
==
flagSpecName
fs
-- Check if a FlagSpec matches "No<ExtensionName>".
-- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
-- In that case, we disable the extension.
flagMatchesNo
ext
fs
=
ext
==
"No"
++
flagSpecName
fs
flagMatchesNo
ext
fs
=
ext
==
"No"
++
flagSpecName
fs
#
if
!
MIN_VERSION_ghc
(
7
,
10
,
0
)
#
if
!
MIN_VERSION_ghc
(
7
,
10
,
0
)
flagSpecName
(
name
,
_
,
_
)
=
name
flagSpecName
(
name
,
_
,
_
)
=
name
flagSpecFlag
(
_
,
flag
,
_
)
=
flag
#
endif
#
if
!
MIN_VERSION_ghc
(
7
,
10
,
0
)
flagSpecFlag
(
_
,
flag
,
_
)
=
flag
flagSpecName
(
name
,
_
,
_
)
=
name
flagSpecFlag
(
_
,
flag
,
_
)
=
flag
#
endif
#
endif
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
pprDynFlags
::
Bool
-- ^ Whether to include flags which are on by default
pprDynFlags
::
Bool
-- ^ Whether to include flags which are on by default
->
DynFlags
->
DynFlags
->
SDoc
->
SDoc
pprDynFlags
show_all
dflags
=
pprDynFlags
show_all
dflags
=
vcat
[
vcat
[
text
"GHCi-specific dynamic flag settings:"
$$
nest
2
(
vcat
(
map
(
setting
opt
)
ghciFlags
))
,
text
"other dynamic, non-language, flag settings:"
$$
nest
2
(
vcat
(
map
(
setting
opt
)
others
))
,
text
"warning settings:"
$$
nest
2
(
vcat
(
map
(
setting
wopt
)
DynFlags
.
fWarningFlags
))
]
where
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
text
"GHCi-specific dynamic flag settings:"
$$
opt
=
gopt
nest
2
(
vcat
(
map
(
setting
gopt
)
ghciFlags
)),
text
"other dynamic, non-language, flag settings:"
$$
nest
2
(
vcat
(
map
(
setting
gopt
)
others
)),
text
"warning settings:"
$$
nest
2
(
vcat
(
map
(
setting
wopt
)
DynFlags
.
fWarningFlags
))
#
else
#
else
text
"GHCi-specific dynamic flag settings:"
$$
opt
=
dopt
nest
2
(
vcat
(
map
(
setting
dopt
)
ghciFlags
)),
text
"other dynamic, non-language, flag settings:"
$$
nest
2
(
vcat
(
map
(
setting
dopt
)
others
)),
text
"warning settings:"
$$
nest
2
(
vcat
(
map
(
setting
wopt
)
DynFlags
.
fWarningFlags
))
#
endif
#
endif
]
setting
test
flag
where
|
quiet
=
empty
setting
test
flag
|
is_on
=
fstr
name
|
quiet
=
empty
|
otherwise
=
fnostr
name
|
is_on
=
fstr
name
where
|
otherwise
=
fnostr
name
name
=
flagSpecName
flag
where
name
=
flagSpecName
flag
f
=
flagSpecFlag
flag
f
=
flagSpecFlag
flag
is_on
=
test
f
dflags
is_on
=
test
f
dflags
quiet
=
not
show_all
&&
test
f
default_dflags
==
is_on
quiet
=
not
show_all
&&
test
f
default_dflags
==
is_on
default_dflags
=
defaultDynFlags
(
settings
dflags
)
default_dflags
=
defaultDynFlags
(
settings
dflags
)
fstr
str
=
text
"-f"
<>
text
str
fstr
str
=
text
"-f"
<>
text
str
fnostr
str
=
text
"-fno-"
<>
text
str
fnostr
str
=
text
"-fno-"
<>
text
str
(
ghciFlags
,
others
)
=
partition
(
\
f
->
flagSpecFlag
f
`
elem
`
flgs
)
(
ghciFlags
,
others
)
=
partition
(
\
f
->
flagSpecFlag
f
`
elem
`
flgs
)
DynFlags
.
fFlags
DynFlags
.
fFlags
flgs
=
[
flgs
=
concat
[
flgs1
,
flgs2
,
flgs3
]
Opt_PrintExplicitForalls
flgs1
=
[
Opt_PrintExplicitForalls
]
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
,
Opt_PrintExplicitKinds
flgs2
=
[
Opt_PrintExplicitKinds
]
#
else
flgs2
=
[]
#
endif
#
endif
,
Opt_PrintBindResult
flgs3
=
[
Opt_PrintBindResult
,
Opt_BreakOnException
,
Opt_BreakOnError
,
Opt_PrintEvldWithShow
]
,
Opt_BreakOnException
,
Opt_BreakOnError
,
Opt_PrintEvldWithShow
]
-- | Pretty-print the base language and active options (taken from `InteractiveUI` module of `ghc-bin`)
-- | Pretty-print the base language and active options (taken from `InteractiveUI` module of
-- `ghc-bin`)
pprLanguages
::
Bool
-- ^ Whether to include flags which are on by default
pprLanguages
::
Bool
-- ^ Whether to include flags which are on by default
->
DynFlags
->
DynFlags
->
SDoc
->
SDoc
pprLanguages
show_all
dflags
=
pprLanguages
show_all
dflags
=
vcat
vcat
[
text
"base language is: "
<>
[
text
"base language is: "
<>
case
language
dflags
of
case
language
dflags
of
Nothing
->
text
"Haskell2010"
Nothing
->
text
"Haskell2010"
Just
Haskell98
->
text
"Haskell98"
Just
Haskell98
->
text
"Haskell98"
Just
Haskell2010
->
text
"Haskell2010"
Just
Haskell2010
->
text
"Haskell2010"
,
(
if
show_all
,
(
if
show_all
then
text
"all active language options:"
then
text
"all active language options:"
else
text
"with the following modifiers:"
)
$$
else
text
"with the following modifiers:"
)
$$
nest
2
(
vcat
(
map
(
setting
xopt
)
DynFlags
.
xFlags
))
nest
2
(
vcat
(
map
(
setting
xopt
)
DynFlags
.
xFlags
))]
]
where
where
setting
test
flag
setting
test
flag
|
quiet
=
empty
|
quiet
=
empty
|
is_on
=
text
"-X"
<>
text
name
|
is_on
=
text
"-X"
<>
text
name
|
otherwise
=
text
"-XNo"
<>
text
name
|
otherwise
=
text
"-XNo"
<>
text
name
where
name
=
flagSpecName
flag
where
f
=
flagSpecFlag
flag
name
=
flagSpecName
flag
is_on
=
test
f
dflags
f
=
flagSpecFlag
flag
quiet
=
not
show_all
&&
test
f
default_dflags
==
is_on
is_on
=
test
f
dflags
quiet
=
not
show_all
&&
test
f
default_dflags
==
is_on
default_dflags
=
defaultDynFlags
(
settings
dflags
)
`
lang_set
`
default_dflags
=
case
language
dflags
of
defaultDynFlags
(
settings
dflags
)
`
lang_set
`
Nothing
->
Just
Haskell2010
case
language
dflags
of
other
->
other
Nothing
->
Just
Haskell2010
other
->
other
-- | Set an extension and update flags.
-- Return @Nothing@ on success. On failure, return an error message.
-- | Set an extension and update flags. Return @Nothing@ on success. On failure, return an error
-- message.
setExtension
::
GhcMonad
m
=>
String
->
m
(
Maybe
String
)
setExtension
::
GhcMonad
m
=>
String
->
m
(
Maybe
String
)
setExtension
ext
=
do
setExtension
ext
=
do
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
...
@@ -177,37 +167,35 @@ setExtension ext = do
...
@@ -177,37 +167,35 @@ setExtension ext = do
Just
flag
->
do
Just
flag
->
do
setSessionDynFlags
$
setSessionDynFlags
$
case
flag
of
case
flag
of
SetFlag
ghcFlag
->
xopt_set
flags
ghcFlag
SetFlag
ghcFlag
->
xopt_set
flags
ghcFlag
UnsetFlag
ghcFlag
->
xopt_unset
flags
ghcFlag
UnsetFlag
ghcFlag
->
xopt_unset
flags
ghcFlag
return
Nothing
return
Nothing
-- | Set a list of flags, as per GHCi's `:set`.
-- | Set a list of flags, as per GHCi's `:set`. This was adapted from GHC's InteractiveUI.hs
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).
-- (newDynFlags). It returns a list of error messages.
-- It returns a list of error messages.
setFlags
::
GhcMonad
m
=>
[
String
]
->
m
[
String
]
setFlags
::
GhcMonad
m
=>
[
String
]
->
m
[
String
]
setFlags
ext
=
do
setFlags
ext
=
do
-- Try to parse flags.
-- Try to parse flags.
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
(
flags'
,
unrecognized
,
warnings
)
<-
parseDynamicFlags
flags
(
map
noLoc
ext
)
(
flags'
,
unrecognized
,
warnings
)
<-
parseDynamicFlags
flags
(
map
noLoc
ext
)
-- First, try to check if this flag matches any extension name.
-- First, try to check if this flag matches any extension name.
let
restorePkg
x
=
x
{
packageFlags
=
packageFlags
flags
}
let
restorePkg
x
=
x
{
packageFlags
=
packageFlags
flags
}
let
restoredPkgs
=
flags'
{
packageFlags
=
packageFlags
flags
}
let
restoredPkgs
=
flags'
{
packageFlags
=
packageFlags
flags
}
GHC
.
setProgramDynFlags
restoredPkgs
GHC
.
setProgramDynFlags
restoredPkgs
GHC
.
setInteractiveDynFlags
restoredPkgs
GHC
.
setInteractiveDynFlags
restoredPkgs
-- Create the parse errors.
-- Create the parse errors.
let
noParseErrs
=
map
((
"Could not parse: "
++
)
.
unLoc
)
unrecognized
let
noParseErrs
=
map
((
"Could not parse: "
++
)
.
unLoc
)
unrecognized
allWarns
=
map
unLoc
warnings
++
allWarns
=
map
unLoc
warnings
++
[
"-package not supported yet"
|
packageFlags
flags
/=
packageFlags
flags'
]
[
"-package not supported yet"
|
packageFlags
flags
/=
packageFlags
flags'
]
warnErrs
=
map
(
"Warning: "
++
)
allWarns
warnErrs
=
map
(
"Warning: "
++
)
allWarns
return
$
noParseErrs
++
warnErrs
return
$
noParseErrs
++
warnErrs
-- | Convert an 'SDoc' into a string. This is similar to the family of
-- | Convert an 'SDoc' into a string. This is similar to the family of 'showSDoc' functions, but
-- 'showSDoc' functions, but does not impose an arbitrary width limit on
-- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,
-- the output (in terms of number of columns). Instead, it respsects the
-- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus
-- 'pprCols' field in the structure returned by 'getSessionDynFlags', and
-- gives a configurable width of output.
-- thus gives a configurable width of output.
doc
::
GhcMonad
m
=>
SDoc
->
m
String
doc
::
GhcMonad
m
=>
SDoc
->
m
String
doc
sdoc
=
do
doc
sdoc
=
do
flags
<-
getSessionDynFlags
flags
<-
getSessionDynFlags
...
@@ -216,15 +204,16 @@ doc sdoc = do
...
@@ -216,15 +204,16 @@ doc sdoc = do
let
cols
=
pprCols
flags
let
cols
=
pprCols
flags
d
=
runSDoc
sdoc
(
initSDocContext
flags
style
)
d
=
runSDoc
sdoc
(
initSDocContext
flags
style
)
return
$
Pretty
.
fullRender
Pretty
.
PageMode
cols
1.5
string_txt
""
d
return
$
Pretty
.
fullRender
Pretty
.
PageMode
cols
1.5
string_txt
""
d
where
where
string_txt
::
Pretty
.
TextDetails
->
String
->
String
string_txt
::
Pretty
.
TextDetails
->
String
->
String
string_txt
(
Pretty
.
Chr
c
)
s
=
c
:
s
string_txt
(
Pretty
.
Chr
c
)
s
=
c
:
s
string_txt
(
Pretty
.
Str
s1
)
s2
=
s1
++
s2
string_txt
(
Pretty
.
Str
s1
)
s2
=
s1
++
s2
string_txt
(
Pretty
.
PStr
s1
)
s2
=
unpackFS
s1
++
s2
string_txt
(
Pretty
.
PStr
s1
)
s2
=
unpackFS
s1
++
s2
string_txt
(
Pretty
.
LStr
s1
_
)
s2
=
unpackLitString
s1
++
s2
string_txt
(
Pretty
.
LStr
s1
_
)
s2
=
unpackLitString
s1
++
s2
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.
This initializes some dyn
--
This initializes some dyn
flags (@ExtendedDefaultRules@,
-- flags (@ExtendedDefaultRules@,
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- memory, sets a reasonable output width, and potentially a few other
-- memory, sets a reasonable output width, and potentially a few other
-- things. It should be invoked before other functions from this module.
-- things. It should be invoked before other functions from this module.
...
@@ -234,27 +223,28 @@ doc sdoc = do
...
@@ -234,27 +223,28 @@ doc sdoc = do
-- (and only the first time) it is called.
-- (and only the first time) it is called.
initGhci
::
GhcMonad
m
=>
Maybe
String
->
m
()
initGhci
::
GhcMonad
m
=>
Maybe
String
->
m
()
initGhci
sandboxPackages
=
do
initGhci
sandboxPackages
=
do
-- Initialize dyn flags.
-- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
-- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
originalFlags
<-
getSessionDynFlags
originalFlags
<-
getSessionDynFlags
let
flag
=
flip
xopt_set
let
flag
=
flip
xopt_set
unflag
=
flip
xopt_unset
unflag
=
flip
xopt_unset
dflags
=
flag
Opt_ExtendedDefaultRules
.
unflag
Opt_MonomorphismRestriction
$
originalFlags
dflags
=
flag
Opt_ExtendedDefaultRules
.
unflag
Opt_MonomorphismRestriction
$
originalFlags
pkgConfs
=
case
sandboxPackages
of
pkgConfs
=
Nothing
->
extraPkgConfs
originalFlags
case
sandboxPackages
of
Just
path
->
Nothing
->
extraPkgConfs
originalFlags
let
pkg
=
PkgConfFile
path
in
Just
path
->
(
pkg
:
)
.
extraPkgConfs
originalFlags
let
pkg
=
PkgConfFile
path
in
(
pkg
:
)
.
extraPkgConfs
originalFlags
void
$
setSessionDynFlags
$
dflags
{
hscTarget
=
HscInterpreted
,
ghcLink
=
LinkInMemory
,
void
$
setSessionDynFlags
$
dflags
pprCols
=
300
,
{
hscTarget
=
HscInterpreted
extraPkgConfs
=
pkgConfs
}
,
ghcLink
=
LinkInMemory
,
pprCols
=
300
-- | Evaluate a single import statement.
,
extraPkgConfs
=
pkgConfs
-- If this import statement is importing a module which was previously
}
-- imported implicitly (such as `Prelude`) or if this module has a `hiding`
-- annotation, the previous import is removed.
-- | Evaluate a single import statement. If this import statement is importing a module which was
-- previously imported implicitly (such as `Prelude`) or if this module has a `hiding` annotation,
-- the previous import is removed.
evalImport
::
GhcMonad
m
=>
String
->
m
()
evalImport
::
GhcMonad
m
=>
String
->
m
()
evalImport
imports
=
do
evalImport
imports
=
do
importDecl
<-
parseImportDecl
imports
importDecl
<-
parseImportDecl
imports
...
@@ -265,8 +255,8 @@ evalImport imports = do
...
@@ -265,8 +255,8 @@ evalImport imports = do
-- If this is a `hiding` import, remove previous non-`hiding` imports.
-- If this is a `hiding` import, remove previous non-`hiding` imports.
oldImps
=
if
isHiddenImport
importDecl
oldImps
=
if
isHiddenImport
importDecl
then
filter
(
not
.
importOf
importDecl
)
context
then
filter
(
not
.
importOf
importDecl
)
context
else
noImplicit
else
noImplicit
-- Replace the context.
-- Replace the context.
setContext
$
IIDecl
importDecl
:
oldImps
setContext
$
IIDecl
importDecl
:
oldImps
...
@@ -285,9 +275,10 @@ evalImport imports = do
...
@@ -285,9 +275,10 @@ evalImport imports = do
-- Check whether an import is hidden.
-- Check whether an import is hidden.
isHiddenImport
::
ImportDecl
RdrName
->
Bool
isHiddenImport
::
ImportDecl
RdrName
->
Bool
isHiddenImport
imp
=
case
ideclHiding
imp
of
isHiddenImport
imp
=
Just
(
True
,
_
)
->
True
case
ideclHiding
imp
of
_
->
False
Just
(
True
,
_
)
->
True
_
->
False
removeImport
::
GhcMonad
m
=>
String
->
m
()
removeImport
::
GhcMonad
m
=>
String
->
m
()
removeImport
moduleName
=
do
removeImport
moduleName
=
do
...
@@ -301,8 +292,7 @@ removeImport moduleName = do
...
@@ -301,8 +292,7 @@ removeImport moduleName = do
isImportOf
name
(
IIModule
modName
)
=
name
==
modName
isImportOf
name
(
IIModule
modName
)
=
name
==
modName
isImportOf
name
(
IIDecl
impDecl
)
=
name
==
unLoc
(
ideclName
impDecl
)
isImportOf
name
(
IIDecl
impDecl
)
=
name
==
unLoc
(
ideclName
impDecl
)
-- | Evaluate a series of declarations.
-- | Evaluate a series of declarations. Return all names which were bound by these declarations.
-- Return all names which were bound by these declarations.
evalDeclarations
::
GhcMonad
m
=>
String
->
m
[
String
]
evalDeclarations
::
GhcMonad
m
=>
String
->
m
[
String
]
evalDeclarations
decl
=
do
evalDeclarations
decl
=
do
names
<-
runDecls
decl
names
<-
runDecls
decl
...
@@ -321,16 +311,16 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
...
@@ -321,16 +311,16 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
in
hscEnv
{
hsc_IC
=
ic
{
ic_instances
=
(
clsInsts'
,
famInsts
)
}
}
in
hscEnv
{
hsc_IC
=
ic
{
ic_instances
=
(
clsInsts'
,
famInsts
)
}
}
where
where
instEq
::
ClsInst
->
ClsInst
->
Bool
instEq
::
ClsInst
->
ClsInst
->
Bool
instEq
ClsInst
{
is_tvs
=
tpl_tvs
,
is_tys
=
tpl_tys
,
is_cls
=
cls
}
ClsInst
{
is_tys
=
tpl_tys'
,
is_cls
=
cls'
}
=
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
-- Only support replacing instances on GHC 7.8 and up
-- Only support replacing instances on GHC 7.8 and up
let
tpl_tv_set
=
mkVarSet
tpl_tvs
instEq
c1
c2
in
cls
==
cls'
&&
isJust
(
tcMatchTys
tpl_tv_set
tpl_tys
tpl_tys'
)
|
ClsInst
{
is_tvs
=
tpl_tvs
,
is_tys
=
tpl_tys
,
is_cls
=
cls
}
<-
c1
,
ClsInst
{
is_tys
=
tpl_tys'
,
is_cls
=
cls'
}
<-
c2
=
let
tpl_tv_set
=
mkVarSet
tpl_tvs
in
cls
==
cls'
&&
isJust
(
tcMatchTys
tpl_tv_set
tpl_tys
tpl_tys'
)
#
else
#
else
False
instEq
_
_
=
False
#
endif
#
endif
-- | Get the type of an expression and convert it to a string.
-- | Get the type of an expression and convert it to a string.
getType
::
GhcMonad
m
=>
String
->
m
String
getType
::
GhcMonad
m
=>
String
->
m
String
getType
expr
=
do
getType
expr
=
do
...
@@ -342,21 +332,23 @@ getType expr = do
...
@@ -342,21 +332,23 @@ getType expr = do
-- | A wrapper around @getInfo@. Return info about each name in the string.
-- | A wrapper around @getInfo@. Return info about each name in the string.
getDescription
::
GhcMonad
m
=>
String
->
m
[
String
]
getDescription
::
GhcMonad
m
=>
String
->
m
[
String
]
getDescription
str
=
do
getDescription
str
=
do
names
<-
parseName
str
names
<-
parseName
str
maybeInfos
<-
mapM
getInfo'
names
maybeInfos
<-
mapM
getInfo'
names
-- Filter out types that have parents in the same set.
-- Filter out types that have parents in the same set. GHCi also does this.
-- GHCi also does this.
let
infos
=
catMaybes
maybeInfos
let
infos
=
catMaybes
maybeInfos
allNames
=
mkNameSet
$
map
(
getName
.
getType
)
infos
allNames
=
mkNameSet
$
map
(
getName
.
getType
)
infos
hasParent
info
=
case
tyThingParent_maybe
(
getType
info
)
of
hasParent
info
=
Just
parent
->
getName
parent
`
elemNameSet
`
allNames
case
tyThingParent_maybe
(
getType
info
)
of
Nothing
->
False
Just
parent
->
getName
parent
`
elemNameSet
`
allNames
Nothing
->
False
filteredOutput
=
filter
(
not
.
hasParent
)
infos
filteredOutput
=
filter
(
not
.
hasParent
)
infos
-- Print nicely
-- Print nicely
mapM
(
doc
.
printInfo
)
filteredOutput
mapM
(
doc
.
printInfo
)
filteredOutput
where
where
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
getInfo'
=
getInfo
False
getInfo'
=
getInfo
False
#
else
#
else
...
@@ -371,15 +363,16 @@ getDescription str = do
...
@@ -371,15 +363,16 @@ getDescription str = do
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
#
if
MIN_VERSION_ghc
(
7
,
8
,
0
)
printInfo
(
thing
,
fixity
,
classInstances
,
famInstances
)
=
printInfo
(
thing
,
fixity
,
classInstances
,
famInstances
)
=
pprTyThingInContextLoc
thing
$$
pprTyThingInContextLoc
thing
$$
showFixity
thing
fixity
$$
showFixity
thing
fixity
$$
vcat
(
map
GHC
.
pprInstance
classInstances
)
$$
vcat
(
map
GHC
.
pprInstance
classInstances
)
$$
vcat
(
map
GHC
.
pprFamInst
famInstances
)
vcat
(
map
GHC
.
pprFamInst
famInstances
)
#
else
#
else
printInfo
(
thing
,
fixity
,
classInstances
)
=
printInfo
(
thing
,
fixity
,
classInstances
)
=
pprTyThingInContextLoc
False
thing
$$
showFixity
thing
fixity
$$
vcat
(
map
GHC
.
pprInstance
classInstances
)
pprTyThingInContextLoc
False
thing
$$
showFixity
thing
fixity
$$
vcat
(
map
GHC
.
pprInstance
classInstances
)
#
endif
#
endif
showFixity
thing
fixity
=
showFixity
thing
fixity
=
if
fixity
==
GHC
.
defaultFixity
if
fixity
==
GHC
.
defaultFixity
then
empty
then
empty
else
ppr
fixity
<+>
pprInfixName
(
getName
thing
)
else
ppr
fixity
<+>
pprInfixName
(
getName
thing
)
src/IHaskell/Flags.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module
IHaskell.Flags
(
module
IHaskell.Flags
(
IHaskellMode
(
..
),
IHaskellMode
(
..
),
Argument
(
..
),
Argument
(
..
),
...
@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
...
@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
import
Data.List
(
findIndex
)
import
Data.List
(
findIndex
)
import
IHaskell.Types
import
IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with
-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
-- the mode being invoked.
data
Args
=
Args
IHaskellMode
[
Argument
]
data
Args
=
Args
IHaskellMode
[
Argument
]
deriving
Show
deriving
Show
...
@@ -33,30 +33,29 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
...
@@ -33,30 +33,29 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
|
ConvertLhsStyle
(
LhsStyle
String
)
|
ConvertLhsStyle
(
LhsStyle
String
)
deriving
(
Eq
,
Show
)
deriving
(
Eq
,
Show
)
data
LhsStyle
string
=
LhsStyle
{
lhsCodePrefix
::
string
-- ^ @>@
data
LhsStyle
string
=
,
lhsOutputPrefix
::
string
-- ^ @<<@
LhsStyle
,
lhsBeginCode
::
string
-- ^ @\\begin{code}@
{
lhsCodePrefix
::
string
-- ^ @>@
,
lhsEndCode
::
string
-- ^ @\\end{code}@
,
lhsOutputPrefix
::
string
-- ^ @<<@
,
lhsBeginOutput
::
string
-- ^ @\\begin{verbatim}@
,
lhsBeginCode
::
string
-- ^ @\\begin{code}@
,
lhsEndOutput
::
string
-- ^ @\\end{verbatim}@
,
lhsEndCode
::
string
-- ^ @\\end{code}@
}
,
lhsBeginOutput
::
string
-- ^ @\\begin{verbatim}@
,
lhsEndOutput
::
string
-- ^ @\\end{verbatim}@
}
deriving
(
Eq
,
Functor
,
Show
)
deriving
(
Eq
,
Functor
,
Show
)
data
NotebookFormat
=
LhsMarkdown
data
NotebookFormat
=
LhsMarkdown
|
IpynbFile
|
IpynbFile
deriving
(
Eq
,
Show
)
deriving
(
Eq
,
Show
)
-- Which mode IHaskell is being invoked in.
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data
IHaskellMode
=
ShowHelp
String
data
IHaskellMode
=
ShowHelp
String
|
InstallKernelSpec
|
InstallKernelSpec
|
ConvertLhs
|
ConvertLhs
|
Kernel
(
Maybe
String
)
|
Kernel
(
Maybe
String
)
deriving
(
Eq
,
Show
)
deriving
(
Eq
,
Show
)
-- | Given a list of command-line arguments, return the IHaskell mode and
-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
-- arguments to process.
parseFlags
::
[
String
]
->
Either
String
Args
parseFlags
::
[
String
]
->
Either
String
Args
parseFlags
flags
=
parseFlags
flags
=
let
modeIndex
=
findIndex
(`
elem
`
modeFlags
)
flags
let
modeIndex
=
findIndex
(`
elem
`
modeFlags
)
flags
...
@@ -111,7 +110,8 @@ installKernelSpec =
...
@@ -111,7 +110,8 @@ installKernelSpec =
[
ghcLibFlag
,
kernelDebugFlag
,
confFlag
,
helpFlag
]
[
ghcLibFlag
,
kernelDebugFlag
,
confFlag
,
helpFlag
]
kernel
::
Mode
Args
kernel
::
Mode
Args
kernel
=
mode
"kernel"
(
Args
(
Kernel
Nothing
)
[]
)
"Invoke the IHaskell kernel."
kernelArg
[
ghcLibFlag
,
kernelDebugFlag
,
confFlag
]
kernel
=
mode
"kernel"
(
Args
(
Kernel
Nothing
)
[]
)
"Invoke the IHaskell kernel."
kernelArg
[
ghcLibFlag
,
kernelDebugFlag
,
confFlag
]
where
where
kernelArg
=
flagArg
update
"<json-kernel-file>"
kernelArg
=
flagArg
update
"<json-kernel-file>"
update
filename
(
Args
_
flags
)
=
Right
$
Args
(
Kernel
$
Just
filename
)
flags
update
filename
(
Args
_
flags
)
=
Right
$
Args
(
Kernel
$
Just
filename
)
flags
...
@@ -154,16 +154,17 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
...
@@ -154,16 +154,17 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
lhsStyleBird
,
lhsStyleTex
::
LhsStyle
String
lhsStyleBird
,
lhsStyleTex
::
LhsStyle
String
lhsStyleBird
=
LhsStyle
"> "
"
\n
<< "
""
""
""
""
lhsStyleBird
=
LhsStyle
"> "
"
\n
<< "
""
""
""
""
lhsStyleTex
=
LhsStyle
""
""
"
\\
begin{code}"
"
\\
end{code}"
"
\\
begin{verbatim}"
"
\\
end{verbatim}"
lhsStyleTex
=
LhsStyle
""
""
"
\\
begin{code}"
"
\\
end{code}"
"
\\
begin{verbatim}"
"
\\
end{verbatim}"
ihaskellArgs
::
Mode
Args
ihaskellArgs
::
Mode
Args
ihaskellArgs
=
ihaskellArgs
=
let
descr
=
"Haskell for Interactive Computing."
let
descr
=
"Haskell for Interactive Computing."
helpStr
=
showText
(
Wrap
100
)
$
helpText
[]
HelpFormatAll
ihaskellArgs
helpStr
=
showText
(
Wrap
100
)
$
helpText
[]
HelpFormatAll
ihaskellArgs
onlyHelp
=
[
flagHelpSimple
(
add
Help
)]
onlyHelp
=
[
flagHelpSimple
(
add
Help
)]
noMode
=
mode
"IHaskell"
(
Args
(
ShowHelp
helpStr
)
[]
)
descr
noArgs
onlyHelp
in
noMode
=
mode
"IHaskell"
(
Args
(
ShowHelp
helpStr
)
[]
)
descr
noArgs
onlyHelp
noMode
{
modeGroupModes
=
toGroup
allModes
}
in
noMode
{
modeGroupModes
=
toGroup
allModes
}
where
where
add
flag
(
Args
mode
flags
)
=
Args
mode
$
flag
:
flags
add
flag
(
Args
mode
flags
)
=
Args
mode
$
flag
:
flags
noArgs
=
flagArg
unexpected
""
noArgs
=
flagArg
unexpected
""
...
...
src/IHaskell/IPython.hs
View file @
7ba7c4d1
...
@@ -40,17 +40,20 @@ import qualified GHC.Paths
...
@@ -40,17 +40,20 @@ import qualified GHC.Paths
import
IHaskell.Types
import
IHaskell.Types
import
System.Posix.Signals
import
System.Posix.Signals
data
KernelSpecOptions
=
data
KernelSpecOptions
=
KernelSpecOptions
{
kernelSpecGhcLibdir
::
String
-- ^ GHC libdir.
KernelSpecOptions
,
kernelSpecDebug
::
Bool
-- ^ Spew debugging output?
{
kernelSpecGhcLibdir
::
String
-- ^ GHC libdir.
,
kernelSpecConfFile
::
IO
(
Maybe
String
)
-- ^ Filename of profile JSON file.
,
kernelSpecDebug
::
Bool
-- ^ Spew debugging output?
}
,
kernelSpecConfFile
::
IO
(
Maybe
String
)
-- ^ Filename of profile JSON file.
}
defaultKernelSpecOptions
::
KernelSpecOptions
defaultKernelSpecOptions
::
KernelSpecOptions
defaultKernelSpecOptions
=
KernelSpecOptions
{
kernelSpecGhcLibdir
=
GHC
.
Paths
.
libdir
defaultKernelSpecOptions
=
KernelSpecOptions
,
kernelSpecDebug
=
False
{
kernelSpecGhcLibdir
=
GHC
.
Paths
.
libdir
,
kernelSpecConfFile
=
defaultConfFile
,
kernelSpecDebug
=
False
}
,
kernelSpecConfFile
=
defaultConfFile
}
-- | The IPython kernel name.
-- | The IPython kernel name.
kernelName
::
IsString
a
=>
a
kernelName
::
IsString
a
=>
a
kernelName
=
"haskell"
kernelName
=
"haskell"
...
@@ -133,6 +136,7 @@ verifyIPythonVersion = do
...
@@ -133,6 +136,7 @@ verifyIPythonVersion = do
Just
(
1
:
_
)
->
oldIPython
Just
(
1
:
_
)
->
oldIPython
Just
(
0
:
_
)
->
oldIPython
Just
(
0
:
_
)
->
oldIPython
_
->
badIPython
"Detected IPython, but could not parse version number."
_
->
badIPython
"Detected IPython, but could not parse version number."
where
where
badIPython
::
Text
->
Sh
()
badIPython
::
Text
->
Sh
()
badIPython
message
=
liftIO
$
do
badIPython
message
=
liftIO
$
do
...
@@ -140,8 +144,8 @@ verifyIPythonVersion = do
...
@@ -140,8 +144,8 @@ verifyIPythonVersion = do
exitFailure
exitFailure
oldIPython
=
badIPython
"Detected old version of IPython. IHaskell requires 3.0.0 or up."
oldIPython
=
badIPython
"Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location.
-- | Install an IHaskell kernelspec into the right location.
The right location is determined by
--
The right location is determined by
using `ipython kernelspec install --user`.
-- using `ipython kernelspec install --user`.
installKernelspec
::
Bool
->
KernelSpecOptions
->
Sh
()
installKernelspec
::
Bool
->
KernelSpecOptions
->
Sh
()
installKernelspec
replace
opts
=
void
$
do
installKernelspec
replace
opts
=
void
$
do
ihaskellPath
<-
getIHaskellPath
ihaskellPath
<-
getIHaskellPath
...
@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
...
@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
Just
file
->
[
"--conf"
,
file
])
Just
file
->
[
"--conf"
,
file
])
++
[
"--ghclib"
,
kernelSpecGhcLibdir
opts
]
++
[
"--ghclib"
,
kernelSpecGhcLibdir
opts
]
let
kernelSpec
=
KernelSpec
{
kernelDisplayName
=
"Haskell"
let
kernelSpec
=
KernelSpec
,
kernelLanguage
=
kernelName
{
kernelDisplayName
=
"Haskell"
,
kernelCommand
=
[
ihaskellPath
,
"kernel"
,
"{connection_file}"
]
++
kernelFlags
,
kernelLanguage
=
kernelName
}
,
kernelCommand
=
[
ihaskellPath
,
"kernel"
,
"{connection_file}"
]
++
kernelFlags
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec
-- Create a temporary directory. Use this temporary directory to make a kernelspec
directory; then,
--
directory; then,
shell out to IPython to install this kernelspec directory.
-- shell out to IPython to install this kernelspec directory.
withTmpDir
$
\
tmp
->
do
withTmpDir
$
\
tmp
->
do
let
kernelDir
=
tmp
</>
kernelName
let
kernelDir
=
tmp
</>
kernelName
let
filename
=
kernelDir
</>
"kernel.json"
let
filename
=
kernelDir
</>
"kernel.json"
...
@@ -180,21 +185,19 @@ installKernelspec replace opts = void $ do
...
@@ -180,21 +185,19 @@ installKernelspec replace opts = void $ do
kernelSpecCreated
::
Sh
Bool
kernelSpecCreated
::
Sh
Bool
kernelSpecCreated
=
do
kernelSpecCreated
=
do
Just
ipython
<-
which
"ipython"
Just
ipython
<-
which
"ipython"
out
<-
silently
$
run
ipython
[
"kernelspec"
,
"list"
]
out
<-
silently
$
run
ipython
[
"kernelspec"
,
"list"
]
let
kernelspecs
=
map
T
.
strip
$
lines
out
let
kernelspecs
=
map
T
.
strip
$
lines
out
return
$
kernelName
`
elem
`
kernelspecs
return
$
kernelName
`
elem
`
kernelspecs
-- | Replace "~" with $HOME if $HOME is defined.
-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
-- Otherwise, do nothing.
subHome
::
String
->
IO
String
subHome
::
String
->
IO
String
subHome
path
=
shelly
$
do
subHome
path
=
shelly
$
do
home
<-
unpack
<$>
fromMaybe
"~"
<$>
get_env
"HOME"
home
<-
unpack
<$>
fromMaybe
"~"
<$>
get_env
"HOME"
return
$
replace
"~"
home
path
return
$
replace
"~"
home
path
-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- | Get the path to an executable. If it doensn't exist, fail with an
-- about it.
-- error message complaining about it.
path
::
Text
->
Sh
FilePath
path
::
Text
->
Sh
FilePath
path
exe
=
do
path
exe
=
do
path
<-
which
$
fromText
exe
path
<-
which
$
fromText
exe
...
@@ -229,9 +232,8 @@ getIHaskellPath = do
...
@@ -229,9 +232,8 @@ getIHaskellPath = do
if
FS
.
absolute
f
if
FS
.
absolute
f
then
return
$
FS
.
encodeString
f
then
return
$
FS
.
encodeString
f
else
else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH
-- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH
-- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
-- variable to find where IHaskell lives.
if
FS
.
filename
f
==
f
if
FS
.
filename
f
==
f
then
do
then
do
ihaskellPath
<-
which
"ihaskell"
ihaskellPath
<-
which
"ihaskell"
...
...
src/IHaskell/Types.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric
, ExistentialQuantification
#-}
{-# LANGUAGE ExistentialQuantification #-}
-- | Description : All message type definitions.
-- | Description : All message type definitions.
module
IHaskell.Types
(
module
IHaskell.Types
(
Message
(
..
),
Message
(
..
),
MessageHeader
(
..
),
MessageHeader
(
..
),
MessageType
(
..
),
MessageType
(
..
),
Username
,
Username
,
Metadata
(
..
),
Metadata
(
..
),
replyType
,
replyType
,
ExecutionState
(
..
),
ExecutionState
(
..
),
StreamType
(
..
),
StreamType
(
..
),
MimeType
(
..
),
MimeType
(
..
),
DisplayData
(
..
),
DisplayData
(
..
),
EvaluationResult
(
..
),
EvaluationResult
(
..
),
ExecuteReplyStatus
(
..
),
ExecuteReplyStatus
(
..
),
KernelState
(
..
),
KernelState
(
..
),
LintStatus
(
..
),
LintStatus
(
..
),
Width
,
Height
,
Width
,
Display
(
..
),
Height
,
defaultKernelState
,
Display
(
..
),
extractPlain
,
defaultKernelState
,
kernelOpts
,
extractPlain
,
KernelOpt
(
..
),
kernelOpts
,
IHaskellDisplay
(
..
),
KernelOpt
(
..
),
IHaskellWidget
(
..
),
IHaskellDisplay
(
..
),
Widget
(
..
),
IHaskellWidget
(
..
),
CommInfo
(
..
),
Widget
(
..
),
KernelSpec
(
..
),
CommInfo
(
..
),
)
where
KernelSpec
(
..
),
)
where
import
ClassyPrelude
import
ClassyPrelude
import
qualified
Data.ByteString.Char8
as
Char
import
qualified
Data.ByteString.Char8
as
Char
...
@@ -40,8 +41,8 @@ import IHaskell.IPython.Kernel
...
@@ -40,8 +41,8 @@ import IHaskell.IPython.Kernel
-- | A class for displayable Haskell types.
-- | A class for displayable Haskell types.
--
--
-- IHaskell's displaying of results behaves as if these two
-- IHaskell's displaying of results behaves as if these two
overlapping/undecidable instances also
--
overlapping/undecidable instances also
existed:
-- existed:
--
--
-- > instance (Show a) => IHaskellDisplay a
-- > instance (Show a) => IHaskellDisplay a
-- > instance Show a where shows _ = id
-- > instance Show a where shows _ = id
...
@@ -50,12 +51,10 @@ class IHaskellDisplay a where
...
@@ -50,12 +51,10 @@ class IHaskellDisplay a where
-- | Display as an interactive widget.
-- | Display as an interactive widget.
class
IHaskellDisplay
a
=>
IHaskellWidget
a
where
class
IHaskellDisplay
a
=>
IHaskellWidget
a
where
-- | Output target name for this widget.
-- | Output target name for this widget. The actual input parameter should be ignored.
-- The actual input parameter should be ignored.
targetName
::
a
->
String
targetName
::
a
->
String
-- | Called when the comm is opened. Allows additional messages to be sent
-- | Called when the comm is opened. Allows additional messages to be sent after comm open.
-- after comm open.
open
::
a
-- ^ Widget to open a comm port with.
open
::
a
-- ^ Widget to open a comm port with.
->
(
Value
->
IO
()
)
-- ^ Way to respond to the message.
->
(
Value
->
IO
()
)
-- ^ Way to respond to the message.
->
IO
()
->
IO
()
...
@@ -75,7 +74,7 @@ class IHaskellDisplay a => IHaskellWidget a where
...
@@ -75,7 +74,7 @@ class IHaskellDisplay a => IHaskellWidget a where
close
_
_
=
return
()
close
_
_
=
return
()
data
Widget
=
forall
a
.
IHaskellWidget
a
=>
Widget
a
data
Widget
=
forall
a
.
IHaskellWidget
a
=>
Widget
a
deriving
Typeable
deriving
Typeable
instance
IHaskellDisplay
Widget
where
instance
IHaskellDisplay
Widget
where
display
(
Widget
widget
)
=
display
widget
display
(
Widget
widget
)
=
display
widget
...
@@ -89,86 +88,92 @@ instance IHaskellWidget Widget where
...
@@ -89,86 +88,92 @@ instance IHaskellWidget Widget where
instance
Show
Widget
where
instance
Show
Widget
where
show
_
=
"<Widget>"
show
_
=
"<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
-- expression.
-- results from the same expression.
data
Display
=
Display
[
DisplayData
]
data
Display
=
Display
[
DisplayData
]
|
ManyDisplay
[
Display
]
|
ManyDisplay
[
Display
]
deriving
(
Show
,
Typeable
,
Generic
)
deriving
(
Show
,
Typeable
,
Generic
)
instance
Serialize
Display
instance
Serialize
Display
instance
Monoid
Display
where
instance
Monoid
Display
where
mempty
=
Display
[]
mempty
=
Display
[]
ManyDisplay
a
`
mappend
`
ManyDisplay
b
=
ManyDisplay
(
a
++
b
)
ManyDisplay
a
`
mappend
`
ManyDisplay
b
=
ManyDisplay
(
a
++
b
)
ManyDisplay
a
`
mappend
`
b
=
ManyDisplay
(
a
++
[
b
])
ManyDisplay
a
`
mappend
`
b
=
ManyDisplay
(
a
++
[
b
])
a
`
mappend
`
ManyDisplay
b
=
ManyDisplay
(
a
:
b
)
a
`
mappend
`
ManyDisplay
b
=
ManyDisplay
(
a
:
b
)
a
`
mappend
`
b
=
ManyDisplay
[
a
,
b
]
a
`
mappend
`
b
=
ManyDisplay
[
a
,
b
]
instance
Semigroup
Display
where
instance
Semigroup
Display
where
a
<>
b
=
a
`
mappend
`
b
a
<>
b
=
a
`
mappend
`
b
-- | All state stored in the kernel between executions.
-- | All state stored in the kernel between executions.
data
KernelState
=
KernelState
{
getExecutionCounter
::
Int
data
KernelState
=
,
getLintStatus
::
LintStatus
-- Whether to use hlint, and what arguments to pass it.
KernelState
,
useSvg
::
Bool
{
getExecutionCounter
::
Int
,
useShowErrors
::
Bool
,
getLintStatus
::
LintStatus
-- Whether to use hlint, and what arguments to pass it.
,
useShowTypes
::
Bool
,
useSvg
::
Bool
,
usePager
::
Bool
,
useShowErrors
::
Bool
,
openComms
::
Map
UUID
Widget
,
useShowTypes
::
Bool
,
kernelDebug
::
Bool
,
usePager
::
Bool
}
,
openComms
::
Map
UUID
Widget
,
kernelDebug
::
Bool
}
deriving
Show
deriving
Show
defaultKernelState
::
KernelState
defaultKernelState
::
KernelState
defaultKernelState
=
KernelState
{
getExecutionCounter
=
1
defaultKernelState
=
KernelState
,
getLintStatus
=
LintOn
{
getExecutionCounter
=
1
,
useSvg
=
True
,
getLintStatus
=
LintOn
,
useShowErrors
=
False
,
useSvg
=
True
,
useShowTypes
=
False
,
useShowErrors
=
False
,
usePager
=
True
,
useShowTypes
=
False
,
openComms
=
empty
,
usePager
=
True
,
kernelDebug
=
False
,
openComms
=
empty
}
,
kernelDebug
=
False
}
-- | Kernel options to be set via `:set` and `:option`.
-- | Kernel options to be set via `:set` and `:option`.
data
KernelOpt
=
KernelOpt
{
data
KernelOpt
=
getOptionName
::
[
String
],
-- ^ Ways to set this option via `:option`
KernelOpt
getSetName
::
[
String
],
-- ^ Ways to set this option via `:set`
{
getOptionName
::
[
String
]
-- ^ Ways to set this option via `:option`
getUpdateKernelState
::
KernelState
->
KernelState
-- ^ Function to update the kernel state.
,
getSetName
::
[
String
]
-- ^ Ways to set this option via `:set`
}
,
getUpdateKernelState
::
KernelState
->
KernelState
-- ^ Function to update the kernel
-- state.
}
kernelOpts
::
[
KernelOpt
]
kernelOpts
::
[
KernelOpt
]
kernelOpts
=
kernelOpts
=
[
KernelOpt
[
"lint"
]
[]
$
\
state
->
state
{
getLintStatus
=
LintOn
}
[
KernelOpt
[
"lint"
]
[]
$
\
state
->
state
{
getLintStatus
=
LintOn
}
,
KernelOpt
[
"no-lint"
]
[]
$
\
state
->
state
{
getLintStatus
=
LintOff
}
,
KernelOpt
[
"no-lint"
]
[]
$
\
state
->
state
{
getLintStatus
=
LintOff
}
,
KernelOpt
[
"svg"
]
[]
$
\
state
->
state
{
useSvg
=
True
}
,
KernelOpt
[
"svg"
]
[]
$
\
state
->
state
{
useSvg
=
True
}
,
KernelOpt
[
"no-svg"
]
[]
$
\
state
->
state
{
useSvg
=
False
}
,
KernelOpt
[
"no-svg"
]
[]
$
\
state
->
state
{
useSvg
=
False
}
,
KernelOpt
[
"show-types"
]
[
"+t"
]
$
\
state
->
state
{
useShowTypes
=
True
}
,
KernelOpt
[
"show-types"
]
[
"+t"
]
$
\
state
->
state
{
useShowTypes
=
True
}
,
KernelOpt
[
"no-show-types"
]
[
"-t"
]
$
\
state
->
state
{
useShowTypes
=
False
}
,
KernelOpt
[
"no-show-types"
]
[
"-t"
]
$
\
state
->
state
{
useShowTypes
=
False
}
,
KernelOpt
[
"show-errors"
]
[]
$
\
state
->
state
{
useShowErrors
=
True
}
,
KernelOpt
[
"show-errors"
]
[]
$
\
state
->
state
{
useShowErrors
=
True
}
,
KernelOpt
[
"no-show-errors"
]
[]
$
\
state
->
state
{
useShowErrors
=
False
}
,
KernelOpt
[
"no-show-errors"
]
[]
$
\
state
->
state
{
useShowErrors
=
False
}
,
KernelOpt
[
"pager"
]
[]
$
\
state
->
state
{
usePager
=
True
}
,
KernelOpt
[
"pager"
]
[]
$
\
state
->
state
{
usePager
=
True
}
,
KernelOpt
[
"no-pager"
]
[]
$
\
state
->
state
{
usePager
=
False
}
,
KernelOpt
[
"no-pager"
]
[]
$
\
state
->
state
{
usePager
=
False
}
]
]
-- | Current HLint status.
-- | Current HLint status.
data
LintStatus
data
LintStatus
=
LintOn
=
LintOn
|
LintOff
|
LintOff
deriving
(
Eq
,
Show
)
deriving
(
Eq
,
Show
)
data
CommInfo
=
CommInfo
Widget
UUID
String
deriving
Show
data
CommInfo
=
CommInfo
Widget
UUID
String
deriving
Show
-- | Output of evaluation.
-- | Output of evaluation.
data
EvaluationResult
=
data
EvaluationResult
=
-- | An intermediate result which communicates what has been printed thus
-- | An intermediate result which communicates what has been printed thus
-- far.
-- far.
IntermediateResult
{
IntermediateResult
outputs
::
Display
-- ^ Display outputs.
{
outputs
::
Display
-- ^ Display outputs.
}
}
|
FinalResult
{
|
outputs
::
Display
,
-- ^ Display outputs.
FinalResult
pagerOut
::
String
,
-- ^ Text to display in the IPython pager.
{
outputs
::
Display
-- ^ Display outputs.
startComms
::
[
CommInfo
]
-- ^ Comms to start.
,
pagerOut
::
String
-- ^ Text to display in the IPython pager.
}
,
startComms
::
[
CommInfo
]
-- ^ Comms to start.
}
deriving
Show
deriving
Show
src/Main.hs
View file @
7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-- | 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
(
main
)
where
-- Prelude imports.
-- Prelude imports.
import
ClassyPrelude
hiding
(
last
,
liftIO
,
readChan
,
writeChan
)
import
ClassyPrelude
hiding
(
last
,
liftIO
,
readChan
,
writeChan
)
...
@@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do
...
@@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do
showingHelp
::
IHaskellMode
->
[
Argument
]
->
IO
()
->
IO
()
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
_
->
putStrLn
$
pack
$
help
mode
putStrLn
$
pack
$
help
mode
Nothing
->
Nothing
->
...
@@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do
...
@@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do
-- Receive and reply to all messages on the shell socket.
-- Receive and reply to all messages on the shell socket.
interpret
libdir
True
$
do
interpret
libdir
True
$
do
-- Ignore Ctrl-C the first time. This has to go inside the
-- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
-- `interpret`, because GHC API resets the signal handlers for some
-- signal handlers for some reason (completely unknown to me).
-- reason (completely unknown to me).
liftIO
ignoreCtrlC
liftIO
ignoreCtrlC
-- Initialize the context by evaluating everything we got from the
-- Initialize the context by evaluating everything we got from the command line flags.
-- command line flags.
let
noPublish
_
=
return
()
let
noPublish
_
=
return
()
evaluator
line
=
void
$
do
evaluator
line
=
void
$
do
-- Create a new state each time.
-- Create a new state each time.
...
@@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do
...
@@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do
confFile
<-
liftIO
$
kernelSpecConfFile
kernelOpts
confFile
<-
liftIO
$
kernelSpecConfFile
kernelOpts
case
confFile
of
case
confFile
of
Just
filename
->
liftIO
(
readFile
$
fpFromString
filename
)
>>=
evaluator
Just
filename
->
liftIO
(
readFile
$
fpFromString
filename
)
>>=
evaluator
Nothing
->
return
()
Nothing
->
return
()
forever
$
do
forever
$
do
-- Read the request from the request channel.
-- Read the request from the request channel.
...
@@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do
...
@@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do
-- Create a header for the reply.
-- Create a header for the reply.
replyHeader
<-
createReplyHeader
(
header
request
)
replyHeader
<-
createReplyHeader
(
header
request
)
-- We handle comm messages and normal ones separately.
-- We handle comm messages and normal ones separately. The normal ones are a standard
-- The normal ones are a standard request/response style, while comms
-- request/response style, while comms can be anything, and don't necessarily require a response.
-- can be anything, and don't necessarily require a response.
if
isCommMessage
request
if
isCommMessage
request
then
liftIO
$
do
then
liftIO
$
do
oldState
<-
takeMVar
state
oldState
<-
takeMVar
state
...
@@ -185,62 +183,59 @@ createReplyHeader parent = do
...
@@ -185,62 +183,59 @@ createReplyHeader parent = do
let
repType
=
fromMaybe
err
(
replyType
$
msgType
parent
)
let
repType
=
fromMaybe
err
(
replyType
$
msgType
parent
)
err
=
error
$
"No reply for message "
++
show
(
msgType
parent
)
err
=
error
$
"No reply for message "
++
show
(
msgType
parent
)
return
MessageHeader
{
return
identifiers
=
identifiers
parent
,
MessageHeader
parentHeader
=
Just
parent
,
{
identifiers
=
identifiers
parent
metadata
=
Map
.
fromList
[]
,
,
parentHeader
=
Just
parent
messageId
=
newMessageId
,
,
metadata
=
Map
.
fromList
[]
sessionId
=
sessionId
parent
,
,
messageId
=
newMessageId
username
=
username
parent
,
,
sessionId
=
sessionId
parent
msgType
=
repType
,
username
=
username
parent
}
,
msgType
=
repType
}
-- | Compute a reply to a message.
-- | Compute a reply to a message.
replyTo
::
ZeroMQInterface
->
Message
->
MessageHeader
->
KernelState
->
Interpreter
(
KernelState
,
Message
)
replyTo
::
ZeroMQInterface
->
Message
->
MessageHeader
->
KernelState
->
Interpreter
(
KernelState
,
Message
)
-- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
-- Reply to kernel info requests with a kernel info reply. No computation
-- kernel info reply is a static object (all info is hard coded into the representation of that
-- needs to be done, as a kernel info reply is a static object (all info is
-- message type).
-- hard coded into the representation of that message type).
replyTo
_
KernelInfoRequest
{}
replyHeader
state
=
replyTo
_
KernelInfoRequest
{}
replyHeader
state
=
return
(
state
,
KernelInfoReply
{
return
header
=
replyHeader
,
(
state
,
KernelInfoReply
language
=
"haskell"
,
{
header
=
replyHeader
versionList
=
ghcVersionInts
,
language
=
"haskell"
})
,
versionList
=
ghcVersionInts
})
-- Reply to a shutdown request by exiting the main thread.
-- Before shutdown, reply to the request to let the frontend know shutdown
-- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- is happening.
-- let the frontend know shutdown is happening.
replyTo
interface
ShutdownRequest
{
restartPending
=
restartPending
}
replyHeader
_
=
liftIO
$
do
replyTo
interface
ShutdownRequest
{
restartPending
=
restartPending
}
replyHeader
_
=
liftIO
$
do
writeChan
(
shellReplyChannel
interface
)
$
ShutdownReply
replyHeader
restartPending
writeChan
(
shellReplyChannel
interface
)
$
ShutdownReply
replyHeader
restartPending
exitSuccess
exitSuccess
-- Reply to an execution request. The reply itself does not require
-- Reply to an execution request. The reply itself does not require computation, but this causes
-- computation, but this causes messages to be sent to the IOPub socket
-- messages to be sent to the IOPub socket with the output of the code in the execution request.
-- with the output of the code in the execution request.
replyTo
interface
req
@
ExecuteRequest
{
getCode
=
code
}
replyHeader
state
=
do
replyTo
interface
req
@
ExecuteRequest
{
getCode
=
code
}
replyHeader
state
=
do
-- Convenience function to send a message to the IOPub socket.
-- Convenience function to send a message to the IOPub socket.
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.
dir
<-
liftIO
getIHaskellDir
dir
<-
liftIO
getIHaskellDir
liftIO
$
Stdin
.
recordParentHeader
dir
$
header
req
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
-- All the headers are copies of the reply header with a different
-- header with a different message type, because this preserves the session ID, parent header, and
-- message type, because this preserves the session ID, parent header,
-- other important information.
-- and other important information.
busyHeader
<-
liftIO
$
dupHeader
replyHeader
StatusMessage
busyHeader
<-
liftIO
$
dupHeader
replyHeader
StatusMessage
send
$
PublishStatus
busyHeader
Busy
send
$
PublishStatus
busyHeader
Busy
-- Construct a function for publishing output as this is going.
-- Construct a function for publishing output as this is going. This function accepts a boolean
-- This function accepts a boolean indicating whether this is the final
-- indicating whether this is the final output and the thing to display. Store the final outputs in
-- output and the thing to display. Store the final outputs in a list so
-- a list so that when we receive an updated non-final output, we can clear the entire output and
-- that when we receive an updated non-final output, we can clear the
-- re-display with the updated output.
-- entire output and re-display with the updated output.
displayed
<-
liftIO
$
newMVar
[]
displayed
<-
liftIO
$
newMVar
[]
updateNeeded
<-
liftIO
$
newMVar
False
updateNeeded
<-
liftIO
$
newMVar
False
pagerOutput
<-
liftIO
$
newMVar
""
pagerOutput
<-
liftIO
$
newMVar
""
let
clearOutput
=
do
let
clearOutput
=
do
header
<-
dupHeader
replyHeader
ClearOutputMessage
header
<-
dupHeader
replyHeader
ClearOutputMessage
send
$
ClearOutput
header
True
send
$
ClearOutput
header
True
...
@@ -254,7 +249,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
...
@@ -254,7 +249,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
convertSvgToHtml
x
=
x
convertSvgToHtml
x
=
x
makeSvgImg
base64data
=
unpack
$
"<img src=
\"
data:image/svg+xml;base64,"
++
base64data
++
"
\"
/>"
makeSvgImg
base64data
=
unpack
$
"<img src=
\"
data:image/svg+xml;base64,"
++
base64data
++
"
\"
/>"
prependCss
(
DisplayData
MimeHtml
html
)
=
DisplayData
MimeHtml
$
concat
[
"<style>"
,
pack
ihaskellCSS
,
"</style>"
,
html
]
prependCss
(
DisplayData
MimeHtml
html
)
=
DisplayData
MimeHtml
$
concat
[
"<style>"
,
pack
ihaskellCSS
,
"</style>"
,
html
]
prependCss
x
=
x
prependCss
x
=
x
startComm
::
CommInfo
->
IO
()
startComm
::
CommInfo
->
IO
()
...
@@ -271,9 +267,10 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
...
@@ -271,9 +267,10 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
publish
::
EvaluationResult
->
IO
()
publish
::
EvaluationResult
->
IO
()
publish
result
=
do
publish
result
=
do
let
final
=
case
result
of
let
final
=
IntermediateResult
{}
->
False
case
result
of
FinalResult
{}
->
True
IntermediateResult
{}
->
False
FinalResult
{}
->
True
outs
=
outputs
result
outs
=
outputs
result
-- If necessary, clear all previous output and redraw.
-- If necessary, clear all previous output and redraw.
...
@@ -286,12 +283,11 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
...
@@ -286,12 +283,11 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
-- Draw this message.
-- Draw this message.
sendOutput
outs
sendOutput
outs
-- If this is the final message, add it to the list of completed
-- If this is the final message, add it to the list of completed messages. If it isn't, make sure we
-- messages. If it isn't, make sure we clear it later by marking
-- clear it later by marking update needed as true.
-- update needed as true.
modifyMVar_
updateNeeded
(
const
$
return
$
not
final
)
modifyMVar_
updateNeeded
(
const
$
return
$
not
final
)
when
final
$
do
when
final
$
do
modifyMVar_
displayed
(
return
.
(
outs
:
))
modifyMVar_
displayed
(
return
.
(
outs
:
))
-- Start all comms that need to be started.
-- Start all comms that need to be started.
mapM_
startComm
$
startComms
result
mapM_
startComm
$
startComms
result
...
@@ -300,8 +296,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
...
@@ -300,8 +296,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
let
pager
=
pagerOut
result
let
pager
=
pagerOut
result
unless
(
null
pager
)
$
unless
(
null
pager
)
$
if
usePager
state
if
usePager
state
then
modifyMVar_
pagerOutput
(
return
.
(
++
pager
++
"
\n
"
))
then
modifyMVar_
pagerOutput
(
return
.
(
++
pager
++
"
\n
"
))
else
sendOutput
$
Display
[
html
pager
]
else
sendOutput
$
Display
[
html
pager
]
let
execCount
=
getExecutionCounter
state
let
execCount
=
getExecutionCounter
state
-- Let all frontends know the execution count and code that's about to run
-- Let all frontends know the execution count and code that's about to run
...
@@ -317,14 +313,15 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
...
@@ -317,14 +313,15 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
-- Take pager output if we're using the pager.
-- Take pager output if we're using the pager.
pager
<-
if
usePager
state
pager
<-
if
usePager
state
then
liftIO
$
readMVar
pagerOutput
then
liftIO
$
readMVar
pagerOutput
else
return
""
else
return
""
return
(
updatedState
,
ExecuteReply
{
return
header
=
replyHeader
,
(
updatedState
,
ExecuteReply
pagerOutput
=
pager
,
{
header
=
replyHeader
executionCounter
=
execCount
,
,
pagerOutput
=
pager
status
=
Ok
,
executionCounter
=
execCount
})
,
status
=
Ok
})
replyTo
_
req
@
CompleteRequest
{}
replyHeader
state
=
do
replyTo
_
req
@
CompleteRequest
{}
replyHeader
state
=
do
...
@@ -334,28 +331,29 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
...
@@ -334,28 +331,29 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
let
start
=
pos
-
length
matchedText
let
start
=
pos
-
length
matchedText
end
=
pos
end
=
pos
reply
=
CompleteReply
replyHeader
(
map
pack
completions
)
start
end
Map
.
empty
True
reply
=
CompleteReply
replyHeader
(
map
pack
completions
)
start
end
Map
.
empty
True
return
(
state
,
reply
)
return
(
state
,
reply
)
-- Reply to the object_info_request message. Given an object name, return
-- Reply to the object_info_request message. Given an object name, return
the associated type
--
the associated type
calculated by GHC.
-- calculated by GHC.
replyTo
_
ObjectInfoRequest
{
objectName
=
oname
}
replyHeader
state
=
do
replyTo
_
ObjectInfoRequest
{
objectName
=
oname
}
replyHeader
state
=
do
docs
<-
pack
<$>
info
(
unpack
oname
)
docs
<-
pack
<$>
info
(
unpack
oname
)
let
reply
=
ObjectInfoReply
{
let
reply
=
ObjectInfoReply
header
=
replyHeader
,
{
header
=
replyHeader
objectName
=
oname
,
,
objectName
=
oname
objectFound
=
strip
docs
/=
""
,
,
objectFound
=
strip
docs
/=
""
objectTypeString
=
docs
,
,
objectTypeString
=
docs
objectDocString
=
docs
,
objectDocString
=
docs
}
}
return
(
state
,
reply
)
return
(
state
,
reply
)
-- TODO: Implement history_reply.
-- TODO: Implement history_reply.
replyTo
_
HistoryRequest
{}
replyHeader
state
=
do
replyTo
_
HistoryRequest
{}
replyHeader
state
=
do
let
reply
=
HistoryReply
{
let
reply
=
HistoryReply
header
=
replyHeader
,
{
header
=
replyHeader
historyReply
=
[]
-- FIXME
-- FIXME
}
,
historyReply
=
[]
}
return
(
state
,
reply
)
return
(
state
,
reply
)
handleComm
::
(
Message
->
IO
()
)
->
KernelState
->
Message
->
MessageHeader
->
IO
KernelState
handleComm
::
(
Message
->
IO
()
)
->
KernelState
->
Message
->
MessageHeader
->
IO
KernelState
...
...
verify_formatting.py
0 → 100755
View file @
7ba7c4d1
#!/usr/bin/env python3
from
__future__
import
print_function
import
sys
import
os
import
subprocess
def
hindent
(
contents
):
with
open
(
".tmp3"
,
"w"
)
as
f
:
f
.
write
(
contents
)
with
open
(
".tmp3"
,
"r"
)
as
f
:
output
=
subprocess
.
check_output
([
"hindent"
,
"--style"
,
"gibiansky"
],
stdin
=
f
)
return
output
.
decode
(
'utf-8'
)
def
diff
(
src1
,
src2
):
# Ignore trailing newlines
if
src1
[
-
1
]
==
"
\n
"
:
src1
=
src1
[:
-
1
]
if
src2
[
-
1
]
==
"
\n
"
:
src2
=
src2
[:
-
1
]
with
open
(
".tmp1"
,
"w"
)
as
f1
:
f1
.
write
(
src1
)
with
open
(
".tmp2"
,
"w"
)
as
f2
:
f2
.
write
(
src2
)
try
:
output
=
subprocess
.
check_output
([
"diff"
,
".tmp1"
,
".tmp2"
])
return
output
.
decode
(
'utf-8'
)
except
subprocess
.
CalledProcessError
as
e
:
return
e
.
output
.
decode
(
'utf-8'
)
# Verify that we're in the right directory
try
:
open
(
"ihaskell.cabal"
,
"r"
)
.
close
()
except
:
print
(
sys
.
argv
[
0
],
"must be run from the ihaskell directory"
,
file
=
sys
.
stderr
)
# Find all the source files
sources
=
[]
for
root
,
dirnames
,
filenames
in
os
.
walk
(
"src"
):
for
filename
in
filenames
:
if
filename
.
endswith
(
".hs"
):
sources
.
append
(
os
.
path
.
join
(
root
,
filename
))
hindent_outputs
=
{}
for
source_file
in
sources
:
print
(
"Formatting file"
,
source_file
)
with
open
(
source_file
,
"r"
)
as
f
:
original_source
=
f
.
read
()
formatted_source
=
hindent
(
original_source
)
hindent_outputs
[
source_file
]
=
(
original_source
,
formatted_source
)
diffs
=
{
filename
:
diff
(
original
,
formatted
)
for
(
filename
,
(
original
,
formatted
))
in
hindent_outputs
.
items
()}
incorrect_formatting
=
False
for
filename
,
diff
in
diffs
.
items
():
if
diff
:
incorrect_formatting
=
True
print
(
'Incorrect formatting in'
,
filename
)
print
(
'='
*
10
)
print
(
diff
)
if
incorrect_formatting
:
sys
.
exit
(
1
)
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