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
2f060497
Commit
2f060497
authored
Mar 20, 2015
by
Andrew Gibiansky
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Reformatting all of ihaskell source
parent
e5e92036
Changes
20
Expand all
Show whitespace changes
Inline
Side-by-side
Showing
20 changed files
with
1658 additions
and
1624 deletions
+1658
-1624
.gitignore
.gitignore
+2
-0
BrokenPackages.hs
src/IHaskell/BrokenPackages.hs
+17
-19
Convert.hs
src/IHaskell/Convert.hs
+21
-19
Args.hs
src/IHaskell/Convert/Args.hs
+67
-72
IpynbToLhs.hs
src/IHaskell/Convert/IpynbToLhs.hs
+30
-27
LhsToIpynb.hs
src/IHaskell/Convert/LhsToIpynb.hs
+67
-64
Display.hs
src/IHaskell/Display.hs
+77
-71
Completion.hs
src/IHaskell/Eval/Completion.hs
+190
-196
Evaluate.hs
src/IHaskell/Eval/Evaluate.hs
+438
-409
Hoogle.hs
src/IHaskell/Eval/Hoogle.hs
+110
-123
Info.hs
src/IHaskell/Eval/Info.hs
+10
-12
Lint.hs
src/IHaskell/Eval/Lint.hs
+104
-113
ParseShell.hs
src/IHaskell/Eval/ParseShell.hs
+23
-22
Parser.hs
src/IHaskell/Eval/Parser.hs
+127
-119
Util.hs
src/IHaskell/Eval/Util.hs
+169
-177
Flags.hs
src/IHaskell/Flags.hs
+19
-18
IPython.hs
src/IHaskell/IPython.hs
+31
-28
Types.hs
src/IHaskell/Types.hs
+86
-79
Main.hs
src/Main.hs
+50
-49
verify_formatting.py
verify_formatting.py
+20
-7
No files found.
.gitignore
View file @
2f060497
...
@@ -16,3 +16,5 @@ todo
...
@@ -16,3 +16,5 @@ todo
profile/profile.tar
profile/profile.tar
.cabal-sandbox
.cabal-sandbox
cabal.sandbox.config
cabal.sandbox.config
.tmp1
.tmp2
src/IHaskell/BrokenPackages.hs
View file @
2f060497
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module
IHaskell.BrokenPackages
(
getBrokenPackages
)
where
module
IHaskell.BrokenPackages
(
getBrokenPackages
)
where
import
ClassyPrelude
hiding
((
<|>
))
import
ClassyPrelude
hiding
((
<|>
))
...
@@ -11,17 +12,13 @@ import Data.String.Utils (startswith)
...
@@ -11,17 +12,13 @@ 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"
]
...
@@ -32,7 +29,8 @@ getBrokenPackages = shelly $ do
...
@@ -32,7 +29,8 @@ getBrokenPackages = shelly $ do
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
$
case
parse
(
many
check
)
"ghc-pkg output"
ghcPkgOutput
of
Left
err
->
[]
Left
err
->
[]
Right
pkgs
->
map
show
pkgs
Right
pkgs
->
map
show
pkgs
...
...
src/IHaskell/Convert.hs
View file @
2f060497
-- | 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
Control.Monad.Identity
(
Identity
(
Identity
),
unless
,
when
)
import
IHaskell.Convert.Args
(
ConvertSpec
(
ConvertSpec
,
convertInput
,
convertLhsStyle
,
convertOutput
,
convertOverwriteFiles
,
convertToIpynb
),
fromJustConvertSpec
,
toConvertSpec
)
import
IHaskell.Convert.Args
(
ConvertSpec
(
ConvertSpec
,
convertInput
,
convertLhsStyle
,
convertOutput
,
convertOverwriteFiles
,
convertToIpynb
),
fromJustConvertSpec
,
toConvertSpec
)
import
IHaskell.Convert.IpynbToLhs
(
ipynbToLhs
)
import
IHaskell.Convert.IpynbToLhs
(
ipynbToLhs
)
...
@@ -10,12 +11,15 @@ import Text.Printf (printf)
...
@@ -10,12 +11,15 @@ 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
...
@@ -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 @
2f060497
-- | 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
))
...
@@ -15,35 +11,36 @@ import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
...
@@ -15,35 +11,36 @@ 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
)
|
toIpynb
->
(
i
,
dropExtension
i
<.>
"ipynb"
)
|
otherwise
->
(
i
,
dropExtension
i
<.>
"lhs"
)
|
otherwise
->
(
i
,
dropExtension
i
<.>
"lhs"
)
(
Nothing
,
Just
o
)
|
toIpynb
->
(
dropExtension
o
<.>
"lhs"
,
o
)
(
Nothing
,
Just
o
)
|
toIpynb
->
(
dropExtension
o
<.>
"lhs"
,
o
)
|
otherwise
->
(
dropExtension
o
<.>
"ipynb"
,
o
)
|
otherwise
->
(
dropExtension
o
<.>
"ipynb"
,
o
)
(
Just
i
,
Just
o
)
->
(
i
,
o
)
(
Just
i
,
Just
o
)
->
(
i
,
o
)
...
@@ -55,8 +52,7 @@ isFormatSpec _ = False
...
@@ -55,8 +52,7 @@ 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
...
@@ -68,40 +64,39 @@ mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
...
@@ -68,40 +64,39 @@ 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
=
case
map
toLower
(
takeExtension
s
)
of
".lhs"
->
Just
LhsMarkdown
".lhs"
->
Just
LhsMarkdown
".ipynb"
->
Just
IpynbFile
".ipynb"
->
Just
IpynbFile
_
->
Nothing
_
->
Nothing
src/IHaskell/Convert/IpynbToLhs.hs
View file @
2f060497
{-# 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
((
<$>
))
...
@@ -12,7 +13,8 @@ import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
...
@@ -12,7 +13,8 @@ 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
(
lhsBeginCode
,
lhsBeginOutput
,
lhsCodePrefix
,
lhsEndCode
,
lhsEndOutput
,
lhsOutputPrefix
))
ipynbToLhs
::
LhsStyle
T
.
Text
ipynbToLhs
::
LhsStyle
T
.
Text
->
FilePath
-- ^ the filename of an ipython notebook
->
FilePath
-- ^ the filename of an ipython notebook
...
@@ -22,8 +24,7 @@ ipynbToLhs sty from to = do
...
@@ -22,8 +24,7 @@ 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
...
@@ -35,19 +36,21 @@ toStr :: Value -> Maybe T.Text
...
@@ -35,19 +36,21 @@ 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
)
=
"
\n
"
<>
lhsBeginCode
sty
<>
i
<>
lhsEndCode
sty
<>
"
\n
"
<>
o
<>
"
\n
"
lhsBeginCode
sty
<>
i
<>
lhsEndCode
sty
<>
"
\n
"
<>
o
<>
"
\n
"
convCell
_
_
=
"IHaskell.Convert.convCell: unknown cell"
convCell
_
_
=
"IHaskell.Convert.convCell: unknown cell"
...
...
src/IHaskell/Convert/LhsToIpynb.hs
View file @
2f060497
{-# 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
((
<$>
))
...
@@ -19,7 +20,9 @@ lhsToIpynb sty from to = do
...
@@ -19,7 +20,9 @@ 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
|
OutputLine
a
|
MarkdownLine
a
deriving
Show
deriving
Show
isCode
::
CellLine
t
->
Bool
isCode
::
CellLine
t
->
Bool
...
@@ -44,31 +47,34 @@ untag (CodeLine a) = a
...
@@ -44,31 +47,34 @@ 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
...
@@ -76,44 +82,41 @@ arrayFromTxt i = Array (V.fromList $ map stringify i)
...
@@ -76,44 +82,41 @@ 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
)
=
case
(
sp
c
,
sp
o
)
of
(
Just
a
,
Nothing
)
->
CodeLine
a
:
classifyLines
sty
ls
(
Just
a
,
Nothing
)
->
CodeLine
a
:
classifyLines
sty
ls
(
Nothing
,
Just
a
)
->
OutputLine
a
:
classifyLines
sty
ls
(
Nothing
,
Just
a
)
->
OutputLine
a
:
classifyLines
sty
ls
(
Nothing
,
Nothing
)
->
MarkdownLine
l
:
classifyLines
sty
ls
(
Nothing
,
Nothing
)
->
MarkdownLine
l
:
classifyLines
sty
ls
_
->
error
"IHaskell.Convert.classifyLines"
_
->
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 @
2f060497
{-# 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
...
@@ -23,11 +23,21 @@ module IHaskell.Display (
...
@@ -23,11 +23,21 @@ module IHaskell.Display (
printDisplay
,
printDisplay
,
-- * Constructors for displays
-- * Constructors for displays
plain
,
html
,
png
,
jpg
,
svg
,
latex
,
javascript
,
many
,
plain
,
html
,
png
,
jpg
,
svg
,
latex
,
javascript
,
many
,
-- ** Image and data encoding functions
-- ** Image and data encoding functions
Width
,
Height
,
Base64
(
..
),
Width
,
encode64
,
base64
,
Height
,
Base64
(
..
),
encode64
,
base64
,
-- ** Utilities
-- ** Utilities
switchToTmpDir
,
switchToTmpDir
,
...
@@ -45,7 +55,7 @@ import Data.String.Utils (rstrip)
...
@@ -45,7 +55,7 @@ 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
)
...
@@ -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
=<<
)
...
@@ -77,6 +86,8 @@ instance IHaskellDisplay a => IHaskellDisplay [a] where
...
@@ -77,6 +86,8 @@ instance IHaskellDisplay a => IHaskellDisplay [a] where
displays
<-
mapM
display
disps
displays
<-
mapM
display
disps
return
$
ManyDisplay
displays
return
$
ManyDisplay
displays
-- | Encode many displays into a single one. All will be output.
-- | Encode many displays into a single one. All will be output.
many
::
[
Display
]
->
Display
many
::
[
Display
]
->
Display
many
=
ManyDisplay
many
=
ManyDisplay
...
@@ -101,15 +112,15 @@ latex = DisplayData MimeLatex . pack
...
@@ -101,15 +112,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 +132,37 @@ encode64 str = base64 $ Char.pack str
...
@@ -121,42 +132,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 @
2f060497
This diff is collapsed.
Click to expand it.
src/IHaskell/Eval/Evaluate.hs
View file @
2f060497
This diff is collapsed.
Click to expand it.
src/IHaskell/Eval/Hoogle.hs
View file @
2f060497
{-# 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
)
...
@@ -22,19 +23,13 @@ import qualified Prelude as P
...
@@ -22,19 +23,13 @@ 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
{
data
HoogleResponse
=
HoogleResponse
{
location
::
String
,
self
::
String
,
docs
::
String
}
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
...
@@ -48,23 +43,21 @@ instance FromJSON [HoogleResponse] where
...
@@ -48,23 +43,21 @@ 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
$
case
response
of
Left
err
->
Left
$
show
(
err
::
SomeException
)
Left
err
->
Left
$
show
(
err
::
SomeException
)
Right
resp
->
Right
$
Char
.
unpack
$
responseBody
resp
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"
...
@@ -78,27 +71,27 @@ urlEncode (ch:t)
...
@@ -78,27 +71,27 @@ urlEncode (ch:t)
|
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
$
case
response
of
Left
err
->
[
NoResult
err
]
Left
err
->
[
NoResult
err
]
Right
json
->
Right
json
->
case
eitherDecode
$
Char
.
pack
json
of
case
eitherDecode
$
Char
.
pack
json
of
...
@@ -108,16 +101,17 @@ search string = do
...
@@ -108,16 +101,17 @@ search string = do
[]
->
[
NoResult
"no matching identifiers found."
]
[]
->
[
NoResult
"no matching identifiers found."
]
res
->
res
res
->
res
-- | Look up an identifier on Hoogle.
-- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many
-- 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
$
case
results
of
[]
->
[
NoResult
"no matching identifiers found."
]
[]
->
[
NoResult
"no matching identifiers found."
]
res
->
res
res
->
res
where
where
matches
(
SearchResult
resp
)
=
matches
(
SearchResult
resp
)
=
case
split
" "
$
self
resp
of
case
split
" "
$
self
resp
of
...
@@ -139,16 +133,10 @@ renderPlain (NoResult res) =
...
@@ -139,16 +133,10 @@ 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 +155,37 @@ renderHtml (SearchResult resp) =
...
@@ -167,37 +155,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"
(
unicodeReplace
$
link
loc
(
strip
name
)
++
link
loc
(
strip
name
)
++
" :: "
++
" :: "
++
strip
args
)
strip
args
)
++
packageAndModuleSub
package
modname
++
packageAndModuleSub
package
modname
where
where
extractPackage
=
strip
.
replace
"package"
""
extractPackage
=
strip
.
replace
"package"
""
extractModule
=
strip
.
replace
"module"
""
extractModule
=
strip
.
replace
"module"
""
...
@@ -239,8 +227,7 @@ renderDocs doc =
...
@@ -239,8 +227,7 @@ renderDocs doc =
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
...
...
src/IHaskell/Eval/Info.hs
View file @
2f060497
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-}
{- | Description : Inspect type and function information and documentation. -}
module
IHaskell.Eval.Info
(
module
IHaskell.Eval.Info
(
info
)
where
info
)
where
import
ClassyPrelude
hiding
(
liftIO
)
import
ClassyPrelude
hiding
(
liftIO
)
...
...
src/IHaskell/Eval/Lint.hs
View file @
2f060497
{-# 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
)
...
@@ -32,13 +31,13 @@ import IHaskell.Eval.Parser hiding (line)
...
@@ -32,13 +31,13 @@ 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
)
...
@@ -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,26 +65,25 @@ lint blocks = do
...
@@ -66,26 +65,25 @@ 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
...
@@ -111,12 +109,12 @@ createModule mode (Located line block) =
...
@@ -111,12 +109,12 @@ createModule mode (Located line block) =
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
...
@@ -135,7 +133,8 @@ createModule mode (Located line block) =
...
@@ -135,7 +133,8 @@ 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
=
case
parseStmtWithMode
mode
stmtStr
of
ParseOk
stmt
->
ParseOk
mod
ParseOk
stmt
->
ParseOk
mod
ParseFailed
a
b
->
ParseFailed
a
b
ParseFailed
a
b
->
ParseFailed
a
b
where
where
...
@@ -158,10 +157,7 @@ createModule mode (Located line block) =
...
@@ -158,10 +157,7 @@ createModule mode (Located line block) =
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
...
@@ -169,18 +165,17 @@ htmlSuggestions = concatMap toHtml
...
@@ -169,18 +165,17 @@ 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
=
case
severity
suggest
of
Error
->
"error"
Error
->
"error"
Warning
->
"warning"
Warning
->
"warning"
...
@@ -214,18 +209,14 @@ showSuggestion = remove lintIdent . dropDo
...
@@ -214,18 +209,14 @@ showSuggestion = remove lintIdent . dropDo
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
fullDo
=
a
:
unindented
afterDo
=
drop
(
length
unindented
)
as
afterDo
=
drop
(
length
unindented
)
as
in
in
fullDo
++
clean
afterDo
--
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 @
2f060497
-- | 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
...
@@ -20,9 +19,10 @@ manyTill p end = scan
...
@@ -20,9 +19,10 @@ manyTill p end = scan
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
x
<-
p
xs
<-
manyTill
p
end
xs
<-
manyTill
p
end
return
$
x
:
xs
return
$
x
:
xs
...
@@ -37,7 +37,8 @@ quotedString = do
...
@@ -37,7 +37,8 @@ quotedString = do
(
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"
...
...
src/IHaskell/Eval/Parser.hs
View file @
2f060497
This diff is collapsed.
Click to expand it.
src/IHaskell/Eval/Util.hs
View file @
2f060497
This diff is collapsed.
Click to expand it.
src/IHaskell/Flags.hs
View file @
2f060497
{-# 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,7 +33,9 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
...
@@ -33,7 +33,9 @@ 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
=
LhsStyle
{
lhsCodePrefix
::
string
-- ^ @>@
,
lhsOutputPrefix
::
string
-- ^ @<<@
,
lhsOutputPrefix
::
string
-- ^ @<<@
,
lhsBeginCode
::
string
-- ^ @\\begin{code}@
,
lhsBeginCode
::
string
-- ^ @\\begin{code}@
,
lhsEndCode
::
string
-- ^ @\\end{code}@
,
lhsEndCode
::
string
-- ^ @\\end{code}@
...
@@ -48,15 +50,13 @@ data NotebookFormat = LhsMarkdown
...
@@ -48,15 +50,13 @@ data NotebookFormat = LhsMarkdown
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 +111,8 @@ installKernelSpec =
...
@@ -111,7 +111,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
...
@@ -161,8 +162,8 @@ ihaskellArgs =
...
@@ -161,8 +162,8 @@ 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
...
...
src/IHaskell/IPython.hs
View file @
2f060497
...
@@ -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
{
kernelSpecGhcLibdir
::
String
-- ^ GHC libdir.
,
kernelSpecDebug
::
Bool
-- ^ Spew debugging output?
,
kernelSpecDebug
::
Bool
-- ^ Spew debugging output?
,
kernelSpecConfFile
::
IO
(
Maybe
String
)
-- ^ Filename of profile JSON file.
,
kernelSpecConfFile
::
IO
(
Maybe
String
)
-- ^ Filename of profile JSON file.
}
}
defaultKernelSpecOptions
::
KernelSpecOptions
defaultKernelSpecOptions
::
KernelSpecOptions
defaultKernelSpecOptions
=
KernelSpecOptions
{
kernelSpecGhcLibdir
=
GHC
.
Paths
.
libdir
defaultKernelSpecOptions
=
KernelSpecOptions
{
kernelSpecGhcLibdir
=
GHC
.
Paths
.
libdir
,
kernelSpecDebug
=
False
,
kernelSpecDebug
=
False
,
kernelSpecConfFile
=
defaultConfFile
,
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
{
kernelDisplayName
=
"Haskell"
,
kernelLanguage
=
kernelName
,
kernelLanguage
=
kernelName
,
kernelCommand
=
[
ihaskellPath
,
"kernel"
,
"{connection_file}"
]
++
kernelFlags
,
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"
...
@@ -185,16 +190,15 @@ kernelSpecCreated = do
...
@@ -185,16 +190,15 @@ kernelSpecCreated = do
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
-- | Get the path to an executable. If it doensn't exist, fail with an
error message complaining
--
error message complaining
about it.
-- 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 +233,8 @@ getIHaskellPath = do
...
@@ -229,9 +233,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 @
2f060497
{-# 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
(
..
),
...
@@ -16,7 +16,8 @@ module IHaskell.Types (
...
@@ -16,7 +16,8 @@ module IHaskell.Types (
ExecuteReplyStatus
(
..
),
ExecuteReplyStatus
(
..
),
KernelState
(
..
),
KernelState
(
..
),
LintStatus
(
..
),
LintStatus
(
..
),
Width
,
Height
,
Width
,
Height
,
Display
(
..
),
Display
(
..
),
defaultKernelState
,
defaultKernelState
,
extractPlain
,
extractPlain
,
...
@@ -90,8 +91,8 @@ instance Show Widget where
...
@@ -90,8 +91,8 @@ instance Show Widget where
show
_
=
"<Widget>"
show
_
=
"<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
results from the same
--
results from the same
expression.
-- expression.
data
Display
=
Display
[
DisplayData
]
data
Display
=
Display
[
DisplayData
]
|
ManyDisplay
[
Display
]
|
ManyDisplay
[
Display
]
deriving
(
Show
,
Typeable
,
Generic
)
deriving
(
Show
,
Typeable
,
Generic
)
...
@@ -108,7 +109,9 @@ instance Semigroup Display where
...
@@ -108,7 +109,9 @@ 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
=
KernelState
{
getExecutionCounter
::
Int
,
getLintStatus
::
LintStatus
-- Whether to use hlint, and what arguments to pass it.
,
getLintStatus
::
LintStatus
-- Whether to use hlint, and what arguments to pass it.
,
useSvg
::
Bool
,
useSvg
::
Bool
,
useShowErrors
::
Bool
,
useShowErrors
::
Bool
...
@@ -120,7 +123,8 @@ data KernelState = KernelState { getExecutionCounter :: Int
...
@@ -120,7 +123,8 @@ data KernelState = KernelState { getExecutionCounter :: Int
deriving
Show
deriving
Show
defaultKernelState
::
KernelState
defaultKernelState
::
KernelState
defaultKernelState
=
KernelState
{
getExecutionCounter
=
1
defaultKernelState
=
KernelState
{
getExecutionCounter
=
1
,
getLintStatus
=
LintOn
,
getLintStatus
=
LintOn
,
useSvg
=
True
,
useSvg
=
True
,
useShowErrors
=
False
,
useShowErrors
=
False
...
@@ -131,10 +135,12 @@ defaultKernelState = KernelState { getExecutionCounter = 1
...
@@ -131,10 +135,12 @@ defaultKernelState = KernelState { getExecutionCounter = 1
}
}
-- | 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
]
...
@@ -152,23 +158,24 @@ kernelOpts =
...
@@ -152,23 +158,24 @@ kernelOpts =
]
]
-- | 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 @
2f060497
{-# 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.
...
@@ -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,33 +183,34 @@ createReplyHeader parent = do
...
@@ -185,33 +183,34 @@ 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
-- Reply to kernel info requests with a kernel info reply. No computation
needs to be done, as a
--
needs to be done, as a kernel info reply is a static object (all info is
--
kernel info reply is a static object (all info is hard coded into the representation of that
--
hard coded into the representation of that
message type).
-- 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.
-- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- Before shutdown, reply to the request to let the frontend know shutdown
-- let the frontend know shutdown is happening.
-- 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
...
@@ -254,7 +253,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
...
@@ -254,7 +253,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
()
...
@@ -337,16 +337,16 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
...
@@ -337,16 +337,16 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
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
)
...
@@ -354,7 +354,8 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
...
@@ -354,7 +354,8 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
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
)
...
...
verify_formatting.py
View file @
2f060497
...
@@ -8,8 +8,9 @@ import subprocess
...
@@ -8,8 +8,9 @@ import subprocess
def
hindent
(
contents
):
def
hindent
(
contents
):
return
subprocess
.
check_output
([
"hindent"
,
"--style"
,
"gibiansky"
],
output
=
subprocess
.
check_output
([
"hindent"
,
"--style"
,
"gibiansky"
],
input
=
bytes
(
contents
,
'utf-8'
))
input
=
bytes
(
contents
,
'utf-8'
))
return
output
.
decode
(
'utf-8'
)
def
diff
(
src1
,
src2
):
def
diff
(
src1
,
src2
):
...
@@ -20,7 +21,11 @@ def diff(src1, src2):
...
@@ -20,7 +21,11 @@ def diff(src1, src2):
with
open
(
".tmp2"
,
"w"
)
as
f2
:
with
open
(
".tmp2"
,
"w"
)
as
f2
:
f2
.
write
(
src2
)
f2
.
write
(
src2
)
return
subprocess
.
check_output
([
"diff"
,
".tmp1"
,
".tmp2"
])
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
# Verify that we're in the right directory
try
:
try
:
...
@@ -35,6 +40,8 @@ for root, dirnames, filenames in os.walk("src"):
...
@@ -35,6 +40,8 @@ for root, dirnames, filenames in os.walk("src"):
for
filename
in
filenames
:
for
filename
in
filenames
:
if
filename
.
endswith
(
".hs"
):
if
filename
.
endswith
(
".hs"
):
sources
.
append
(
os
.
path
.
join
(
root
,
filename
))
sources
.
append
(
os
.
path
.
join
(
root
,
filename
))
break
break
hindent_outputs
=
{}
hindent_outputs
=
{}
...
@@ -47,9 +54,15 @@ for source_file in sources:
...
@@ -47,9 +54,15 @@ for source_file in sources:
hindent_outputs
[
source_file
]
=
(
original_source
,
formatted_source
)
hindent_outputs
[
source_file
]
=
(
original_source
,
formatted_source
)
diffs
=
{
filename
:
diff
(
original
,
formatted
)
diffs
=
{
filename
:
diff
(
original
,
formatted
)
for
(
filename
,
(
original
,
formatted
))
in
hindent_outputs
.
value
s
()}
for
(
filename
,
(
original
,
formatted
))
in
hindent_outputs
.
item
s
()}
incorrect_formatting
=
False
for
filename
,
diff
in
diffs
.
items
():
for
filename
,
diff
in
diffs
.
items
():
print
(
filename
)
if
diff
:
incorrect_formatting
=
True
print
(
'Incorrect formatting in'
,
filename
)
print
(
'='
*
10
)
print
(
'='
*
10
)
print
(
diff
)
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