mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-16 03:16:20 +00:00
Code Issues Packages Projects Releases Wiki Activity

Reformatting all of ihaskell source

Browse Source
This commit is contained in:
Andrew Gibiansky 2015-03-19 18:30:22 -07:00
parent e5e9203624
commit 2f06049777
20 changed files with 1598 additions and 1564 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -16,3 +16,5 @@ todo
profile/profile.tar
.cabal-sandbox
cabal.sandbox.config
.tmp1
.tmp2

14
src/IHaskell/BrokenPackages.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>))
@ -11,17 +12,13 @@ import Data.String.Utils (startswith)
import Shelly
data BrokenPackage = BrokenPackage {
packageID :: String,
brokenDeps :: [String]
}
data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
instance Show BrokenPackage where
show = packageID
-- | Get a list of broken packages.
-- This function internally shells out to `ghc-pkg`, and parses the output
-- in order to determine what packages are broken.
-- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- output in order to determine what packages are broken.
getBrokenPackages :: IO [String]
getBrokenPackages = shelly $ do
silently $ errExit False $ run "ghc-pkg" ["check"]
@ -32,7 +29,8 @@ getBrokenPackages = shelly $ do
startswith " dependency" str
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 -> []
Right pkgs -> map show pkgs

18
src/IHaskell/Convert.hs
View File

@ -1,5 +1,6 @@
-- | Description : mostly reversible conversion between ipynb and lhs
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 IHaskell.Convert.IpynbToLhs (ipynbToLhs)
@ -10,12 +11,15 @@ import Text.Printf (printf)
-- | used by @IHaskell convert@
convert :: [Argument] -> IO ()
convert args = case fromJustConvertSpec (toConvertSpec args) of
ConvertSpec { convertToIpynb = Identity toIpynb,
convertInput = Identity inputFile,
convertOutput = Identity outputFile,
convertLhsStyle = Identity lhsStyle,
convertOverwriteFiles = force }
convert args =
case fromJustConvertSpec (toConvertSpec args) of
ConvertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity lhsStyle
, convertOverwriteFiles = force
}
| toIpynb -> do
unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile
@ -29,5 +33,3 @@ failIfExists file = do
exists <- doesFileExist file
when exists $ fail $
printf "File %s already exists. To force supply --force." file

79
src/IHaskell/Convert/Args.hs
View File

@ -1,9 +1,5 @@
-- | Description: interpret flags parsed by "IHaskell.Flags"
module IHaskell.Convert.Args
(ConvertSpec(..),
fromJustConvertSpec,
toConvertSpec,
) where
module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
@ -15,35 +11,36 @@ import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf)
-- | ConvertSpec is the accumulator for command line arguments
data ConvertSpec f = ConvertSpec
{ convertToIpynb :: f Bool,
convertInput :: f FilePath,
convertOutput :: f FilePath,
convertLhsStyle :: f (LhsStyle T.Text),
convertOverwriteFiles :: Bool
data ConvertSpec f =
ConvertSpec
{ convertToIpynb :: f Bool
, convertInput :: f FilePath
, convertOutput :: f FilePath
, convertLhsStyle :: f (LhsStyle T.Text)
, convertOverwriteFiles :: Bool
}
-- | Convert a possibly-incomplete specification for what to convert
-- into one which can be executed. Calls error when data is missing.
-- | Convert a possibly-incomplete specification for what to convert into one which can be executed.
-- Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec {
convertToIpynb = Identity toIpynb,
convertInput = Identity inputFile,
convertOutput = Identity outputFile,
convertLhsStyle = Identity $ fromMaybe
(T.pack <$> lhsStyleBird)
(convertLhsStyle convertSpec)
fromJustConvertSpec convertSpec = convertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
}
where
toIpynb = fromMaybe (error "Error: direction for conversion unknown")
(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"
(Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb")
(Just i, Nothing)
| toIpynb -> (i, dropExtension i <.> "ipynb")
| 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)
(Just i, Just o) -> (i, o)
@ -55,8 +52,7 @@ isFormatSpec _ = False
toConvertSpec :: [Argument] -> ConvertSpec Maybe
toConvertSpec args = mergeArgs otherArgs
(mergeArgs formatSpecArgs initialConvertSpec)
toConvertSpec args = mergeArgs otherArgs (mergeArgs formatSpecArgs initialConvertSpec)
where
(formatSpecArgs, otherArgs) = partition isFormatSpec args
initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False
@ -68,40 +64,39 @@ mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }
mergeArg (ConvertLhsStyle lhsStyle) convertSpec
| Just previousLhsStyle <- convertLhsStyle convertSpec,
previousLhsStyle /= fmap T.pack lhsStyle = error $ printf
"Conflicting lhs styles requested: <%s> and <%s>"
(show lhsStyle) (show previousLhsStyle)
previousLhsStyle /= fmap T.pack lhsStyle
= error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)
(show previousLhsStyle)
| otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }
mergeArg (ConvertFrom inputFile) convertSpec
| Just previousInputFile <- convertInput convertSpec,
previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>"
inputFile previousInputFile
| otherwise = convertSpec {
convertInput = Just inputFile,
convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
previousInputFile /= inputFile
= error $ printf "Multiple input files specified: <%s> and <%s>" inputFile previousInputFile
| otherwise = convertSpec
{ convertInput = Just inputFile
, convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format
}
mergeArg (ConvertTo outputFile) convertSpec
| Just previousOutputFile <- convertOutput convertSpec,
previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>"
outputFile previousOutputFile
| otherwise = convertSpec {
convertOutput = Just outputFile,
convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
previousOutputFile /= outputFile
= error $ printf "Multiple output files specified: <%s> and <%s>" outputFile previousOutputFile
| otherwise = convertSpec
{ convertOutput = Just outputFile
, convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format
}
mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "
++ show unexpectedArg
-- | Guess the format based on the file extension.
fromExt :: FilePath -> Maybe NotebookFormat
fromExt s = case map toLower (takeExtension s) of
fromExt s =
case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile
_ -> Nothing

17
src/IHaskell/Convert/IpynbToLhs.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>))
@ -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 Data.Vector (Vector)
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
-> FilePath -- ^ the filename of an ipython notebook
@ -22,8 +24,7 @@ ipynbToLhs sty from to = do
Just (js :: Object) <- decode <$> L.readFile from
case M.lookup "cells" js of
Just (Array cells) ->
T.writeFile to $ T.unlines $ V.toList
$ V.map (\(Object y) -> convCell sty y) cells
T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
_ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix :: T.Text -- ^ the prefix to add to every line
@ -35,19 +36,21 @@ toStr :: Value -> Maybe T.Text
toStr (String x) = Just (T.fromStrict x)
toStr _ = Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable
-- for the type of lhs file described by the @sty@
-- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file
-- described by the @sty@
convCell :: LhsStyle T.Text -> Object -> T.Text
convCell _sty object
| Just (String "markdown") <- M.lookup "cell_type" object,
Just (Array xs) <- M.lookup "source" object,
~ (Just s) <- concatWithPrefix "" xs = s
~(Just s) <- concatWithPrefix "" xs
= s
convCell sty object
| Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object,
~(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"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell"

69
src/IHaskell/Convert/LhsToIpynb.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>))
@ -19,7 +20,9 @@ lhsToIpynb sty from to = do
classed <- classifyLines sty . T.lines <$> T.readFile from
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
isCode :: CellLine t -> Bool
@ -44,8 +47,9 @@ untag (CodeLine a) = a
untag (OutputLine a) = a
untag (MarkdownLine a) = a
data Cell a = Code a a | Markdown a
deriving (Show)
data Cell a = Code a a
| Markdown a
deriving Show
encodeCells :: [Cell [T.Text]] -> Value
encodeCells xs = object $
@ -54,21 +58,23 @@ encodeCells xs = object $
cellToVal :: Cell [T.Text] -> Value
cellToVal (Code i o) = object $
[ "cell_type" .= String "code",
"execution_count" .= Null,
"metadata" .= object [ "collapsed" .= Bool False ],
"source" .= arrayFromTxt i,
"outputs" .= Array
(V.fromList (
[ object ["text" .= arrayFromTxt o,
"metadata" .= object [],
"output_type" .= String "display_data" ]
| _ <- take 1 o])) ]
[ "cell_type" .= String "code"
, "execution_count" .= Null
, "metadata" .= object ["collapsed" .= Bool False]
, "source" .= arrayFromTxt i
, "outputs" .= Array
(V.fromList
([object
[ "text" .= arrayFromTxt o
, "metadata" .= object []
, "output_type" .= String "display_data"
] | _ <- take 1 o]))
]
cellToVal (Markdown txt) = object $
[ "cell_type" .= String "markdown",
"metadata" .= object [ "hidden" .= Bool False ],
"source" .= arrayFromTxt txt ]
[ "cell_type" .= String "markdown"
, "metadata" .= object ["hidden" .= Bool False]
, "source" .= arrayFromTxt txt
]
-- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [T.Text] -> Value
@ -76,44 +82,41 @@ arrayFromTxt i = Array (V.fromList $ map stringify i)
where
stringify = String . T.toStrict . flip T.snoc '\n'
-- | ihaskell needs this boilerplate at the upper level to interpret the
-- json describing cells and output correctly.
-- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- output correctly.
boilerplate :: [(TS.Text, Value)]
boilerplate =
[ "metadata" .= object [ kernelspec, lang ]
, "nbformat" .= Number 4
, "nbformat_minor" .= Number 0
]
["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]
where
kernelspec = "kernelspec" .= object [
"display_name" .= String "Haskell"
kernelspec = "kernelspec" .= object
[ "display_name" .= String "Haskell"
, "language" .= String "haskell"
, "name" .= String "haskell"
]
lang = "language_info" .= object [
"name" .= String "haskell"
, "version" .= String VERSION_ghc
]
lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc]
groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]
groupClassified (CodeLine a:x)
| (c, x) <- span isCode 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
= Code (a : map untag c) (map untag o) : groupClassified x
groupClassified (MarkdownLine a:x)
| (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = []
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
(Nothing, Just a) -> OutputLine a : classifyLines sty ls
(Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
where
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
classifyLines _ [] = []

80
src/IHaskell/Display.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
-- | If you are interested in the IHaskell library for the purpose of
-- augmenting the IHaskell notebook or writing your own display mechanisms
-- and widgets, this module contains all functions you need.
-- | If you are interested in the IHaskell library for the purpose of augmenting the IHaskell
-- notebook or writing your own display mechanisms and widgets, this module contains all functions
-- you need.
--
-- In order to create a display mechanism for a particular data type, write
-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@.
-- (Note the capitalization - it's important!) Then, in that module, add an
-- instance of @IHaskellDisplay@ for your data type. Similarly, to create
-- a widget, add an instance of @IHaskellWidget@.
-- In order to create a display mechanism for a particular data type, write a module named (for
-- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the
-- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for
-- your data type. Similarly, to create 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 (
-- * Rich display and interactive display typeclasses and types
@ -23,11 +23,21 @@ module IHaskell.Display (
printDisplay,
-- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many,
plain,
html,
png,
jpg,
svg,
latex,
javascript,
many,
-- ** Image and data encoding functions
Width, Height, Base64(..),
encode64, base64,
Width,
Height,
Base64(..),
encode64,
base64,
-- ** Utilities
switchToTmpDir,
@ -61,8 +71,7 @@ type Base64 = Text
-- > IO [Display]
-- > IO (IO Display)
--
-- be run the IO and get rendered (if the frontend allows it) in the pretty
-- form.
-- be run the IO and get rendered (if the frontend allows it) in the pretty form.
instance IHaskellDisplay a => IHaskellDisplay (IO a) where
display = (display =<<)
@ -77,6 +86,8 @@ instance IHaskellDisplay a => IHaskellDisplay [a] where
displays <- mapM display disps
return $ ManyDisplay displays
-- | Encode many displays into a single one. All will be output.
many :: [Display] -> Display
many = ManyDisplay
@ -101,15 +112,15 @@ latex = DisplayData MimeLatex . pack
javascript :: String -> DisplayData
javascript = DisplayData MimeJavascript . pack
-- | Generate a PNG display of the given width and height. Data must be
-- provided in a Base64 encoded manner, suitable for embedding into HTML.
-- The @base64@ function may be used to encode data into this format.
-- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- this format.
png :: Width -> Height -> Base64 -> DisplayData
png width height = DisplayData (MimePng width height)
-- | Generate a JPG display of the given width and height. Data must be
-- provided in a Base64 encoded manner, suitable for embedding into HTML.
-- The @base64@ function may be used to encode data into this format.
-- | Generate a JPG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- this format.
jpg :: Width -> Height -> Base64 -> DisplayData
jpg width height = DisplayData (MimeJpg width height)
@ -121,42 +132,37 @@ encode64 str = base64 $ Char.pack str
base64 :: ByteString -> Base64
base64 = decodeUtf8 . Base64.encode
-- | For internal use within IHaskell.
-- Serialize displays to a ByteString.
-- | For internal use within IHaskell. Serialize displays to a ByteString.
serializeDisplay :: Display -> ByteString
serializeDisplay = Serialize.encode
-- | Items written to this chan will be included in the output sent
-- to the frontend (ultimately the browser), the next time IHaskell
-- has an item to display.
-- | Items written to this chan will be included in the output sent to the frontend (ultimately the
-- browser), the next time IHaskell has an item to display.
{-# NOINLINE displayChan #-}
displayChan :: TChan Display
displayChan = unsafePerformIO newTChanIO
-- | Take everything that was put into the 'displayChan' at that point
-- out, and make a 'Display' out of it.
-- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out
-- of it.
displayFromChan :: IO (Maybe Display)
displayFromChan =
Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action
-- until it return Nothing, and puts all the Justs in a list.
-- If you find yourself using more functionality from monad-loops, just add
-- the package dependency instead of copying more code from it.
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- just add the package dependency instead of copying more code from it.
unfoldM :: IO (Maybe a) -> IO [a]
unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f
-- | Write to the display channel. The contents will be displayed in the
-- notebook once the current execution call ends.
-- | Write to the display channel. The contents will be displayed in the notebook once the current
-- execution call ends.
printDisplay :: IHaskellDisplay a => a -> IO ()
printDisplay disp = display disp >>= atomically . writeTChan displayChan
-- | Convenience function for client libraries. Switch to a temporary
-- directory so that any files we create aren't visible. On Unix, this is
-- usually /tmp.
-- | Convenience function for client libraries. Switch to a temporary directory so that any files we
-- create aren't visible. On Unix, this is usually /tmp.
switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))
where
switchDir =
getTemporaryDirectory >>=
setCurrentDirectory

124
src/IHaskell/Eval/Completion.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{- |
Description: Generates tab completion options.
@ -13,7 +14,6 @@ This has a limited amount of context sensitivity. It distinguishes between four
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import ClassyPrelude hiding (init, last, head, liftIO)
--import Prelude
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take, lines, length)
@ -46,9 +46,7 @@ import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell)
data CompletionType
= Empty
data CompletionType = Empty
| Identifier String
| DynFlag String
| Qualified String String
@ -58,10 +56,14 @@ data CompletionType
| KernelOption String
| Extension String
deriving (Show, Eq)
#if MIN_VERSION_ghc(7,10,0)
extName (FlagSpec { flagSpecName = name }) = name
#else
extName (name, _, _) = name
exposedName = id
#endif
complete :: String -> Int -> Interpreter (String, [String])
complete code posOffset = do
-- Get the line of code which is being completed and offset within that line
let findLine offset (first:rest) =
if offset <= length first
@ -78,10 +80,6 @@ complete code posOffset = do
unqualNames = nub $ filter (not . isQualified) rdrNames
qualNames = nub $ scopeNames ++ filter isQualified rdrNames
#if !MIN_VERSION_ghc(7,10,0)
let exposedName = id
#endif
let Just db = pkgDatabase flags
getNames = map (moduleNameString . exposedName) . exposedModules
moduleNames = nub $ concatMap getNames db
@ -89,19 +87,13 @@ complete code posOffset = do
let target = completionTarget line pos
completion = completionType line pos target
let matchedText = case completion of
let matchedText =
case completion of
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
options <- case completion of
Empty -> return []
Identifier candidate ->
@ -121,8 +113,7 @@ complete code posOffset = do
return $ filter (prefix `isPrefixOf`) moduleNames
DynFlag ext -> do
-- Possibly leave out the fLangFlags? The
-- -XUndecidableInstances vs. obsolete
-- Possibly leave out the fLangFlags? The -XUndecidableInstances vs. obsolete
-- -fallow-undecidable-instances.
let kernelOptNames = concatMap getSetName kernelOpts
otherNames = ["-package", "-Wall", "-w"]
@ -146,7 +137,8 @@ complete code posOffset = do
xNoNames = map ("No" ++) xNames
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
@ -164,8 +156,8 @@ getTrueModuleName name = do
-- Get all imports that we use.
imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext
-- Find the ones that have a qualified name attached.
-- If this name isn't one of them, it already is the true name.
-- Find the ones that have a qualified name attached. If this name isn't one of them, it already is
-- the true name.
flags <- getSessionDynFlags
let qualifiedImports = filter (isJust . ideclAs) imports
hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
@ -180,40 +172,41 @@ completionType :: String -- ^ The line on which the completion is bei
-> CompletionType
completionType line loc target
-- File and directory completions are special
| startswith ":!" stripped
= fileComplete FilePath
| startswith ":l" stripped
= fileComplete HsFilePath
| startswith ":!" stripped =
fileComplete FilePath
| startswith ":l" stripped =
fileComplete HsFilePath
-- Complete :set, :opt, and :ext
| startswith ":s" stripped
= DynFlag candidate
| startswith ":o" stripped
= KernelOption candidate
| startswith ":e" stripped
= Extension candidate
| startswith ":s" stripped =
DynFlag candidate
| startswith ":o" stripped =
KernelOption candidate
| startswith ":e" stripped =
Extension candidate
-- Use target for other completions.
-- If it's empty, no completion.
| null target
= Empty
-- Use target for other completions. If it's empty, no completion.
| null target =
Empty
-- When in a string, complete filenames.
| cursorInString line loc
= FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
| cursorInString line loc =
FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
-- Complete module names in imports and elsewhere.
| startswith "import" stripped && isModName
= ModuleName dotted candidate
| isModName && (not . null . init) target
= Qualified dotted candidate
| startswith "import" stripped && isModName =
ModuleName dotted candidate
| isModName && (not . null . init) target =
Qualified dotted candidate
-- Default to completing identifiers.
| otherwise
= Identifier candidate
where stripped = strip line
| otherwise =
Identifier candidate
where
stripped = strip line
dotted = dots target
candidate | null target = ""
candidate
| null target = ""
| otherwise = last target
dots = intercalate "." . init
isModName = all isCapitalized (init target)
@ -222,7 +215,8 @@ completionType line loc target
isCapitalized (x:_) = isUpper x
lineUpToCursor = take loc line
fileComplete filePath = case parseShell lineUpToCursor of
fileComplete filePath =
case parseShell lineUpToCursor of
Right xs -> filePath lineUpToCursor $
if endswith (last xs) lineUpToCursor
then last xs
@ -236,13 +230,13 @@ completionType line loc target
nquotes (_:xs) = nquotes xs
nquotes [] = 0
-- Get the bit of a string that might be a filename completion.
-- Logic is a bit convoluted, but basically go backwards from the
-- end, stopping at any quote or space, unless they are escaped.
-- Get the bit of a string that might be a filename completion. Logic is a bit convoluted, but
-- basically go backwards from the end, stopping at any quote or space, unless they are escaped.
getStringTarget :: String -> String
getStringTarget = go "" . reverse
where
go acc rest = case rest of
go acc rest =
case rest of
'"':'\\':rem -> go ('"' : acc) rem
'"':rem -> acc
' ':'\\':rem -> go (' ' : acc) rem
@ -260,10 +254,9 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
-- Split using only the characters, which are the first elements of
-- the (char, index) tuple
delimiter = Delimiter [uncurry isDelim],
-- Condense multiple delimiters into one and then drop them.
condensePolicy = Condense,
delimPolicy = Drop
}
-- Condense multiple delimiters into one and then drop
-- them.
condensePolicy = Condense, delimPolicy = Drop }
isDelim :: Char -> Int -> Bool
isDelim char idx = char `elem` neverIdent || isSymbol char
@ -285,7 +278,8 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
getHome :: IO String
getHome = do
homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)
return $ case homeEither of
return $
case homeEither of
Left _ -> "~"
Right home -> home
@ -301,7 +295,8 @@ unDirExpand str = do
completePath :: String -> Interpreter [String]
completePath line = completePathFilter acceptAll acceptAll line ""
where acceptAll = const True
where
acceptAll = const True
completePathWithExtensions :: [String] -> String -> Interpreter [String]
completePathWithExtensions extensions line =
@ -309,7 +304,8 @@ completePathWithExtensions extensions line =
where
acceptAll = const True
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.
-> (String -> Bool) -- ^ Directory filter: test whether to include this directory.
@ -321,15 +317,13 @@ completePathFilter includeFile includeDirectory left right = liftIO $ do
expanded <- dirExpand left
completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)
-- Split up into files and directories.
-- Filter out ones we don't want.
-- Split up into files and directories. Filter out ones we don't want.
areDirs <- mapM doesDirectoryExist completions
let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs
files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs
-- Return directories before files. However, stick everything that starts
-- with a dot after everything else. If we wanted to keep original
-- order, we could instead use
-- Return directories before files. However, stick everything that starts with a dot after
-- everything else. If we wanted to keep original order, we could instead use
-- filter (`elem` (dirs ++ files)) completions
suggestions <- mapM unDirExpand $ dirs ++ files
let isHidden str = startswith "." . last . StringUtils.split "/" $

435
src/IHaskell/Eval/Evaluate.hs
View File

@ -145,47 +145,52 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do
-- Run the rest of the interpreter
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'.
initializeImports :: Interpreter ()
initializeImports = do
-- Load packages that start with ihaskell-*, aren't just IHaskell,
-- and depend directly on the right version of the ihaskell library.
-- Also verify that the packages we load are not broken.
-- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right
-- version of the ihaskell library. Also verify that the packages we load are not broken.
dflags <- getSessionDynFlags
broken <- liftIO getBrokenPackages
displayPackages <- liftIO $ do
(dflags, _) <- initPackages dflags
let Just db = pkgDatabase dflags
#if MIN_VERSION_ghc(7,10,0)
packageIdString = packageKeyPackageIdString dflags
#endif
packageNames = map (packageIdString . packageConfigId) db
packageNames = map (packageIdString' dflags . packageConfigId) db
initStr = "ihaskell-"
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))
iHaskellPkgName = initStr ++ intercalate "."
(map show (versionBranch version))
dependsOnRight pkg = not $ null $ do
pkg <- db
depId <- depends pkg
dep <- filter ((== depId) . installedPackageId) db
guard (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))
guard
(iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))
-- ideally the Paths_ihaskell module could provide a way to get the
-- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9),
-- for now. Things will end badly if you also happen to have an
-- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.
iHaskellPkg = case filter (== iHaskellPkgName) packageNames of
-- ideally the Paths_ihaskell module could provide a way to get the hash too
-- (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), for now. Things will end badly if you also
-- happen to have an ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.
iHaskellPkg =
case filter (== iHaskellPkgName) packageNames of
[x] -> x
[] -> error ("cannot find required haskell library: " ++ iHaskellPkgName)
_ -> error ("multiple haskell packages " ++ iHaskellPkgName ++ " found")
[] -> error
("cannot find required haskell library: " ++ iHaskellPkgName)
_ -> error
("multiple haskell packages " ++ iHaskellPkgName ++ " found")
displayPkgs = [ pkgName
| pkgName <- packageNames,
Just (x:_) <- [stripPrefix initStr pkgName],
pkgName `notElem` broken,
isAlpha x]
displayPkgs = [pkgName | pkgName <- packageNames
, Just (x:_) <- [stripPrefix initStr pkgName]
, pkgName `notElem` broken
, isAlpha x]
return displayPkgs
@ -218,21 +223,24 @@ initializeItVariable = do
-- statements - if it doesn't exist, the first statement will fail.
void $ runStmt "let it = ()" RunToCompletion
-- | Publisher for IHaskell outputs. The first argument indicates whether
-- this output is final (true) or intermediate (false).
-- | Publisher for IHaskell outputs. The first argument indicates whether this output is final
-- (true) or intermediate (false).
type Publisher = (EvaluationResult -> IO ())
-- | Output of a command evaluation.
data EvalOut = EvalOut {
evalStatus :: ErrorOccurred,
evalResult :: Display,
evalState :: KernelState,
evalPager :: String,
evalComms :: [CommInfo]
data EvalOut =
EvalOut
{ evalStatus :: ErrorOccurred
, evalResult :: Display
, evalState :: KernelState
, evalPager :: String
, evalComms :: [CommInfo]
}
cleanString :: String -> String
cleanString x = if allBrackets then clean else str
cleanString x = if allBrackets
then clean
else str
where
str = strip x
l = lines str
@ -274,9 +282,8 @@ evaluate kernelState code output = do
liftIO $ output $ FinalResult (evalResult out) "" []
return kernelState
return updated {
getExecutionCounter = execCount + 1
}
return updated { getExecutionCounter = execCount + 1 }
where
noResults (Display res) = null res
noResults (ManyDisplay res) = all noResults res
@ -286,8 +293,7 @@ evaluate kernelState code output = do
runUntilFailure state (cmd:rest) = do
evalOut <- evalCommand output cmd state
-- Get displayed channel outputs.
-- Merge them with normal display outputs.
-- Get displayed channel outputs. Merge them with normal display outputs.
dispsIO <- extractValue "IHaskell.Display.displayFromChan"
dispsMay <- liftIO dispsIO
let result =
@ -322,12 +328,13 @@ safely state = ghandle handler . ghandle sourceErrorHandler
where
handler :: SomeException -> Interpreter EvalOut
handler exception =
return EvalOut {
evalStatus = Failure,
evalResult = displayError $ show exception,
evalState = state,
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Failure
, evalResult = displayError $ show exception
, evalState = state
, evalPager = ""
, evalComms = []
}
sourceErrorHandler :: SourceError -> Interpreter EvalOut
@ -340,28 +347,30 @@ safely state = ghandle handler . ghandle sourceErrorHandler
let fullErr = unlines errStrs
return EvalOut {
evalStatus = Failure,
evalResult = displayError fullErr,
evalState = state,
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Failure
, evalResult = displayError fullErr
, evalState = state
, evalPager = ""
, evalComms = []
}
wrapExecution :: KernelState
-> Interpreter Display
-> Interpreter EvalOut
wrapExecution state exec = safely state $ exec >>= \res ->
return EvalOut {
evalStatus = Success,
evalResult = res,
evalState = state,
evalPager = "",
evalComms = []
wrapExecution state exec = safely state $
exec >>= \res ->
return
EvalOut
{ evalStatus = Success
, evalResult = res
, 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 _ (Import importStr) state = wrapExecution state $ do
write state $ "Import: " ++ importStr
@ -393,21 +402,21 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
-- Remember which modules we've loaded before.
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 (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl
moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp
-- Return whether this module prevents the loading of the one we're
-- trying to load. If a module B exist, we cannot load A.B. All
-- modules must have unique last names (where A.B has last name B).
-- Return whether this module prevents the loading of the one we're trying to load. If a module B
-- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).
-- However, we *can* just reload a module.
preventsLoading mod =
let pieces = moduleNameOf mod in
last namePieces == last pieces && namePieces /= pieces
let pieces = moduleNameOf mod
in last namePieces == last pieces && namePieces /= pieces
-- If we've loaded anything with the same last name, we can't use this.
-- Otherwise, GHC tries to load the original *.hs fails and then fails.
-- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load
-- the original *.hs fails and then fails.
case find preventsLoading importedModules of
-- If something prevents loading this module, return an error.
Just previous -> do
@ -425,7 +434,8 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
-- Find which flags are IHaskell flags, and which are GHC flags
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 flag = getUpdateKernelState <$> find (elem flag . getSetName) kernelOpts
@ -437,38 +447,44 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
if null flags
then do
flags <- getSessionDynFlags
return EvalOut {
evalStatus = Success,
evalResult = Display [plain $ showSDoc flags $ vcat [pprDynFlags False flags, pprLanguages False flags]],
evalState = state,
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Success
, evalResult = Display
[ plain $ showSDoc flags $ vcat
[ pprDynFlags False flags
, pprLanguages False flags
]
]
, evalState = state
, evalPager = ""
, evalComms = []
}
else do
-- Apply all IHaskell flag updaters to the state to get the new state
let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state
errs <- setFlags ghcFlags
let display = case errs of
let display =
case errs of
[] -> mempty
_ -> displayError $ intercalate "\n" errs
-- For -XNoImplicitPrelude, remove the Prelude import.
-- For -XImplicitPrelude, add it back in.
-- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in.
if "-XNoImplicitPrelude" `elem` flags
then evalImport "import qualified Prelude as Prelude"
else
when ("-XImplicitPrelude" `elem` flags) $ do
else when ("-XImplicitPrelude" `elem` flags) $ do
importDecl <- parseImportDecl "import Prelude"
let implicitPrelude = importDecl { ideclImplicit = True }
imports <- getContext
setContext $ IIDecl implicitPrelude : imports
return EvalOut {
evalStatus = Success,
evalResult = display,
evalState = state',
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Success
, evalResult = display
, evalState = state'
, evalPager = ""
, evalComms = []
}
evalCommand output (Directive SetExtension opts) state = do
@ -546,7 +562,8 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
"cd":dirs -> do
-- Get home so we can replace '~` with it.
homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String))
let home = case homeEither of
let home =
case homeEither of
Left _ -> "~"
Right val -> val
@ -554,8 +571,8 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
exists <- liftIO $ doesDirectoryExist directory
if exists
then do
-- Set the directory in IHaskell native code, for future shell
-- commands. This doesn't set it for user code, though.
-- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for
-- user code, though.
liftIO $ setCurrentDirectory directory
-- Set the directory for user code.
@ -564,21 +581,14 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
replace "\"" "\\\"" directory
runStmt cmd RunToCompletion
return mempty
else
return $ displayError $ printf "No such directory: '%s'" directory
else return $ displayError $ printf "No such directory: '%s'" directory
cmd -> liftIO $ do
#if MIN_VERSION_base(4,8,0)
(pipe, handle) <- createPipe
#else
(readEnd, writeEnd) <- createPipe
handle <- fdToHandle writeEnd
pipe <- fdToHandle readEnd
#endif
(pipe, handle) <- createPipe'
let initProcSpec = shell $ unwords cmd
procSpec = initProcSpec {
std_in = Inherit,
std_out = UseHandle handle,
std_err = UseHandle handle
procSpec = initProcSpec
{ std_in = Inherit
, std_out = UseHandle handle
, std_err = UseHandle handle
}
(_, _, _, process) <- createProcess procSpec
@ -587,8 +597,8 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
-- Start a loop to publish intermediate results.
let
-- Compute how long to wait between reading pieces of the output.
-- `threadDelay` takes an argument of microseconds.
-- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
-- argument of microseconds.
ms = 1000
delay = 100 * ms
@ -625,23 +635,38 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
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]
return $ Display
[ plain $ out ++ "\n" ++ errMsg
, html $ printf "<span class='mono'>%s</span>" out ++ htmlErr
]
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.
evalCommand _ (Directive GetHelp _) state = do
write state "Help via :help or :?."
return EvalOut {
evalStatus = Success,
evalResult = Display [out],
evalState = state,
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Success
, evalResult = Display [out]
, evalState = state
, evalPager = ""
, evalComms = []
}
where out = plain $ intercalate "\n"
where
out = plain $ intercalate "\n"
[ "The following commands are available:"
, " :extension <Extension> - Enable a GHC extension."
, " :extension No<Extension> - Disable a GHC extension."
@ -673,17 +698,20 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
-- TODO: Make pager work without html by porting to newer architecture
let output = unlines (map htmlify strings)
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>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>"
return EvalOut {
evalStatus = Success,
evalResult = mempty,
evalState = state,
evalPager = output,
evalComms = []
return
EvalOut
{ evalStatus = Success
, evalResult = mempty
, evalState = state
, evalPager = output
, evalComms = []
}
evalCommand _ (Directive SearchHoogle query) state = safely state $ do
@ -711,8 +739,7 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
write state $ "Names: " ++ show allNames
-- Display the types of all bound names if the option is on.
-- This is similar to GHCi :set +t.
-- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
if not $ useShowTypes state
then return $ Display output
else do
@ -724,14 +751,12 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
let joined = unlines types
htmled = unlines $ map formatGetType types
return $ case extractPlain output of
return $
case extractPlain output of
"" -> Display [html htmled]
-- Return plain and html versions.
-- Previously there was only a plain version.
text -> Display
[plain $ joined ++ "\n" ++ text,
html $ htmled ++ mono text]
-- Return plain and html versions. Previously there was only a plain version.
text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]
RunException exception -> throw exception
RunBreak{} -> error "Should not break."
@ -739,10 +764,9 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
evalCommand output (Expression expr) state = do
write state $ "Expression:\n" ++ expr
-- Try to use `display` to convert our type into the output
-- Dislay If typechecking fails and there is no appropriate
-- typeclass instance, this will throw an exception and thus `attempt` will
-- return False, and we just resort to plaintext.
-- Try to use `display` to convert our type into the output Dislay If typechecking fails and there
-- is no appropriate typeclass instance, this will throw an exception and thus `attempt` will return
-- False, and we just resort to plaintext.
let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String
canRunDisplay <- attempt $ exprType displayExpr
@ -760,17 +784,19 @@ evalCommand output (Expression expr) state = do
write state $ "Is Declaration: " ++ show isTHDeclaration
if isTHDeclaration
-- If it typechecks as a DecsQ, we do not want to display the DecsQ,
-- we just want the declaration made.
then do
then
-- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the
-- declaration made.
do
write state $ "Suppressing display for template haskell declaration"
GHC.runDecls expr
return EvalOut {
evalStatus = Success,
evalResult = mempty,
evalState = state,
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Success
, evalResult = mempty
, evalState = state
, evalPager = ""
, evalComms = []
}
else do
if canRunDisplay
@ -783,36 +809,37 @@ evalCommand output (Expression expr) state = do
then registerWidget out
else return out
else do
-- Evaluate this expression as though it's just a statement.
-- The output is bound to 'it', so we can then use it.
-- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can
-- then use it.
evalOut <- evalCommand output (Statement expr) state
let out = evalResult evalOut
showErr = isShowError out
-- If evaluation failed, return the failure. If it was successful, we
-- may be able to use the IHaskellDisplay typeclass.
-- If evaluation failed, return the failure. If it was successful, we may be able to use the
-- IHaskellDisplay typeclass.
return $ if not showErr || useShowErrors state
then evalOut
else postprocessShowError evalOut
where
-- Try to evaluate an action. Return True if it succeeds and False if
-- it throws an exception. The result of the action is discarded.
-- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The
-- result of the action is discarded.
attempt :: Interpreter a -> Interpreter Bool
attempt action = gcatch (action >> return True) failure
where failure :: SomeException -> Interpreter Bool
where
failure :: SomeException -> Interpreter Bool
failure _ = return False
-- Check if the error is due to trying to print something that doesn't
-- implement the Show typeclass.
-- Check if the error is due to trying to print something that doesn't implement the Show typeclass.
isShowError (ManyDisplay _) = False
isShowError (Display errs) =
-- Note that we rely on this error message being 'type cleaned', so
-- that `Show` is not displayed as GHC.Show.Show. This is also very fragile!
-- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as
-- GHC.Show.Show. This is also very fragile!
startswith "No instance for (Show" msg &&
isInfixOf "print it" msg
where msg = extractPlain errs
where
msg = extractPlain errs
isSvg (DisplayData mime _) = mime == MimeSvg
@ -821,16 +848,12 @@ evalCommand output (Expression expr) state = do
removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps
useDisplay displayExpr = do
-- If there are instance matches, convert the object into
-- a Display. We also serialize it into a bytestring. We get
-- the bytestring IO action as a dynamic and then convert back to
-- a bytestring, which we promptly unserialize. Note that
-- attempting to do this without the serialization to binary and
-- back gives very strange errors - all the types match but 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`.
-- If there are instance matches, convert the object into a Display. We also serialize it into a
-- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring,
-- which we promptly unserialize. Note that attempting to do this without the serialization to
-- binary and back gives very strange errors - all the types match but 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
let stmtTemplate = if io
then "it <- (%s)"
@ -872,9 +895,14 @@ evalCommand output (Expression expr) state = do
state' = state { openComms = newComms }
-- Store the fact that we should start this comm.
return evalOut {
evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut,
evalState = state'
return evalOut
{ evalComms = CommInfo
widget
uuid
(targetName
widget) : evalComms
evalOut
, evalState = state'
}
isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
@ -885,16 +913,20 @@ evalCommand output (Expression expr) state = do
Display disps = evalResult evalOut
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
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 [
"$('#unshowable').on('click', function(e) {",
" e.preventDefault();",
" var $this = $(this);",
" var $collapse = $this.closest('.collapse-group').find('.err-msg');",
" $collapse.collapse('toggle');",
"});"
script = unlines
[ "$('#unshowable').on('click', function(e) {"
, " e.preventDefault();"
, " var $this = $(this);"
, " var $collapse = $this.closest('.collapse-group').find('.err-msg');"
, " $collapse.collapse('toggle');"
, "});"
]
postprocess other = other
@ -910,14 +942,12 @@ evalCommand output (Expression expr) state = do
else after
evalCommand _ (Declaration decl) state = wrapExecution state $ do
write state $ "Declaration:\n" ++ decl
boundNames <- evalDeclarations decl
let nonDataNames = filter (not . isUpper . head) boundNames
-- Display the types of all bound names if the option is on.
-- This is similar to GHCi :set +t.
-- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
if not $ useShowTypes state
then return mempty
else do
@ -930,53 +960,51 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do
return $ Display [html $ unlines $ map formatGetType types]
evalCommand _ (TypeSignature sig) state = wrapExecution state $
-- We purposefully treat this as a "success" because that way execution
-- continues. Empty type signatures are likely due to a parse error later
-- on, and we want that to be displayed.
return $ displayError $ "The type signature " ++ sig ++
"\nlacks an accompanying binding."
-- We purposefully treat this as a "success" because that way execution continues. Empty type
-- signatures are likely due to a parse error later on, and we want that to be displayed.
return $ displayError $ "The type signature " ++ sig ++ "\nlacks an accompanying binding."
evalCommand _ (ParseError loc err) state = do
write state "Parse Error."
return EvalOut {
evalStatus = Failure,
evalResult = displayError $ formatParseError loc err,
evalState = state,
evalPager = "",
evalComms = []
return
EvalOut
{ evalStatus = Failure
, evalResult = displayError $ formatParseError loc err
, evalState = state
, evalPager = ""
, evalComms = []
}
evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $
return $ displayError $ "Pragmas of type " ++ pragmaType ++
"\nare not supported."
return $ displayError $ "Pragmas of type " ++ pragmaType ++ "\nare not supported."
evalCommand output (Pragma PragmaLanguage pragmas) state = do
write state $ "Got LANGUAGE pragma " ++ show pragmas
evalCommand output (Directive SetExtension $ unwords pragmas) state
hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
hoogleResults state results = EvalOut {
evalStatus = Success,
evalResult = mempty,
evalState = state,
evalPager = output,
evalComms = []
hoogleResults state results =
EvalOut
{ evalStatus = Success
, evalResult = mempty
, evalState = state
, evalPager = output
, evalComms = []
}
where
-- TODO: Make pager work with plaintext
fmt = Hoogle.HTML
output = unlines $ map (Hoogle.render fmt) results
-- Read from a file handle until we hit a delimiter or until we've read
-- as many characters as requested
-- Read from a file handle until we hit a delimiter or until we've read as many characters as
-- requested
readChars :: Handle -> String -> Int -> IO String
-- If we're done reading, return nothing.
readChars handle delims 0 = return []
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 handle is already closed.
tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
case tryRead of
Right char ->
@ -998,13 +1026,7 @@ doLoadModule name modName = do
flip gcatch (unload importedModules) $ do
-- Compile loaded modules.
flags <- getSessionDynFlags
#if MIN_VERSION_ghc(7,8,0)
let objTarget = defaultObjectTarget platform
platform = targetPlatform flags
#else
let objTarget = defaultObjectTarget
#endif
setSessionDynFlags flags{ hscTarget = objTarget }
setSessionDynFlags flags { hscTarget = objTarget flags }
-- Clear old targets to be sure.
setTargets []
@ -1030,7 +1052,14 @@ doLoadModule name modName = do
case result of
Succeeded -> return mempty
Failed -> return $ displayError $ "Failed to load module " ++ modName
where
#if MIN_VERSION_ghc(7,8,0)
objTarget flags = defaultObjectTarget $ targetPlatform flags
#else
objTarget flags = defaultObjectTarget
#endif
unload :: [InteractiveImport] -> SomeException -> Ghc Display
unload imported exception = do
print $ show exception

89
src/IHaskell/Eval/Hoogle.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
module IHaskell.Eval.Hoogle (
search,
document,
render,
OutputFormat(..),
HoogleResult
HoogleResult,
) where
import ClassyPrelude hiding (last, span, div)
@ -22,19 +23,13 @@ import qualified Prelude as P
import IHaskell.IPython
-- | Types of formats to render output to.
data OutputFormat
= Plain -- ^ Render to plain text.
data OutputFormat = Plain -- ^ Render to plain text.
| 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)
data HoogleResult
= SearchResult HoogleResponse
data HoogleResult = SearchResult HoogleResponse
| DocResult HoogleResponse
| NoResult String
deriving Show
@ -48,23 +43,21 @@ instance FromJSON [HoogleResponse] where
instance FromJSON HoogleResponse where
parseJSON (Object obj) =
HoogleResponse <$>
obj .: "location" <*>
obj .: "self" <*>
obj .: "docs"
HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs"
parseJSON _ = fail "Expected object with fields: location, self, docs"
-- | Query Hoogle for the given string.
-- This searches Hoogle using the internet. It returns either an error
-- message or the successful JSON result.
-- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
-- an error message or the successful JSON result.
query :: String -> IO (Either String String)
query str = do
request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request
return $ case response of
return $
case response of
Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp
where
queryUrl :: String -> String
queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
@ -90,15 +83,15 @@ urlEncode (ch:t)
eightBs :: [Int] -> Int -> [Int]
eightBs acc x
| x <= 0xff = (x:acc)
| x <= 255 = x : acc
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
-- | Search for a query on Hoogle.
-- Return all search results.
-- | Search for a query on Hoogle. Return all search results.
search :: String -> IO [HoogleResult]
search string = do
response <- query string
return $ case response of
return $
case response of
Left err -> [NoResult err]
Right json ->
case eitherDecode $ Char.pack json of
@ -108,16 +101,17 @@ search string = do
[] -> [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.
document :: String -> IO [HoogleResult]
document string = do
matchingResults <- filter matches <$> search string
let results = map toDocResult matchingResults
return $ case results of
return $
case results of
[] -> [NoResult "no matching identifiers found."]
res -> res
where
matches (SearchResult resp) =
case split " " $ self resp of
@ -139,16 +133,10 @@ renderPlain (NoResult res) =
"No response available: " ++ res
renderPlain (SearchResult resp) =
printf "%s\nURL: %s\n%s"
(self resp)
(location resp)
(docs resp)
printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
renderPlain (DocResult resp) =
printf "%s\nURL: %s\n%s"
(self resp)
(location resp)
(docs resp)
printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
-- | Render a Hoogle result to HTML.
renderHtml :: HoogleResult -> String
@ -167,37 +155,37 @@ renderHtml (SearchResult resp) =
renderSelf :: String -> String -> String
renderSelf string loc
| startswith "package" string
= pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "package" string =
pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "module" string
= let package = extractPackageName loc in
mod ++ " " ++
| startswith "module" string =
let package = extractPackageName loc
in mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++
packageSub package
| startswith "class" string
= let package = extractPackageName loc in
cls ++ " " ++
| startswith "class" string =
let package = extractPackageName loc
in cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++
packageSub package
| startswith "data" string
= let package = extractPackageName loc in
dat ++ " " ++
| startswith "data" string =
let package = extractPackageName loc
in dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++
packageSub package
| otherwise
= let [name, args] = split "::" string
| otherwise =
let [name, args] = split "::" string
package = extractPackageName loc
modname = extractModuleName loc in
span "hoogle-name" (unicodeReplace $
modname = extractModuleName loc
in span "hoogle-name"
(unicodeReplace $
link loc (strip name) ++
" :: " ++
strip args)
++ packageAndModuleSub package modname
where
extractPackage = strip . replace "package" ""
extractModule = strip . replace "module" ""
@ -239,8 +227,7 @@ renderDocs doc =
if isCode lines
then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines
in
div "hoogle-doc" $ unlines $ map makeBlock groups
in div "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String
extractPackageName link = do

8
src/IHaskell/Eval/Info.hs
View File

@ -1,9 +1,7 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-}
module IHaskell.Eval.Info (
info
) where
{- | Description : Inspect type and function information and documentation. -}
module IHaskell.Eval.Info (info) where
import ClassyPrelude hiding (liftIO)

85
src/IHaskell/Eval/Lint.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (
lint
) where
module IHaskell.Eval.Lint (lint) where
import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last)
@ -32,13 +31,13 @@ import IHaskell.Eval.Parser hiding (line)
type ExtsModule = SrcExts.Module SrcSpanInfo
data LintSuggestion
= Suggest {
line :: LineNumber,
found :: String,
whyNot :: String,
severity :: Severity,
suggestion :: String
data LintSuggestion =
Suggest
{ line :: LineNumber
, found :: String
, whyNot :: String
, severity :: Severity
, suggestion :: String
}
deriving (Eq, Show)
@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
lintIdent :: String
lintIdent = "lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable
-- report on linting warnings and errors.
-- | Given parsed code chunks, perform linting and output a displayable report on linting warnings
-- and errors.
lint :: [Located CodeBlock] -> IO Display
lint blocks = do
-- Initialize hlint settings
@ -72,20 +71,19 @@ lint blocks = do
return $ Display $
if null suggestions
then []
else
[plain $ concatMap plainSuggestion suggestions,
html $ htmlSuggestions suggestions]
else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
showIdea :: Idea -> Maybe LintSuggestion
showIdea idea =
case ideaTo idea of
Nothing -> Nothing
Just whyNot -> Just Suggest {
line = srcSpanStartLine $ ideaSpan idea,
found = showSuggestion $ ideaFrom idea,
whyNot = showSuggestion whyNot,
severity = ideaSeverity idea,
suggestion = ideaHint idea
Just whyNot -> Just
Suggest
{ line = srcSpanStartLine $ ideaSpan idea
, found = showSuggestion $ ideaFrom idea
, whyNot = showSuggestion whyNot
, severity = ideaSeverity idea
, suggestion = ideaHint idea
}
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
@ -111,12 +109,12 @@ createModule mode (Located line block) =
unparse _ = Nothing
srcSpan :: SrcSpan
srcSpan = SrcSpan {
srcSpanFilename = "<interactive>",
srcSpanStartLine = line,
srcSpanStartColumn = 0,
srcSpanEndLine = line + length (lines blockStr),
srcSpanEndColumn = length $ last $ lines blockStr
srcSpan = SrcSpan
{ srcSpanFilename = "<interactive>"
, srcSpanStartLine = line
, srcSpanStartColumn = 0
, srcSpanEndLine = line + length (lines blockStr)
, srcSpanEndColumn = length $ last $ lines blockStr
}
loc :: SrcSpanInfo
@ -135,7 +133,8 @@ createModule mode (Located line block) =
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of
stmtToModule stmtStr =
case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b
where
@ -158,10 +157,7 @@ createModule mode (Located line block) =
plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest =
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s"
(line suggest)
(suggestion suggest)
(found suggest)
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest)
(whyNot suggest)
htmlSuggestions :: [LintSuggestion] -> String
@ -169,18 +165,17 @@ htmlSuggestions = concatMap toHtml
where
toHtml :: LintSuggestion -> String
toHtml suggest = concat
[
named $ suggestion suggest,
floating "left" $ style severityClass "Found:" ++
[ named $ suggestion suggest
, floating "left" $ style severityClass "Found:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (found suggest),
floating "left" $ style severityClass "Why Not:" ++
styleId "highlight-code" "haskell" (found suggest)
, floating "left" $ style severityClass "Why Not:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (whyNot suggest)
]
where
severityClass = case severity suggest of
severityClass =
case severity suggest of
Error -> "error"
Warning -> "warning"
@ -214,18 +209,14 @@ showSuggestion = remove lintIdent . dropDo
else string
clean :: [String] -> [String]
-- If the first line starts with a `do`...
-- Note that hlint always indents by two spaces in its output.
-- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
-- output.
clean ((stripPrefix " do " -> Just a):as) =
-- Take all indented lines and unindent them.
let unindented = catMaybes
$ takeWhile isJust
$ map (stripPrefix " ") as
let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix " ") as
fullDo = a : unindented
afterDo = drop (length unindented) as
in
--
fullDo ++ clean afterDo
in fullDo ++ clean afterDo
-- Ignore other list elements - just proceed onwards.
clean (x:xs) = x : clean xs

7
src/IHaskell/Eval/ParseShell.hs
View File

@ -1,4 +1,3 @@
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where
@ -22,7 +21,8 @@ manyTill p end = scan
xs <- scan
return $ x : xs
manyTill1 p end = do x <- p
manyTill1 p end = do
x <- p
xs <- manyTill p end
return $ x : xs
@ -37,7 +37,8 @@ quotedString = do
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end
where end = unescapedChar space
where
end = unescapedChar space
<|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word"

94
src/IHaskell/Eval/Parser.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module IHaskell.Eval.Parser (
parseString,
CodeBlock(..),
@ -26,28 +27,28 @@ import GHC hiding (Located)
import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
-- | A block of code to be evaluated.
-- Each block contains a single element - one declaration, statement,
-- expression, etc. If parsing of the block failed, the block is instead
-- a ParseError, which has the error location and error message.
data CodeBlock
= Expression String -- ^ A Haskell expression.
-- | A block of code to be evaluated. Each block contains a single element - one declaration,
-- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,
-- which has the error location and error message.
data CodeBlock = Expression String -- ^ A Haskell expression.
| Declaration String -- ^ A data type or function declaration.
| Statement String -- ^ A Haskell statement (as if in a `do` block).
| Import String -- ^ An import statement.
| TypeSignature String -- ^ A lonely type signature (not above a function declaration).
| TypeSignature String -- ^ A lonely type signature (not above a function
-- declaration).
| Directive DirectiveType String -- ^ An IHaskell directive.
| Module String -- ^ A full Haskell module, to be compiled and loaded.
| ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block failed.
| Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-} block)
| ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block
-- failed.
| Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-}
-- block)
deriving (Show, Eq)
-- | Directive types. Each directive is associated with a string in the
-- directive code block.
data DirectiveType
= GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)
-- | Directive types. Each directive is associated with a string in the directive code block.
data DirectiveType = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)
| GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)
| SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set`
| SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`.
-- Emulates GHCi's `:set`
| LoadFile -- ^ Load a Haskell module.
| SetOption -- ^ Set IHaskell kernel option `:option`.
| SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`
@ -59,10 +60,9 @@ data DirectiveType
| LoadModule -- ^ Load and unload modules via ':module'.
deriving (Show, Eq)
-- | Pragma types. Only LANGUAGE pragmas are currently supported.
-- Other pragma types are kept around as a string for error reporting.
data PragmaType
= PragmaLanguage
-- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around
-- as a string for error reporting.
data PragmaType = PragmaLanguage
| PragmaUnsupported String
deriving (Show, Eq)
@ -73,18 +73,18 @@ parseString codeString = do
flags <- getSessionDynFlags
let output = runParser flags parserModule codeString
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
-- Split input into chunks based on indentation.
let chunks = layoutChunks $ removeComments codeString
result <- joinFunctions <$> processChunks [] chunks
-- Return to previous flags. When parsing, flags can be set to make
-- sure parsing works properly. But we don't want those flags to be
-- set during evaluation until the right time.
-- Return to previous flags. When parsing, flags can be set to make sure parsing works properly. But
-- we don't want those flags to be set during evaluation until the right time.
_ <- setSessionDynFlags flags
return result
otherwise -> error "parseString failed, output was neither Parsed nor Failure"
where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$> handleChunk chunk line
@ -137,14 +137,15 @@ parseCodeChunk code startLine = do
rawResults = map (tryParser code) (parsers flags)
-- Convert statements into expressions where we can
results = map (statementToExpression flags) rawResults in
results = map (statementToExpression flags) rawResults
case successes results of
-- If none of them succeeded, choose the best error message to
-- display. Only one of the error messages is actually relevant.
-- If none of them succeeded, choose the best error message to display. Only one of the error
-- messages is actually relevant.
[] -> return $ bestError $ failures results
-- If one of the parsers succeeded
result:_ -> return result
where
successes :: [ParseOutput a] -> [a]
successes [] = []
@ -164,19 +165,22 @@ parseCodeChunk code startLine = do
statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression flags (Parsed (Statement stmt)) = Parsed result
where result = if isExpr flags stmt
where
result = if isExpr flags stmt
then Expression stmt
else Statement stmt
statementToExpression _ other = other
-- Check whether a string is a valid expression.
isExpr :: DynFlags -> String -> Bool
isExpr flags str = case runParser flags parserExpression str of
isExpr flags str =
case runParser flags parserExpression str of
Parsed{} -> True
_ -> False
tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
tryParser string (blockType, parser) = case parser string of
tryParser string (blockType, parser) =
case parser string of
Parsed res -> Parsed (blockType res)
Failure err loc -> Failure err loc
otherwise -> error "tryParser failed, output was neither Parsed nor Failure"
@ -196,9 +200,9 @@ parseCodeChunk code startLine = do
Partial out strs -> Partial code strs
Failure err loc -> Failure err loc
-- | Find consecutive declarations of the same function and join them into
-- a single declaration. These declarations may also include a type
-- signature, which is also joined with the subsequent declarations.
-- | Find consecutive declarations of the same function and join them into a single declaration.
-- These declarations may also include a type signature, which is also joined with the subsequent
-- declarations.
joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [] = []
joinFunctions blocks =
@ -230,9 +234,10 @@ parsePragma ('{':'-':'#':pragma) line =
let commaToSpace :: Char -> Char
commaToSpace ',' = ' '
commaToSpace x = x
pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma in
case pragmas of
[] -> Pragma (PragmaUnsupported "") [] --empty string pragmas are unsupported
pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma
in case pragmas of
--empty string pragmas are unsupported
[] -> Pragma (PragmaUnsupported "") []
"LANGUAGE":xs -> Pragma PragmaLanguage xs
x:xs -> Pragma (PragmaUnsupported x) xs
@ -242,17 +247,20 @@ parseDirective :: String -- ^ Directive string.
-> CodeBlock -- ^ Directive code block or a parse error.
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!' : directive
parseDirective (':':directive) line = case find rightDirective directives of
parseDirective (':':directive) line =
case find rightDirective directives of
Just (directiveType, _) -> Directive directiveType arg
where arg = unwords restLine
_:restLine = words directive
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
rightDirective (_, dirname) = case words directive of
rightDirective (_, dirname) =
case words directive of
[] -> False
dir:_ -> dir `elem` tail (inits dirname)
directives =
@ -271,9 +279,9 @@ parseDirective (':':directive) line = case find rightDirective directives of
]
parseDirective _ _ = error "Directive must start with colon!"
-- | Parse a module and return the name declared in the 'module X where'
-- line. That line is required, and if it does not exist, this will error.
-- Names with periods in them are returned piece y piece.
-- | Parse a module and return the name declared in the 'module X where' line. That line is
-- required, and if it does not exist, this will error. Names with periods in them are returned
-- piece y piece.
getModuleName :: GhcMonad m => String -> m [String]
getModuleName moduleSrc = do
flags <- getSessionDynFlags

164
src/IHaskell/Eval/Util.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE CPP, NoImplicitPrelude #-}
module IHaskell.Eval.Util (
-- * Initialization
initGhci,
-- * Flags and extensions
-- ** Set and unset flags.
extensionFlag, setExtension,
-- * Flags and extensions ** Set and unset flags.
extensionFlag,
setExtension,
ExtFlag(..),
setFlags,
@ -19,7 +20,7 @@ module IHaskell.Eval.Util (
-- * Pretty printing
doc,
pprDynFlags,
pprLanguages
pprLanguages,
) where
import ClassyPrelude hiding ((<>))
@ -50,20 +51,17 @@ import Data.String.Utils (replace)
import Data.List (nubBy)
-- | A extension flag that can be set or unset.
data ExtFlag
= SetFlag ExtensionFlag
data ExtFlag = SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
-- | Find the extension that corresponds to a given flag. Create the
-- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@.
-- If no such extension exist, yield @Nothing@.
-- | Find the extension that corresponds to a given flag. Create the corresponding 'ExtFlag' via
-- @SetFlag@ or @UnsetFlag@. If no such extension exist, yield @Nothing@.
extensionFlag :: String -- Extension name, such as @"DataKinds"@
-> Maybe ExtFlag
extensionFlag ext =
case find (flagMatches ext) xFlags of
Just fs -> Just $ SetFlag $ flagSpecFlag fs
-- If it doesn't match an extension name, try matching against
-- disabling an extension.
-- If it doesn't match an extension name, try matching against disabling an extension.
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just fs -> Just $ UnsetFlag $ flagSpecFlag fs
@ -72,8 +70,7 @@ extensionFlag ext =
-- Check if a FlagSpec matches an extension name.
flagMatches ext fs = ext == flagSpecName fs
-- Check if a FlagSpec matches "No<ExtensionName>".
-- In that case, we disable the extension.
-- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs
#if !MIN_VERSION_ghc(7,10,0)
@ -81,39 +78,32 @@ extensionFlag ext =
flagSpecFlag (_, flag, _) = flag
#endif
#if !MIN_VERSION_ghc(7,10,0)
flagSpecName (name,_,_) = name
flagSpecFlag (_,flag,_) = flag
#endif
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
pprDynFlags :: Bool -- ^ Whether to include flags which are on by default
-> DynFlags
-> SDoc
pprDynFlags show_all dflags =
vcat [
#if MIN_VERSION_ghc(7,8,0)
text "GHCi-specific dynamic flag settings:" $$
nest 2 (vcat (map (setting gopt) ghciFlags)),
text "other dynamic, non-language, flag settings:" $$
nest 2 (vcat (map (setting gopt) others)),
text "warning settings:" $$
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))
#else
text "GHCi-specific dynamic flag settings:" $$
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
]
where
#if MIN_VERSION_ghc(7,8,0)
opt = gopt
#else
opt = dopt
#endif
setting test flag
| quiet = empty
| is_on = fstr name
| otherwise = fnostr name
where name = flagSpecName flag
where
name = flagSpecName flag
f = flagSpecFlag flag
is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
@ -123,20 +113,18 @@ pprDynFlags show_all dflags =
fstr str = text "-f" <> text str
fnostr str = text "-fno-" <> text str
(ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)
DynFlags.fFlags
flgs = [
Opt_PrintExplicitForalls
(ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags
flgs = concat [flgs1, flgs2, flgs3]
flgs1 = [Opt_PrintExplicitForalls]
#if MIN_VERSION_ghc(7,8,0)
, Opt_PrintExplicitKinds
flgs2 = [Opt_PrintExplicitKinds]
#else
flgs2 = []
#endif
, Opt_PrintBindResult
, Opt_BreakOnException
, Opt_BreakOnError
, Opt_PrintEvldWithShow
]
flgs3 = [Opt_PrintBindResult, 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
-> DynFlags
-> SDoc
@ -146,17 +134,17 @@ pprLanguages show_all dflags =
case language dflags of
Nothing -> text "Haskell2010"
Just Haskell98 -> text "Haskell98"
Just Haskell2010 -> text "Haskell2010"
, (if show_all then text "all active language options:"
Just Haskell2010 -> text "Haskell2010", (if show_all
then text "all active language options:"
else text "with the following modifiers:") $$
nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
]
nest 2 (vcat (map (setting xopt) DynFlags.xFlags))]
where
setting test flag
| quiet = empty
| is_on = text "-X" <> text name
| otherwise = text "-XNo" <> text name
where name = flagSpecName flag
where
name = flagSpecName flag
f = flagSpecFlag flag
is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
@ -167,8 +155,8 @@ pprLanguages show_all dflags =
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 ext = do
flags <- getSessionDynFlags
@ -181,9 +169,8 @@ setExtension ext = do
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing
-- | Set a list of flags, as per GHCi's `:set`.
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).
-- It returns a list of error messages.
-- | Set a list of flags, as per GHCi's `:set`. This was adapted from GHC's InteractiveUI.hs
-- (newDynFlags). It returns a list of error messages.
setFlags :: GhcMonad m => [String] -> m [String]
setFlags ext = do
-- Try to parse flags.
@ -203,11 +190,10 @@ setFlags ext = do
warnErrs = map ("Warning: " ++) allWarns
return $ noParseErrs ++ warnErrs
-- | Convert an 'SDoc' into a string. This is similar to the family of
-- 'showSDoc' functions, but does not impose an arbitrary width limit on
-- the output (in terms of number of columns). Instead, it respsects the
-- 'pprCols' field in the structure returned by 'getSessionDynFlags', and
-- thus gives a configurable width of output.
-- | Convert an 'SDoc' into a string. This is similar to the family of 'showSDoc' functions, but
-- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,
-- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus
-- gives a configurable width of output.
doc :: GhcMonad m => SDoc -> m String
doc sdoc = do
flags <- getSessionDynFlags
@ -216,6 +202,7 @@ doc sdoc = do
let cols = pprCols flags
d = runSDoc sdoc (initSDocContext flags style)
return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d
where
string_txt :: Pretty.TextDetails -> String -> String
string_txt (Pretty.Chr c) s = c : s
@ -223,8 +210,8 @@ doc sdoc = do
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.
-- This initializes some dyn flags (@ExtendedDefaultRules@,
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn
-- flags (@ExtendedDefaultRules@,
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- memory, sets a reasonable output width, and potentially a few other
-- things. It should be invoked before other functions from this module.
@ -234,27 +221,28 @@ doc sdoc = do
-- (and only the first time) it is called.
initGhci :: GhcMonad m => Maybe String -> m ()
initGhci sandboxPackages = do
-- Initialize dyn flags.
-- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
-- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
originalFlags <- getSessionDynFlags
let flag = flip xopt_set
unflag = flip xopt_unset
dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags
pkgConfs = case sandboxPackages of
pkgConfs =
case sandboxPackages of
Nothing -> extraPkgConfs originalFlags
Just path ->
let pkg = PkgConfFile path in
(pkg:) . extraPkgConfs originalFlags
let pkg = PkgConfFile path
in (pkg :) . extraPkgConfs originalFlags
void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,
ghcLink = LinkInMemory,
pprCols = 300,
extraPkgConfs = pkgConfs }
void $ setSessionDynFlags $ dflags
{ hscTarget = HscInterpreted
, ghcLink = LinkInMemory
, pprCols = 300
, extraPkgConfs = pkgConfs
}
-- | 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.
-- | 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 imports = do
importDecl <- parseImportDecl imports
@ -285,7 +273,8 @@ evalImport imports = do
-- Check whether an import is hidden.
isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp = case ideclHiding imp of
isHiddenImport imp =
case ideclHiding imp of
Just (True, _) -> True
_ -> False
@ -301,8 +290,7 @@ removeImport moduleName = do
isImportOf name (IIModule modName) = name == modName
isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl)
-- | Evaluate a series of declarations.
-- Return all names which were bound by these declarations.
-- | Evaluate a series of declarations. Return all names which were bound by these declarations.
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations decl = do
names <- runDecls decl
@ -321,16 +309,17 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } }
where
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)
-- Only support replacing instances on GHC 7.8 and up
let tpl_tv_set = mkVarSet tpl_tvs
instEq c1 c2
| 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
False
instEq _ _ = False
#endif
-- | Get the type of an expression and convert it to a string.
getType :: GhcMonad m => String -> m String
getType expr = do
@ -345,18 +334,20 @@ getDescription str = do
names <- parseName str
maybeInfos <- mapM getInfo' names
-- Filter out types that have parents in the same set.
-- GHCi also does this.
-- Filter out types that have parents in the same set. GHCi also does this.
let infos = catMaybes maybeInfos
allNames = mkNameSet $ map (getName . getType) infos
hasParent info = case tyThingParent_maybe (getType info) of
hasParent info =
case tyThingParent_maybe (getType info) of
Just parent -> getName parent `elemNameSet` allNames
Nothing -> False
filteredOutput = filter (not . hasParent) infos
-- Print nicely
mapM (doc . printInfo) filteredOutput
where
#if MIN_VERSION_ghc(7,8,0)
getInfo' = getInfo False
#else
@ -377,7 +368,8 @@ getDescription str = do
vcat (map GHC.pprFamInst famInstances)
#else
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
showFixity thing fixity =
if fixity == GHC.defaultFixity

19
src/IHaskell/Flags.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module IHaskell.Flags (
IHaskellMode(..),
Argument(..),
@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
import Data.List (findIndex)
import IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with
-- the mode being invoked.
-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
data Args = Args IHaskellMode [Argument]
deriving Show
@ -33,7 +33,9 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
| ConvertLhsStyle (LhsStyle String)
deriving (Eq, Show)
data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@
data LhsStyle string =
LhsStyle
{ lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@
@ -48,15 +50,13 @@ data NotebookFormat = LhsMarkdown
deriving (Eq, Show)
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode = ShowHelp String
| InstallKernelSpec
| ConvertLhs
| Kernel (Maybe String)
deriving (Eq, Show)
-- | Given a list of command-line arguments, return the IHaskell mode and
-- arguments to process.
-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
parseFlags :: [String] -> Either String Args
parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags
@ -111,7 +111,8 @@ installKernelSpec =
[ghcLibFlag, kernelDebugFlag, confFlag, helpFlag]
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
kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
@ -161,8 +162,8 @@ ihaskellArgs =
let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in
noMode { modeGroupModes = toGroup allModes }
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp
in noMode { modeGroupModes = toGroup allModes }
where
add flag (Args mode flags) = Args mode $ flag : flags

33
src/IHaskell/IPython.hs
View File

@ -40,17 +40,20 @@ import qualified GHC.Paths
import IHaskell.Types
import System.Posix.Signals
data KernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir :: String -- ^ GHC libdir.
data KernelSpecOptions =
KernelSpecOptions
{ kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecDebug :: Bool -- ^ Spew debugging output?
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir = GHC.Paths.libdir
defaultKernelSpecOptions = KernelSpecOptions
{ kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecDebug = False
, kernelSpecConfFile = defaultConfFile
}
-- | The IPython kernel name.
kernelName :: IsString a => a
kernelName = "haskell"
@ -133,6 +136,7 @@ verifyIPythonVersion = do
Just (1:_) -> oldIPython
Just (0:_) -> oldIPython
_ -> badIPython "Detected IPython, but could not parse version number."
where
badIPython :: Text -> Sh ()
badIPython message = liftIO $ do
@ -140,8 +144,8 @@ verifyIPythonVersion = do
exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location.
-- The right location is determined by using `ipython kernelspec install --user`.
-- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec replace opts = void $ do
ihaskellPath <- getIHaskellPath
@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
Just file -> ["--conf", file])
++ ["--ghclib", kernelSpecGhcLibdir opts]
let kernelSpec = KernelSpec { kernelDisplayName = "Haskell"
let kernelSpec = KernelSpec
{ kernelDisplayName = "Haskell"
, kernelLanguage = kernelName
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec
-- directory; then, shell out to IPython to install this kernelspec directory.
-- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
-- shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json"
@ -185,16 +190,15 @@ kernelSpecCreated = do
let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined.
-- Otherwise, do nothing.
-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
subHome :: String -> IO String
subHome path = shelly $ do
home <- unpack <$> fromMaybe "~" <$> get_env "HOME"
return $ replace "~" home path
-- | Get the path to an executable. If it doensn't exist, fail with an
-- error message complaining about it.
-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- about it.
path :: Text -> Sh FilePath
path exe = do
path <- which $ fromText exe
@ -229,9 +233,8 @@ getIHaskellPath = do
if FS.absolute f
then return $ FS.encodeString f
else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH
-- variable to find where IHaskell lives.
-- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
if FS.filename f == f
then do
ihaskellPath <- which "ihaskell"

47
src/IHaskell/Types.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
-- | Description : All message type definitions.
module IHaskell.Types (
Message(..),
@ -16,7 +16,8 @@ module IHaskell.Types (
ExecuteReplyStatus(..),
KernelState(..),
LintStatus(..),
Width, Height,
Width,
Height,
Display(..),
defaultKernelState,
extractPlain,
@ -90,8 +91,8 @@ instance Show Widget where
show _ = "<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
-- results from the same expression.
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- expression.
data Display = Display [DisplayData]
| ManyDisplay [Display]
deriving (Show, Typeable, Generic)
@ -108,7 +109,9 @@ instance Semigroup Display where
a <> b = a `mappend` b
-- | 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.
, useSvg :: Bool
, useShowErrors :: Bool
@ -120,7 +123,8 @@ data KernelState = KernelState { getExecutionCounter :: Int
deriving Show
defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1
defaultKernelState = KernelState
{ getExecutionCounter = 1
, getLintStatus = LintOn
, useSvg = True
, useShowErrors = False
@ -131,10 +135,12 @@ defaultKernelState = KernelState { getExecutionCounter = 1
}
-- | Kernel options to be set via `:set` and `:option`.
data KernelOpt = KernelOpt {
getOptionName :: [String], -- ^ Ways to set this option via `:option`
getSetName :: [String], -- ^ Ways to set this option via `:set`
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.
data KernelOpt =
KernelOpt
{ getOptionName :: [String] -- ^ Ways to set this option via `:option`
, getSetName :: [String] -- ^ Ways to set this option via `:set`
, getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
-- state.
}
kernelOpts :: [KernelOpt]
@ -152,23 +158,24 @@ kernelOpts =
]
-- | Current HLint status.
data LintStatus
= LintOn
data LintStatus = LintOn
| LintOff
deriving (Eq, Show)
data CommInfo = CommInfo Widget UUID String deriving Show
data CommInfo = CommInfo Widget UUID String
deriving Show
-- | Output of evaluation.
data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult {
outputs :: Display -- ^ Display outputs.
IntermediateResult
{ outputs :: Display -- ^ Display outputs.
}
| FinalResult {
outputs :: Display, -- ^ Display outputs.
pagerOut :: String, -- ^ Text to display in the IPython pager.
startComms :: [CommInfo] -- ^ Comms to start.
|
FinalResult
{ outputs :: Display -- ^ Display outputs.
, pagerOut :: String -- ^ Text to display in the IPython pager.
, startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show

75
src/Main.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets.
module Main where
module Main (main) where
-- Prelude imports.
import ClassyPrelude hiding (last, liftIO, readChan, writeChan)
@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do
-- Receive and reply to all messages on the shell socket.
interpret libdir True $ do
-- Ignore Ctrl-C the first time. This has to go inside the
-- `interpret`, because GHC API resets the signal handlers for some
-- reason (completely unknown to me).
-- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
-- signal handlers for some reason (completely unknown to me).
liftIO ignoreCtrlC
-- Initialize the context by evaluating everything we got from the
-- command line flags.
-- Initialize the context by evaluating everything we got from the command line flags.
let noPublish _ = return ()
evaluator line = void $ do
-- Create a new state each time.
@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do
-- Create a header for the reply.
replyHeader <- createReplyHeader (header request)
-- We handle comm messages and normal ones separately.
-- The normal ones are a standard request/response style, while comms
-- can be anything, and don't necessarily require a response.
-- We handle comm messages and normal ones separately. The normal ones are a standard
-- request/response style, while comms can be anything, and don't necessarily require a response.
if isCommMessage request
then liftIO $ do
oldState <- takeMVar state
@ -185,32 +183,33 @@ createReplyHeader parent = do
let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader {
identifiers = identifiers parent,
parentHeader = Just parent,
metadata = Map.fromList [],
messageId = newMessageId,
sessionId = sessionId parent,
username = username parent,
msgType = repType
return
MessageHeader
{ identifiers = identifiers parent
, parentHeader = Just parent
, metadata = Map.fromList []
, messageId = newMessageId
, sessionId = sessionId parent
, username = username parent
, msgType = repType
}
-- | Compute a reply to a 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 kernel info reply is a static object (all info is
-- hard coded into the representation of that message type).
-- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
-- kernel info reply is a static object (all info is hard coded into the representation of that
-- message type).
replyTo _ KernelInfoRequest{} replyHeader state =
return (state, KernelInfoReply {
header = replyHeader,
language = "haskell",
versionList = ghcVersionInts
return
(state, KernelInfoReply
{ header = replyHeader
, 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
-- is happening.
-- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- let the frontend know shutdown is happening.
replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
exitSuccess
@ -254,7 +253,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
convertSvgToHtml x = x
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
startComm :: CommInfo -> IO ()
@ -337,16 +337,16 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
return (state, reply)
-- Reply to the object_info_request message. Given an object name, return
-- the associated type calculated by GHC.
-- Reply to the object_info_request message. Given an object name, return the associated type
-- calculated by GHC.
replyTo _ ObjectInfoRequest { objectName = oname } replyHeader state = do
docs <- pack <$> info (unpack oname)
let reply = ObjectInfoReply {
header = replyHeader,
objectName = oname,
objectFound = strip docs /= "",
objectTypeString = docs,
objectDocString = docs
let reply = ObjectInfoReply
{ header = replyHeader
, objectName = oname
, objectFound = strip docs /= ""
, objectTypeString = docs
, objectDocString = docs
}
return (state, reply)
@ -354,7 +354,8 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
replyTo _ HistoryRequest{} replyHeader state = do
let reply = HistoryReply {
header = replyHeader,
historyReply = [] -- FIXME
-- FIXME
historyReply = []
}
return (state, reply)

21
verify_formatting.py
View File

@ -8,8 +8,9 @@ import subprocess
def hindent(contents):
return subprocess.check_output(["hindent", "--style", "gibiansky"],
output = subprocess.check_output(["hindent", "--style", "gibiansky"],
input=bytes(contents, 'utf-8'))
return output.decode('utf-8')
def diff(src1, src2):
@ -20,7 +21,11 @@ def diff(src1, src2):
with open(".tmp2", "w") as f2:
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
try:
@ -35,6 +40,8 @@ for root, dirnames, filenames in os.walk("src"):
for filename in filenames:
if filename.endswith(".hs"):
sources.append(os.path.join(root, filename))
break
break
hindent_outputs = {}
@ -47,9 +54,15 @@ for source_file in sources:
hindent_outputs[source_file] = (original_source, formatted_source)
diffs = {filename: diff(original, formatted)
for (filename, (original, formatted)) in hindent_outputs.values()}
for (filename, (original, formatted)) in hindent_outputs.items()}
incorrect_formatting = False
for filename, diff in diffs.items():
print(filename)
if diff:
incorrect_formatting = True
print('Incorrect formatting in', filename)
print('=' * 10)
print(diff)
if incorrect_formatting:
sys.exit(1)