mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-19 12:56:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #923 from erikd/topic/warnings

Browse Source 
-Wall the things
This commit is contained in:
Vaibhav Sagar 2018-09-01 07:45:30 -04:00 committed by GitHub
commit 3d382e7b79
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
33 changed files with 487 additions and 687 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
ihaskell.cabal
View File

@ -49,6 +49,7 @@ data-files:
library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
build-depends:
aeson >=1.0,
base >=4.9,
@ -120,7 +121,7 @@ executable ihaskell
other-modules:
IHaskellPrelude
Paths_ihaskell
ghc-options: -threaded -rtsopts
ghc-options: -threaded -rtsopts -Wall
-- Other library packages from which modules are imported.
default-language: Haskell2010
@ -141,7 +142,7 @@ executable ihaskell
Test-Suite hspec
Type: exitcode-stdio-1.0
Ghc-Options: -threaded
Ghc-Options: -threaded -Wall
Main-Is: Hspec.hs
hs-source-dirs: src/tests
other-modules:

36
main/IHaskellPrelude.hs
View File

@ -1,4 +1,5 @@
{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}{-# LANGUAGE CPP #-}
{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
{-# LANGUAGE CPP #-}
module IHaskellPrelude (
module IHaskellPrelude,
module X,
@ -64,7 +65,8 @@ module IHaskellPrelude (
import Prelude
import Data.Monoid as X
import Data.Semigroup as X
import Data.Monoid as X hiding ((<>), First(..), Last(..))
import Data.Tuple as X
import Control.Monad as X
import Data.Maybe as X
@ -83,7 +85,7 @@ import Data.List as X hiding (head, last, tail, init, tra
elemIndices, elemIndex, findIndex, findIndices, zip5, zip6,
zip7, zipWith5, zipWith6, zipWith7, unzip5, unzip6, unzip6,
delete, union, lookup, intersect, insert, deleteBy,
deleteFirstBy, unionBy, intersectBy, group, groupBy, insertBy,
unionBy, intersectBy, group, groupBy, insertBy,
maximumBy, minimumBy, genericLength, genericDrop, genericTake,
genericSplitAt, genericIndex, genericReplicate, inits, tails)
@ -111,13 +113,27 @@ type LByteString = Data.ByteString.Lazy.ByteString
type LText = Data.Text.Lazy.Text
(headMay, tailMay, lastMay, initMay, maximumMay, minimumMay) =
(wrapEmpty head, wrapEmpty tail, wrapEmpty last,
wrapEmpty init, wrapEmpty maximum, wrapEmpty minimum)
where
wrapEmpty :: ([a] -> b) -> [a] -> Maybe b
wrapEmpty _ [] = Nothing
wrapEmpty f xs = Just (f xs)
headMay :: [a] -> Maybe a
headMay = wrapEmpty head
tailMay :: [a] -> Maybe [a]
tailMay = wrapEmpty tail
lastMay :: [a] -> Maybe a
lastMay = wrapEmpty last
initMay :: [a] -> Maybe [a]
initMay = wrapEmpty init
maximumMay :: Ord a => [a] -> Maybe a
maximumMay = wrapEmpty maximum
minimumMay :: Ord a => [a] -> Maybe a
minimumMay = wrapEmpty minimum
wrapEmpty :: ([a] -> b) -> [a] -> Maybe b
wrapEmpty _ [] = Nothing
wrapEmpty f xs = Just (f xs)
maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
maximumByMay _ [] = Nothing

81
main/Main.hs
View File

@ -7,17 +7,12 @@ module Main (main) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
-- Standard library imports.
import Control.Concurrent (threadDelay)
import Control.Concurrent.Chan
import Control.Arrow (second)
import Data.Aeson
import System.Directory
import System.Process (readProcess, readProcessWithExitCode)
import System.Exit (exitSuccess, ExitCode(ExitSuccess))
import Control.Exception (try, SomeException)
@ -25,7 +20,6 @@ import System.Environment (getArgs)
import System.Environment (setEnv)
import System.Posix.Signals
import qualified Data.Map as Map
import qualified Data.Text.Encoding as E
import Data.List (break, last)
import Data.Version (showVersion)
@ -35,7 +29,6 @@ import IHaskell.Eval.Completion (complete)
import IHaskell.Eval.Inspect (inspect)
import IHaskell.Eval.Evaluate
import IHaskell.Display
import IHaskell.Eval.Info
import IHaskell.Eval.Widgets (widgetHandler)
import IHaskell.Flags
import IHaskell.IPython
@ -49,31 +42,12 @@ import qualified IHaskell.IPython.Stdin as Stdin
-- Cabal imports.
import Paths_ihaskell(version)
-- GHC API imports.
#if MIN_VERSION_ghc(8,4,0)
import GHC hiding (extensions, language, convert)
#else
import GHC hiding (extensions, language)
#endif
-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
ghcVersionInts :: [Int]
ghcVersionInts = map (fromJust . readMay) . words . map dotToSpace $ VERSION_ghc
where
dotToSpace '.' = ' '
dotToSpace x = x
consoleBanner :: Text
consoleBanner =
"Welcome to IHaskell! Run `IHaskell --help` for more information.\n" <>
"Enter `:help` to learn more about IHaskell built-ins."
main :: IO ()
main = do
args <- parseFlags <$> getArgs
case args of
Left errorMessage -> hPutStrLn stderr errorMessage
Right args -> ihaskell args
Right xs -> ihaskell xs
ihaskell :: Args -> IO ()
ihaskell (Args (ShowDefault helpStr) args) = showDefault helpStr args
@ -121,16 +95,16 @@ parseKernelArgs = foldl' addFlag defaultKernelSpecOptions
kernelSpecOpts { kernelSpecInstallPrefix = Just prefix }
addFlag kernelSpecOpts KernelspecUseStack =
kernelSpecOpts { kernelSpecUseStack = True }
addFlag kernelSpecOpts flag = error $ "Unknown flag" ++ show flag
addFlag _kernelSpecOpts flag = error $ "Unknown flag" ++ show flag
-- | Run the IHaskell language kernel.
runKernel :: KernelSpecOptions -- ^ Various options from when the kernel was installed.
-> String -- ^ File with kernel profile JSON (ports, etc).
-> IO ()
runKernel kernelOpts profileSrc = do
let debug = kernelSpecDebug kernelOpts
libdir = kernelSpecGhcLibdir kernelOpts
useStack = kernelSpecUseStack kernelOpts
runKernel kOpts profileSrc = do
let debug = kernelSpecDebug kOpts
libdir = kernelSpecGhcLibdir kOpts
useStack = kernelSpecUseStack kOpts
-- Parse the profile file.
let profileErr = error $ "ihaskell: "++profileSrc++": Failed to parse profile file"
@ -170,7 +144,7 @@ runKernel kernelOpts profileSrc = do
interpret libdir True $ \hasSupportLibraries -> 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).
liftIO ignoreCtrlC
_ <- liftIO ignoreCtrlC
liftIO $ modifyMVar_ state $ \kernelState -> return $
kernelState { supportLibrariesAvailable = hasSupportLibraries }
@ -181,10 +155,10 @@ runKernel kernelOpts profileSrc = do
evaluator line = void $ do
-- Create a new state each time.
stateVar <- liftIO initialKernelState
state <- liftIO $ takeMVar stateVar
evaluate state line noPublish noWidget
st <- liftIO $ takeMVar stateVar
evaluate st line noPublish noWidget
confFile <- liftIO $ kernelSpecConfFile kernelOpts
confFile <- liftIO $ kernelSpecConfFile kOpts
case confFile of
Just filename -> liftIO (readFile filename) >>= evaluator
Nothing -> return ()
@ -285,8 +259,8 @@ replyTo _ CommInfoRequest{} replyHeader state =
-- 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
replyTo interface ShutdownRequest { restartPending = pending } replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending
exitSuccess
-- Reply to an execution request. The reply itself does not require computation, but this causes
@ -311,7 +285,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
-- re-display with the updated output.
displayed <- liftIO $ newMVar []
updateNeeded <- liftIO $ newMVar False
pagerOutput <- liftIO $ newMVar []
pOut <- liftIO $ newMVar []
let execCount = getExecutionCounter state
-- Let all frontends know the execution count and code that's about to run
@ -320,7 +294,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
-- Run code and publish to the frontend as we go.
let widgetMessageHandler = widgetHandler send replyHeader
publish = publishResult send replyHeader displayed updateNeeded pagerOutput (usePager state)
publish = publishResult send replyHeader displayed updateNeeded pOut (usePager state)
updatedState <- evaluate state (T.unpack code) publish widgetMessageHandler
-- Notify the frontend that we're done computing.
@ -329,7 +303,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
-- Take pager output if we're using the pager.
pager <- if usePager state
then liftIO $ readMVar pagerOutput
then liftIO $ readMVar pOut
else return []
return
(updatedState, ExecuteReply
@ -397,14 +371,14 @@ replyTo _ HistoryRequest{} replyHeader state = do
--
-- Sending the message only on the shell_reply channel doesn't work, so we send it as a comm message
-- on the iopub channel and return the SendNothing message.
replyTo interface open@CommOpen{} replyHeader state = do
let send msg = liftIO $ writeChan (iopubChannel interface) msg
replyTo interface ocomm@CommOpen{} replyHeader state = do
let send = liftIO . writeChan (iopubChannel interface)
incomingUuid = commUuid open
target = commTargetName open
incomingUuid = commUuid ocomm
target = commTargetName ocomm
targetMatches = target == "ipython.widget"
valueMatches = commData open == object ["widget_class" .= "ipywidgets.CommInfo"]
valueMatches = commData ocomm == object ["widget_class" .= ("ipywidgets.CommInfo" :: Text)]
commMap = openComms state
uuidTargetPairs = map (second targetName) $ Map.toList commMap
@ -413,11 +387,11 @@ replyTo interface open@CommOpen{} replyHeader state = do
currentComms = object $ map pairProcessor $ (incomingUuid, "comm") : uuidTargetPairs
replyValue = object [ "method" .= "custom"
replyValue = object [ "method" .= ("custom" :: Text)
, "content" .= object ["comms" .= currentComms]
]
msg = CommData replyHeader (commUuid open) replyValue
msg = CommData replyHeader (commUuid ocomm) replyValue
-- To the iopub channel you go
when (targetMatches && valueMatches) $ send msg
@ -435,7 +409,7 @@ handleComm send kernelState req replyHeader = do
-- MVars to hold intermediate data during publishing
displayed <- liftIO $ newMVar []
updateNeeded <- liftIO $ newMVar False
pagerOutput <- liftIO $ newMVar []
pOut <- liftIO $ newMVar []
let widgets = openComms kernelState
uuid = commUuid req
@ -449,7 +423,7 @@ handleComm send kernelState req replyHeader = do
-- a function that executes an IO action and publishes the output to
-- the frontend simultaneously.
let run = capturedIO publish kernelState
publish = publishResult send replyHeader displayed updateNeeded pagerOutput toUsePager
publish = publishResult send replyHeader displayed updateNeeded pOut toUsePager
-- Notify the frontend that the kernel is busy
busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
@ -461,14 +435,17 @@ handleComm send kernelState req replyHeader = do
case msgType $ header req of
CommDataMessage -> do
disp <- run $ comm widget dat communicate
pgrOut <- liftIO $ readMVar pagerOutput
pgrOut <- liftIO $ readMVar pOut
liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
return kernelState
CommCloseMessage -> do
disp <- run $ close widget dat
pgrOut <- liftIO $ readMVar pagerOutput
pgrOut <- liftIO $ readMVar pOut
liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
return kernelState { openComms = Map.delete uuid widgets }
_ ->
-- Only sensible thing to do.
return kernelState
-- Notify the frontend that the kernel is idle once again
idleHeader <- liftIO $ dupHeader replyHeader StatusMessage

13
src/IHaskell/BrokenPackages.hs
View File

@ -4,27 +4,22 @@ module IHaskell.BrokenPackages (getBrokenPackages) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Text.Parsec
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Shelly
data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
data BrokenPackage = BrokenPackage String [String]
instance Show BrokenPackage where
show = packageID
show (BrokenPackage packageID _) = 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.
getBrokenPackages :: IO [String]
getBrokenPackages = shelly $ do
silently $ errExit False $ run "ghc-pkg" ["check"]
_ <- silently $ errExit False $ run "ghc-pkg" ["check"]
checkOut <- lastStderr
-- Get rid of extraneous things
@ -34,7 +29,7 @@ getBrokenPackages = shelly $ do
return $
case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> []
Left _ -> []
Right pkgs -> map show pkgs
check :: Parser BrokenPackage

9
src/IHaskell/CSS.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
module IHaskell.CSS (ihaskellCSS) where
import IHaskellPrelude
@ -5,7 +6,7 @@ import IHaskellPrelude
ihaskellCSS :: String
ihaskellCSS =
unlines
[
[
-- Custom IHaskell CSS
"/* Styles used for the Hoogle display in the pager */"
, ".hoogle-doc {"
@ -42,7 +43,7 @@ ihaskellCSS =
, ".hoogle-class {"
, "font-weight: bold;"
, "}"
,
,
-- Styles used for basic displays
".get-type {"
, "color: green;"
@ -75,13 +76,13 @@ ihaskellCSS =
, ".err-msg.in.collapse {"
, "padding-top: 0.7em;"
, "}"
,
,
-- Code that will get highlighted before it is highlighted
".highlight-code {"
, "white-space: pre;"
, "font-family: monospace;"
, "}"
,
,
-- Hlint styles
".suggestion-warning { "
, "font-weight: bold;"

7
src/IHaskell/Convert.hs
View File

@ -1,14 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | Description : mostly reversible conversion between ipynb and lhs
-- | Description : mostly reversible conversion between ipynb and lhs
module IHaskell.Convert (convert) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec)

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

@ -4,18 +4,13 @@
module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower)
import Data.List (partition)
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T (pack, Text)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf)

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

@ -4,11 +4,8 @@
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Aeson (decode, Object, Value(Array, Object, String))
import Data.Vector (Vector)
@ -49,12 +46,12 @@ convCell _sty object
= s
convCell sty object
| Just (String "code") <- lookup "cell_type" object,
Just (Array i) <- lookup "source" object,
Just (Array a) <- lookup "source" object,
Just (Array o) <- lookup "outputs" object,
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o)
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) a,
o2 <- fromMaybe mempty (convOutputs sty o)
= "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o2 <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
convOutputs :: LhsStyle LT.Text

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

@ -6,13 +6,11 @@ module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import Data.Char (isSpace)
import qualified Data.Vector as V (fromList, singleton)
import qualified Data.Vector as V
import qualified Data.List as List
import IHaskell.Flags (LhsStyle(LhsStyle))
@ -97,12 +95,12 @@ boilerplate =
groupClassified :: [CellLine LText] -> [Cell [LText]]
groupClassified (CodeLine a:x)
| (c, x) <- List.span isCode x,
(_, x) <- List.span isEmptyMD x,
(o, x) <- List.span isOutput x
= Code (a : map untag c) (map untag o) : groupClassified x
| (c, x1) <- List.span isCode x,
(_, x2) <- List.span isEmptyMD x1,
(o, x3) <- List.span isOutput x2
= Code (a : map untag c) (map untag o) : groupClassified x3
groupClassified (MarkdownLine a:x)
| (m, x) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x
| (m, x1) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x1
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = []

29
src/IHaskell/Display.hs
View File

@ -42,7 +42,7 @@ module IHaskell.Display (
-- ** Image and data encoding functions
Width,
Height,
Base64(..),
Base64,
encode64,
base64,
@ -57,14 +57,10 @@ module IHaskell.Display (
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Serialize as Serialize
import qualified Data.ByteString.Base64 as Base64
import Data.Aeson (Value)
import System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM (atomically)
@ -80,28 +76,6 @@ import StringUtils (rstrip)
type Base64 = Text
-- | these instances cause the image, html etc. which look like:
--
-- > Display
-- > [Display]
-- > IO [Display]
-- > IO (IO Display)
--
-- 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 =<<)
instance IHaskellDisplay Display where
display = return
instance IHaskellDisplay DisplayData where
display disp = return $ Display [disp]
instance IHaskellDisplay a => IHaskellDisplay [a] where
display disps = do
displays <- mapM display disps
return $ ManyDisplay displays
-- | Encode many displays into a single one. All will be output.
many :: [Display] -> Display
many = ManyDisplay
@ -201,6 +175,7 @@ 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.
switchToTmpDir :: IO ()
switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))
where
switchDir =

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

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, DoAndIfThenElse, TypeFamilies, FlexibleContexts #-}
{-# LANGUAGE CPP, NoImplicitPrelude, DoAndIfThenElse, TypeFamilies, FlexibleContexts #-}
{- |
Description: Generates tab completion options.
@ -13,37 +13,21 @@ This has a limited amount of context sensitivity. It distinguishes between four
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take, lines, length)
import Data.Char
import Data.List (nub, init, last, head, elemIndex, concatMap)
import Data.List (nub, init, last, elemIndex, concatMap)
import qualified Data.List.Split as Split
import qualified Data.List.Split.Internals as Split
import Data.Maybe (fromJust)
import System.Environment (getEnv)
import GHC hiding (Qualified)
#if MIN_VERSION_ghc(8,2,0)
import GHC
import GHC.PackageDb
#else
import GHC.PackageDb (ExposedModule(exposedName))
#endif
import DynFlags
import GhcMonad
import qualified GhcMonad
import PackageConfig
import Outputable (showPpr)
import MonadUtils (MonadIO)
import System.Directory
import System.FilePath
import Control.Exception (try)
import System.Console.Haskeline.Completion
@ -69,6 +53,7 @@ exposedName :: (a, b) -> a
exposedName = fst
#endif
extName :: FlagSpec flag -> String
extName (FlagSpec { flagSpecName = name }) = name
complete :: String -> Int -> Interpreter (String, [String])
@ -100,7 +85,7 @@ complete code posOffset = do
case completion of
HsFilePath _ match -> match
FilePath _ match -> match
otherwise -> intercalate "." target
_ -> intercalate "." target
options <- case completion of
Empty -> return []
@ -108,9 +93,8 @@ complete code posOffset = do
Identifier candidate ->
return $ filter (candidate `isPrefixOf`) unqualNames
Qualified moduleName candidate -> do
trueName <- getTrueModuleName moduleName
let prefix = intercalate "." [moduleName, candidate]
Qualified mName candidate -> do
let prefix = intercalate "." [mName, candidate]
completions = filter (prefix `isPrefixOf`) qualNames
return completions
@ -122,8 +106,7 @@ complete code posOffset = do
DynFlag ext -> do
-- Possibly leave out the fLangFlags?
let kernelOptNames = concatMap getSetName kernelOpts
otherNames = ["-package", "-Wall", "-w"]
let otherNames = ["-package", "-Wall", "-w"]
fNames = map extName fFlags ++
map extName wWarningFlags ++
@ -144,33 +127,16 @@ complete code posOffset = do
xNoNames = map ("No" ++) xNames
return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames
HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"]
HsFilePath lineUpToCursor _match -> completePathWithExtensions [".hs", ".lhs"]
lineUpToCursor
FilePath lineUpToCursor match -> completePath lineUpToCursor
FilePath lineUpToCursor _match -> completePath lineUpToCursor
KernelOption str -> return $
filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
return (matchedText, options)
getTrueModuleName :: String -> Interpreter String
getTrueModuleName name = do
-- Only use the things that were actually imported
let onlyImportDecl (IIDecl decl) = Just decl
onlyImportDecl _ = Nothing
-- Get all imports that we use.
imports <- 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.
flags <- getSessionDynFlags
let qualifiedImports = filter (isJust . ideclAs) imports
hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
case find hasName qualifiedImports of
Nothing -> return name
Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
-- | Get which type of completion this is from the surrounding context.
completionType :: String -- ^ The line on which the completion is being done.
@ -230,7 +196,7 @@ completionType line loc target
else []
Left _ -> Empty
cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0
cursorInString str lcn = nquotes (take lcn str) `mod` 2 /= (0 :: Int)
nquotes ('\\':'"':xs) = nquotes xs
nquotes ('"':xs) = 1 + nquotes xs
@ -244,12 +210,12 @@ completionType line loc target
where
go acc rest =
case rest of
'"':'\\':rem -> go ('"' : acc) rem
'"':rem -> acc
' ':'\\':rem -> go (' ' : acc) rem
' ':rem -> acc
x:rem -> go (x : acc) rem
[] -> acc
'"':'\\':xs -> go ('"' : acc) xs
'"':_ -> acc
' ':'\\':xs -> go (' ' : acc) xs
' ':_ -> acc
x:xs -> go (x : acc) xs
[] -> acc
-- | Get the word under a given cursor location.
completionTarget :: String -> Int -> [String]
@ -267,7 +233,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
}
isDelim :: Char -> Int -> Bool
isDelim char idx = char `elem` neverIdent || isSymbol char
isDelim char _idx = char `elem` neverIdent || isSymbol char
splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
splitAlongCursor [] = []
@ -307,8 +273,8 @@ completePath line = completePathFilter acceptAll acceptAll line ""
acceptAll = const True
completePathWithExtensions :: [String] -> String -> Interpreter [String]
completePathWithExtensions extensions line =
completePathFilter (extensionIsOneOf extensions) acceptAll line ""
completePathWithExtensions extns line =
completePathFilter (extensionIsOneOf extns) acceptAll line ""
where
acceptAll = const True
extensionIsOneOf exts str = any correctEnding exts

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

@ -1,4 +1,4 @@
{-# LANGUAGE NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-}
{-# LANGUAGE NoOverloadedStrings, NoImplicitPrelude, TypeSynonymInstances, GADTs, CPP #-}
{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
a statement, declaration, import, or directive.
@ -19,60 +19,36 @@ module IHaskell.Eval.Evaluate (
) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent (forkIO, threadDelay)
import Data.Foldable (foldMap)
import Prelude (putChar, head, tail, last, init, (!!))
import Data.List (findIndex, and, foldl1, nubBy)
import Text.Printf
import Prelude (head, tail, last, init)
import Data.List (nubBy)
import Data.Char as Char
import Data.Dynamic
import Data.Typeable
import qualified Data.Serialize as Serialize
import System.Directory
#if !MIN_VERSION_base(4,8,0)
import System.Posix.IO (createPipe)
#endif
import System.Posix.IO (fdToHandle)
import System.IO (hGetChar, hSetEncoding, utf8, hFlush)
import System.IO (hGetChar, hSetEncoding, utf8)
import System.Random (getStdGen, randomRs)
import Unsafe.Coerce
import Control.Monad (guard)
import System.Process
import System.Exit
import Data.Maybe (fromJust)
import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO)
import qualified MonadUtils (MonadIO, liftIO)
import System.Environment (getEnv)
import qualified Data.Map as Map
import qualified GHC.Paths
import NameSet
import Name
import PprTyThing
import InteractiveEval
import DynFlags
import Type
import Exception (gtry)
import HscTypes
import HscMain
import qualified Linker
import TcType
import Unify
import InstEnv
import GhcMonad (liftIO, withSession)
import GhcMonad (liftIO)
import GHC hiding (Stmt, TypeSig)
import Exception hiding (evaluate)
import Outputable hiding ((<>))
import Packages
import Module hiding (Module)
import qualified Pretty
import FastString
import Bag
import qualified ErrUtils
@ -83,13 +59,16 @@ import IHaskell.Eval.Lint
import IHaskell.Display
import qualified IHaskell.Eval.Hoogle as Hoogle
import IHaskell.Eval.Util
import IHaskell.Eval.Widgets
import IHaskell.BrokenPackages
import qualified IHaskell.IPython.Message.UUID as UUID
import StringUtils (replace, split, strip, rstrip)
#if MIN_VERSION_ghc(8,2,0)
import FastString (unpackFS)
#else
import Paths_ihaskell (version)
import Data.Version (versionBranch)
#endif
data ErrorOccurred = Success
| Failure
@ -142,7 +121,7 @@ ihaskellGlobalImports =
-- | Interpreting function for testing.
testInterpret :: Interpreter a -> IO a
testInterpret val = interpret GHC.Paths.libdir False (const val)
testInterpret v = interpret GHC.Paths.libdir False (const v)
-- | Evaluation function for testing.
testEvaluate :: String -> IO ()
@ -203,9 +182,9 @@ initializeImports = do
-- version of the ihaskell library. Also verify that the packages we load are not broken.
dflags <- getSessionDynFlags
broken <- liftIO getBrokenPackages
(dflags, _) <- liftIO $ initPackages dflags
let db = getPackageConfigs dflags
packageNames = map (packageIdString' dflags) db
(dflgs, _) <- liftIO $ initPackages dflags
let db = getPackageConfigs dflgs
packageNames = map (packageIdString' dflgs) db
initStr = "ihaskell-"
@ -217,13 +196,6 @@ initializeImports = do
iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))
#endif
dependsOnRight pkg = not $ null $ do
pkg <- db
depId <- depends pkg
dep <- filter ((== depId) . unitId) db
let idString = packageIdString' dflags dep
guard (iHaskellPkgName `isPrefixOf` idString)
displayPkgs = [ pkgName
| pkgName <- packageNames
, Just (x:_) <- [stripPrefix initStr pkgName]
@ -234,17 +206,20 @@ initializeImports = do
-- Generate import statements all Display modules.
let capitalize :: String -> String
capitalize [] = []
capitalize (first:rest) = Char.toUpper first : rest
importFmt = "import IHaskell.Display.%s"
#if MIN_VERSION_ghc(8,2,0)
toImportStmt :: String -> String
toImportStmt = printf importFmt . concatMap capitalize . drop 1 . split "-"
#else
dropFirstAndLast :: [a] -> [a]
dropFirstAndLast = reverse . drop 1 . reverse . drop 1
toImportStmt :: String -> String
#if MIN_VERSION_ghc(8,2,0)
toImportStmt = printf importFmt . concatMap capitalize . drop 1 . split "-"
#else
toImportStmt = printf importFmt . concatMap capitalize . dropFirstAndLast . split "-"
#endif
@ -288,11 +263,11 @@ data EvalOut =
}
cleanString :: String -> String
cleanString x = if allBrackets
cleanString istr = if allBrackets
then clean
else str
else istr
where
str = strip x
str = strip istr
l = lines str
allBrackets = all (fAny [isPrefixOf ">", null]) l
fAny fs x = any ($ x) fs
@ -327,7 +302,7 @@ evaluate kernelState code output widgetHandler = do
runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
-- Print all parse errors.
errs -> do
_ -> do
forM_ errs $ \err -> do
out <- evalCommand output err kernelState
liftIO $ output $ FinalResult (evalResult out) [] []
@ -362,8 +337,7 @@ evaluate kernelState code output widgetHandler = do
Just disps -> evalResult evalOut <> disps
-- Output things only if they are non-empty.
let empty = noResults result && null (evalPager evalOut)
unless empty $
unless (noResults result && null (evalPager evalOut)) $
liftIO $ output $ FinalResult result (evalPager evalOut) []
let tempMsgs = evalMsgs evalOut
@ -408,7 +382,7 @@ flushWidgetMessages :: KernelState
-> [WidgetMsg]
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter KernelState
flushWidgetMessages state evalMsgs widgetHandler = do
flushWidgetMessages state evalmsgs widgetHandler = do
-- Capture all widget messages queued during code execution
extracted <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages"
liftIO $
@ -421,7 +395,7 @@ flushWidgetMessages state evalMsgs widgetHandler = do
messages <- messagesIO
-- Handle all the widget messages
let commMessages = evalMsgs ++ messages
let commMessages = evalmsgs ++ messages
widgetHandler state commMessages
@ -507,8 +481,8 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
-- 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
preventsLoading md =
let pieces = moduleNameOf md
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
@ -524,7 +498,7 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
Nothing -> doLoadModule modName modName
-- | Directives set via `:set`.
evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
evalCommand _output (Directive SetDynFlag flagsStr) state = safely state $ do
write state $ "All Flags: " ++ flagsStr
-- Find which flags are IHaskell flags, and which are GHC flags
@ -542,14 +516,14 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
if null flags
then do
flags <- getSessionDynFlags
flgs <- getSessionDynFlags
return
EvalOut
{ evalStatus = Success
, evalResult = Display
[ plain $ showSDoc flags $ vcat
[ pprDynFlags False flags
, pprLanguages False flags
[ plain $ showSDoc flgs $ vcat
[ pprDynFlags False flgs
, pprLanguages False flgs
]
]
, evalState = state
@ -560,7 +534,7 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ 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 =
let disp =
case errs of
[] -> mempty
_ -> displayError $ intercalate "\n" errs
@ -577,7 +551,7 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
return
EvalOut
{ evalStatus = Success
, evalResult = display
, evalResult = disp
, evalState = state'
, evalPager = []
, evalMsgs = []
@ -588,7 +562,7 @@ evalCommand output (Directive SetExtension opts) state = do
let set = concatMap (" -X" ++) $ words opts
evalCommand output (Directive SetDynFlag set) state
evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
evalCommand _output (Directive LoadModule mods) state = wrapExecution state $ do
write state $ "Load Module: " ++ mods
let stripped@(firstChar:remainder) = mods
(modules, removeModule) =
@ -603,9 +577,9 @@ evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
return mempty
evalCommand a (Directive SetOption opts) state = do
evalCommand _output (Directive SetOption opts) state = do
write state $ "Option: " ++ opts
let (existing, nonExisting) = partition optionExists $ words opts
let nonExisting = filter (not . optionExists) $ words opts
if not $ null nonExisting
then let err = "No such options: " ++ intercalate ", " nonExisting
in return
@ -655,15 +629,16 @@ evalCommand _ (Directive LoadFile names) state = wrapExecution state $ do
doLoadModule filename modName
return (ManyDisplay displays)
evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
case words cmd of
evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $
-- Assume the first character of 'cmd' is '!'.
case words $ drop 1 cmd of
"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
Left _ -> "~"
Right val -> val
Left _ -> "~"
Right v -> v
let directory = replace "~" home $ unwords dirs
exists <- liftIO $ doesDirectoryExist directory
@ -674,19 +649,19 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
liftIO $ setCurrentDirectory directory
-- Set the directory for user code.
let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
let cmd1 = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
replace " " "\\ " $
replace "\"" "\\\"" directory
execStmt cmd execOptions
_ <- execStmt cmd1 execOptions
return mempty
else return $ displayError $ printf "No such directory: '%s'" directory
cmd -> liftIO $ do
(pipe, handle) <- createPipe'
let initProcSpec = shell $ unwords cmd
cmd1 -> liftIO $ do
(pipe, hdl) <- createPipe'
let initProcSpec = shell $ unwords cmd1
procSpec = initProcSpec
{ std_in = Inherit
, std_out = UseHandle handle
, std_err = UseHandle handle
, std_out = UseHandle hdl
, std_err = UseHandle hdl
}
(_, _, _, process) <- createProcess procSpec
@ -718,8 +693,8 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
let computationDone = isJust exitCode
when computationDone $ do
nextChunk <- readChars pipe "" maxSize
modifyMVar_ outputAccum (return . (++ nextChunk))
next <- readChars pipe "" maxSize
modifyMVar_ outputAccum (return . (++ next))
if not computationDone
then do
@ -792,11 +767,11 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
strings <- unlines <$> getDescription str
-- Make pager work without html by porting to newer architecture
let htmlify str =
let htmlify str1 =
html $
concat
[ "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>"
, str
, str1
, "</textarea></form></div>"
, "<script>CodeMirror.fromTextArea(document.getElementById('code'),"
, " {mode: 'haskell', readOnly: 'nocursor'});</script>"
@ -861,8 +836,8 @@ evalCommand output (Expression expr) state = do
-- 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
_ <- write state "Suppressing display for template haskell declaration"
_ <- GHC.runDecls expr
return
EvalOut
{ evalStatus = Success
@ -914,7 +889,7 @@ evalCommand output (Expression expr) state = do
removeSvg (Display disps) = Display $ filter (not . isSvg) disps
removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps
useDisplay displayExpr = do
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
@ -930,8 +905,8 @@ evalCommand output (Expression expr) state = do
Failure -> return evalOut
Success -> wrapExecution state $ do
-- Compile the display data into a bytestring.
let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"
displayedBytestring <- dynCompileExpr compileExpr
let cexpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"
displayedBytestring <- dynCompileExpr cexpr
-- Convert from the bytestring into a display.
case fromDynamic displayedBytestring of
@ -940,30 +915,27 @@ evalCommand output (Expression expr) state = do
bytestring <- liftIO bytestringIO
case Serialize.decode bytestring of
Left err -> error err
Right display ->
Right disp ->
return $
if useSvg state
then display :: Display
else removeSvg display
then disp :: Display
else removeSvg disp
#if MIN_VERSION_ghc(8,2,0)
isIO expr = attempt $ exprType TM_Inst $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
isIO exp = attempt $ exprType TM_Inst $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp
#else
isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
isIO exp = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp
#endif
postprocessShowError :: EvalOut -> EvalOut
postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps }
where
Display disps = evalResult evalOut
text = extractPlain disps
txt = 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" txt) 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
@ -978,7 +950,7 @@ evalCommand output (Expression expr) state = do
postprocess other = other
unshowableType = fromMaybe "" $ do
let pieces = words text
let pieces = words txt
before = takeWhile (/= "arising") pieces
after = init $ unwords $ tail $ dropWhile (/= "(Show") before
@ -1025,7 +997,7 @@ evalCommand _ (ParseError loc err) state = do
, evalMsgs = []
}
evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $
evalCommand _ (Pragma (PragmaUnsupported pragmaType) _pragmas) state = wrapExecution state $
return $ displayError $ "Pragmas of type " ++ pragmaType ++ "\nare not supported."
evalCommand output (Pragma PragmaLanguage pragmas) state = do
@ -1053,10 +1025,10 @@ doLoadModule name modName = do
-- Compile loaded modules.
flags <- getSessionDynFlags
errRef <- liftIO $ newIORef []
setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo
_ <- setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo
flags
{ hscTarget = objTarget flags
, log_action = \dflags sev srcspan ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :)
, log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :)
}
-- Load the new target.
@ -1082,7 +1054,7 @@ doLoadModule name modName = do
Succeeded -> IIDecl (simpleImportDecl $ mkModuleName modName) : importedModules
-- Switch back to interpreted mode.
setSessionDynFlags flags
_ <- setSessionDynFlags flags
case result of
Succeeded -> return mempty
@ -1096,11 +1068,11 @@ doLoadModule name modName = do
print $ show exception
-- Explicitly clear targets
setTargets []
load LoadAllTargets
_ <- load LoadAllTargets
-- Switch to interpreted mode!
flags <- getSessionDynFlags
setSessionDynFlags flags { hscTarget = HscInterpreted }
_ <- setSessionDynFlags flags { hscTarget = HscInterpreted }
-- Return to old context, make sure we have `it`.
setContext imported
@ -1108,22 +1080,9 @@ doLoadModule name modName = do
return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception
objTarget :: DynFlags -> HscTarget
objTarget flags = defaultObjectTarget $ targetPlatform flags
keepingItVariable :: Interpreter a -> Interpreter a
keepingItVariable act = do
-- Generate the it variable temp name
gen <- liftIO getStdGen
let rand = take 20 $ randomRs ('0', '9') gen
var name = name ++ rand
goStmt s = execStmt s execOptions
itVariable = var "it_var_temp_"
goStmt $ printf "let %s = it" itVariable
val <- act
goStmt $ printf "let it = %s" itVariable
act
data Captured a = CapturedStmt String
| CapturedIO (IO a)
@ -1175,23 +1134,23 @@ capturedEval output stmt = do
runWithResult (CapturedStmt str) = goStmt str
runWithResult (CapturedIO io) = do
status <- gcatch (liftIO io >> return NoException) (return . AnyException)
stat <- gcatch (liftIO io >> return NoException) (return . AnyException)
return $
case status of
case stat of
NoException -> ExecComplete (Right []) 0
AnyException e -> ExecComplete (Left e) 0
-- Initialize evaluation context.
results <- forM initStmts goStmt
forM_ initStmts goStmt
-- This works fine on GHC 8.0 and newer
dyn <- dynCompileExpr readVariable
pipe <- case fromDynamic dyn of
Nothing -> fail "Evaluate: Bad pipe"
Just fd -> liftIO $ do
handle <- fdToHandle fd
hSetEncoding handle utf8
return handle
hdl <- fdToHandle fd
hSetEncoding hdl utf8
return hdl
-- Keep track of whether execution has completed.
completed <- liftIO $ newMVar False
@ -1205,9 +1164,6 @@ capturedEval output stmt = do
ms = 1000
delay = 100 * ms
-- How much to read each time.
chunkSize = 100
-- Maximum size of the output (after which we truncate).
maxSize = 100 * 1000
@ -1233,7 +1189,7 @@ capturedEval output stmt = do
-- We're done reading.
putMVar finishedReading True
liftIO $ forkIO loop
_ <- liftIO $ forkIO loop
result <- gfinally (runWithResult stmt) $ do
-- Execution is done.
@ -1267,7 +1223,7 @@ evalStatementOrIO publish state cmd = do
case cmd of
CapturedStmt stmt ->
write state $ "Statement:\n" ++ stmt
CapturedIO io ->
CapturedIO _ ->
write state "Evaluating Action"
(printed, result) <- capturedEval output cmd
@ -1280,14 +1236,14 @@ evalStatementOrIO publish state cmd = do
name == "it" ||
name == "it" ++ show (getExecutionCounter state)
nonItNames = filter (not . isItName) allNames
output = [ plain printed
oput = [ plain printed
| not . null $ strip printed ]
write state $ "Names: " ++ show allNames
-- 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
then return $ Display oput
else do
-- Get all the type strings.
types <- forM nonItNames $ \name -> do
@ -1302,11 +1258,11 @@ evalStatementOrIO publish state cmd = do
htmled = unlines $ map formatGetType types
return $
case extractPlain output of
case extractPlain oput 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]
txt -> Display [plain $ joined ++ "\n" ++ txt, html $ htmled ++ mono txt]
ExecComplete (Left exception) _ -> throw exception
ExecBreak{} -> error "Should not break."
@ -1314,20 +1270,20 @@ evalStatementOrIO publish state cmd = do
-- 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
readChars handle delims 0 =
readChars _handle _delims 0 =
-- If we're done reading, return nothing.
return []
readChars handle delims nchars = do
readChars hdl delims nchars = do
-- Try reading a single character. It will throw an exception if the handle is already closed.
tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
tryRead <- gtry $ hGetChar hdl :: IO (Either SomeException Char)
case tryRead of
Right char ->
Right ch ->
-- If this is a delimiter, stop reading.
if char `elem` delims
then return [char]
if ch `elem` delims
then return [ch]
else do
next <- readChars handle delims (nchars - 1)
return $ char : next
next <- readChars hdl delims (nchars - 1)
return $ ch : next
-- An error occurs at the end of the stream, so just stop reading.
Left _ -> return []
@ -1350,13 +1306,10 @@ formatErrorWithClass cls =
where
fixDollarSigns = replace "$" "<span>&dollar;</span>"
useDashV = "\n Use -v to see a list of the files searched for."
isShowError err =
"No instance for (Show" `isPrefixOf` err &&
isInfixOf " arising from a use of `print'" err
formatParseError :: StringLoc -> String -> ErrMsg
formatParseError (Loc line col) =
printf "Parse error (line %d, column %d): %s" line col
formatParseError (Loc ln col) =
printf "Parse error (line %d, column %d): %s" ln col
formatGetType :: String -> String
formatGetType = printf "<span class='get-type'>%s</span>"

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

@ -9,9 +9,6 @@ module IHaskell.Eval.Hoogle (
) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
@ -21,8 +18,6 @@ import Data.Aeson
import qualified Data.List as List
import Data.Char (isAscii, isAlphaNum)
import IHaskell.IPython
import StringUtils (split, strip, replace)
-- | Types of formats to render output to.
@ -97,8 +92,8 @@ search string = do
return $
case response of
Left err -> [NoResult err]
Right json ->
case eitherDecode $ LBS.fromStrict $ CBS.pack json of
Right jsn ->
case eitherDecode $ LBS.fromStrict $ CBS.pack jsn of
Left err -> [NoResult err]
Right results ->
case map SearchResult $ (\(HoogleResponseList l) -> l) results of
@ -110,9 +105,8 @@ search string = do
document :: String -> IO [HoogleResult]
document string = do
matchingResults <- filter matches <$> search string
let results = map toDocResult matchingResults
return $
case results of
case mapMaybe toDocResult matchingResults of
[] -> [NoResult "no matching identifiers found."]
res -> res
@ -123,7 +117,9 @@ document string = do
_ -> False
matches _ = False
toDocResult (SearchResult resp) = DocResult resp
toDocResult (SearchResult resp) = Just $ DocResult resp
toDocResult (DocResult _) = Nothing
toDocResult (NoResult _) = Nothing
-- | Render a Hoogle search result into an output format.
render :: OutputFormat -> HoogleResult -> String
@ -163,7 +159,7 @@ renderSelf string loc
| "module" `isPrefixOf` string =
let package = extractPackageName loc
in mod ++ " " ++
in mdl ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++
packageSub package
@ -202,7 +198,7 @@ renderSelf string loc
extractData = strip . replace "data" ""
extractNewtype = strip . replace "newtype" ""
pkg = span "hoogle-head" "package"
mod = span "hoogle-head" "module"
mdl = span "hoogle-head" "module"
cls = span "hoogle-head" "class"
dat = span "hoogle-head" "data"
nwt = span "hoogle-head" "newtype"
@ -224,7 +220,7 @@ renderSelf string loc
packageAndModuleSub (Just package) (Just modname) =
span "hoogle-sub" $
"(" ++ pkg ++ " " ++ span "hoogle-package" package ++
", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"
", " ++ mdl ++ " " ++ span "hoogle-module" modname ++ ")"
renderDocs :: String -> String
renderDocs doc =
@ -233,28 +229,30 @@ renderDocs doc =
bothAreCode s1 s2 =
isPrefixOf ">" (strip s1) &&
isPrefixOf ">" (strip s2)
isCode (s:_) = isPrefixOf ">" $ strip s
makeBlock lines =
if isCode lines
then div' "hoogle-code" $ unlines $ nonull lines
else div' "hoogle-text" $ unlines $ nonull lines
isCode xs =
case xs of
[] -> False
(s:_) -> isPrefixOf ">" $ strip s
makeBlock xs =
if isCode xs
then div' "hoogle-code" $ unlines $ nonull xs
else div' "hoogle-text" $ unlines $ nonull xs
in div' "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String
extractPackageName link = do
let pieces = split "/" link
extractPackageName lnk = do
let pieces = split "/" lnk
archiveLoc <- List.elemIndex "archive" pieces
latestLoc <- List.elemIndex "latest" pieces
guard $ latestLoc - archiveLoc == 2
return $ pieces List.!! (latestLoc - 1)
extractModuleName :: String -> Maybe String
extractModuleName link = do
let pieces = split "/" link
extractModuleName lnk = do
let pieces = split "/" lnk
guard $ not $ null pieces
let html = fromJust $ lastMay pieces
mod = replace "-" "." $ takeWhile (/= '.') html
return mod
return $ replace "-" "." $ takeWhile (/= '.') html
div' :: String -> String -> String
div' = printf "<div class='%s'>%s</div>"

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

@ -4,11 +4,6 @@
module IHaskell.Eval.Info (info) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)

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

@ -7,11 +7,6 @@ Description: Generates inspections when asked for by the frontend.
module IHaskell.Eval.Inspect (inspect) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import qualified Prelude as P
@ -22,7 +17,6 @@ import Exception (ghandle)
import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Display
import IHaskell.Eval.Util (getType)
import IHaskell.Types
-- | Characters used in Haskell operators.
operatorChars :: String
@ -34,7 +28,7 @@ whitespace = " \t\n"
-- | Compute the identifier that is being queried.
getIdentifier :: String -> Int -> String
getIdentifier code pos = identifier
getIdentifier code _pos = identifier
where
chunks = splitOn whitespace code
lastChunk = P.last chunks :: String

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

@ -3,33 +3,21 @@
module IHaskell.Eval.Lint (lint) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Prelude (head, tail, last)
import Control.Monad
import Data.List (findIndex)
import Data.Char
import Data.Monoid
import Prelude (last)
import Data.Maybe (mapMaybe)
import System.IO.Unsafe (unsafePerformIO)
import Language.Haskell.Exts.Syntax hiding (Module)
import qualified Language.Haskell.Exts.Syntax as SrcExts
import Language.Haskell.Exts (parseFileContentsWithMode)
import Language.Haskell.Exts.Build (doE)
import Language.Haskell.Exts hiding (Module)
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.HLint as HLint
import Language.Haskell.HLint3
import IHaskell.Types
import IHaskell.Display
import IHaskell.IPython
import IHaskell.Eval.Parser hiding (line)
import StringUtils (replace)
@ -65,10 +53,9 @@ lint blocks = do
-- Get hlint settings
(flags, classify, hint) <- readMVar hlintSettings
let mode = hseFlags flags
-- create 'suggestions'
let modules = mapMaybe (createModule mode) blocks
let modules = mapMaybe (createModule (hseFlags flags)) blocks
ideas = applyHints classify hint (map (\m -> (m, [])) modules)
suggestions = mapMaybe showIdea $ filter (not . ignoredIdea) ideas
@ -78,33 +65,33 @@ lint blocks = do
else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
where
autoSettings' = do
(fixities, classify, hints) <- autoSettings
(fixts, classify, hints) <- autoSettings
let hidingIgnore = Classify Ignore "Unnecessary hiding" "" ""
return (fixities, hidingIgnore:classify, hints)
return (fixts, hidingIgnore:classify, hints)
ignoredIdea idea = ideaSeverity idea == Ignore
showIdea :: Idea -> Maybe LintSuggestion
showIdea idea =
case ideaTo idea of
Nothing -> Nothing
Just whyNot ->
Just wn ->
Just
Suggest
{ line = srcSpanStartLine $ ideaSpan idea
, found = showSuggestion $ ideaFrom idea
, whyNot = showSuggestion whyNot
, whyNot = showSuggestion wn
, severity = ideaSeverity idea
, suggestion = ideaHint idea
}
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
createModule mode (Located line block) =
createModule md (Located ln block) =
case block of
Expression expr -> unparse $ exprToModule expr
Declaration decl -> unparse $ declToModule decl
Statement stmt -> unparse $ stmtToModule stmt
Import impt -> unparse $ imptToModule impt
Module mod -> unparse $ parseModule mod
Module mdl -> unparse $ pModule mdl
_ -> Nothing
where
blockStr =
@ -113,7 +100,10 @@ createModule mode (Located line block) =
Declaration decl -> decl
Statement stmt -> stmt
Import impt -> impt
Module mod -> mod
Module mdl -> mdl
-- TODO: Properly handle the other constructors
_ -> []
unparse :: ParseResult a -> Maybe a
unparse (ParseOk a) = Just a
@ -122,49 +112,47 @@ createModule mode (Located line block) =
srcSpan :: SrcSpan
srcSpan = SrcSpan
{ srcSpanFilename = "<interactive>"
, srcSpanStartLine = line
, srcSpanStartLine = ln
, srcSpanStartColumn = 0
, srcSpanEndLine = line + length (lines blockStr)
, srcSpanEndLine = ln + length (lines blockStr)
, srcSpanEndColumn = length $ last $ lines blockStr
}
loc :: SrcSpanInfo
loc = SrcSpanInfo srcSpan []
lcn :: SrcSpanInfo
lcn = SrcSpanInfo srcSpan []
moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]
moduleWithDecls decl = SrcExts.Module lcn Nothing [] [] [decl]
parseModule :: String -> ParseResult ExtsModule
parseModule = parseFileContentsWithMode mode
pModule :: String -> ParseResult ExtsModule
pModule = parseFileContentsWithMode md
declToModule :: String -> ParseResult ExtsModule
declToModule decl = moduleWithDecls <$> parseDeclWithMode mode decl
declToModule decl = moduleWithDecls <$> parseDeclWithMode md decl
exprToModule :: String -> ParseResult ExtsModule
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
exprToModule exp = moduleWithDecls <$> SpliceDecl lcn <$> parseExpWithMode md exp
stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr =
case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod
case parseStmtWithMode md stmtStr of
ParseOk _ -> ParseOk $ moduleWithDecls decl
ParseFailed a b -> ParseFailed a b
where
mod = moduleWithDecls decl
decl :: Decl SrcSpanInfo
decl = SpliceDecl loc expr
decl = SpliceDecl lcn expr
expr :: Exp SrcSpanInfo
expr = Do loc [stmt, ret]
expr = Do lcn [stmt, ret]
stmt :: Stmt SrcSpanInfo
ParseOk stmt = parseStmtWithMode mode stmtStr
ParseOk stmt = parseStmtWithMode md stmtStr
ret :: Stmt SrcSpanInfo
ParseOk ret = Qualifier loc <$> parseExp lintIdent
ParseOk ret = Qualifier lcn <$> parseExp lintIdent
imptToModule :: String -> ParseResult ExtsModule
imptToModule = parseFileContentsWithMode mode
imptToModule = parseFileContentsWithMode md
plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest =
@ -177,10 +165,10 @@ htmlSuggestions = concatMap toHtml
toHtml :: LintSuggestion -> String
toHtml suggest = concat
[ named $ suggestion suggest
, floating "left" $ style severityClass "Found:" ++
, floating "left" $ styl severityClass "Found:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (found suggest)
, floating "left" $ style severityClass "Why Not:" ++
, floating "left" $ styl severityClass "Why Not:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (whyNot suggest)
]
@ -193,8 +181,8 @@ htmlSuggestions = concatMap toHtml
-- Should not occur
_ -> "warning"
style :: String -> String -> String
style = printf "<div class=\"suggestion-%s\">%s</div>"
styl :: String -> String -> String
styl = printf "<div class=\"suggestion-%s\">%s</div>"
named :: String -> String
named = printf "<div class=\"suggestion-name\" style=\"clear:both;\">%s</div>"

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

@ -5,11 +5,6 @@
module IHaskell.Eval.ParseShell (parseShell) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Text.ParserCombinators.Parsec
@ -28,6 +23,7 @@ manyTillEnd p end = scan
xs <- scan
return $ x : xs
manyTillEnd1 :: Parser a -> Parser [a] -> Parser [a]
manyTillEnd1 p end = do
x <- p
xs <- manyTillEnd p end
@ -36,18 +32,21 @@ manyTillEnd1 p end = do
unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do
x <- noneOf "\\"
lookAhead p
_ <- lookAhead p
return [x]
quotedString :: Parser [Char]
quotedString = do
quote <?> "expected starting quote"
_ <- quote <?> "expected starting quote"
(manyTillEnd anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString :: Parser [Char]
unquotedString = manyTillEnd1 anyChar end
where
end = unescapedChar space
<|> (lookAhead eol >> return [])
word :: Parser [Char]
word = quotedString <|> unquotedString <?> "word"
separator :: Parser String
@ -57,11 +56,11 @@ separator = many1 space <?> "separator"
shellWords :: Parser [String]
shellWords = try (eof *> return []) <|> do
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
_rest1 <- lookAhead (many anyToken)
_ss <- separator
_rest2 <- lookAhead (many anyToken)
xs <- shellWords
return $ x : xs
parseShell :: String -> Either ParseError [String]
parseShell string = parse shellWords "shell" (string ++ "\n")
parseShell str = parse shellWords "shell" (str ++ "\n")

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

@ -16,11 +16,6 @@ module IHaskell.Eval.Parser (
) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Char (toLower)
import Data.List (maximumBy, inits)
@ -83,8 +78,8 @@ 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 mdl
| Just _ <- hsmodName (unLoc mdl) -> return [Located 1 $ Module codeString]
_ -> do
-- Split input into chunks based on indentation.
let chunks = layoutChunks $ removeComments codeString
@ -97,12 +92,12 @@ parseString codeString = do
where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$> handleChunk chunk line
parseChunk chunk ln = Located ln <$> handleChunk
where
handleChunk chunk line
| isDirective chunk = return $ parseDirective chunk line
| isPragma chunk = return $ parsePragma chunk line
| otherwise = parseCodeChunk chunk line
handleChunk
| isDirective chunk = return $ parseDirective chunk ln
| isPragma chunk = return $ parsePragma chunk ln
| otherwise = parseCodeChunk chunk ln
processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock]
processChunks accum remaining =
@ -111,10 +106,10 @@ parseString codeString = do
[] -> return $ reverse accum
-- If we have more remaining, parse the current chunk and recurse.
Located line chunk:remaining -> do
block <- parseChunk chunk line
Located ln chunk:remain -> do
block <- parseChunk chunk ln
activateExtensions $ unloc block
processChunks (block : accum) remaining
processChunks (block : accum) remain
-- Test whether a given chunk is a directive.
isDirective :: String -> Bool
@ -130,11 +125,11 @@ activateExtensions (Directive SetDynFlag flags) =
case stripPrefix "-X" flags of
Just ext -> void $ setExtension ext
Nothing -> return ()
activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions
activateExtensions (Pragma PragmaLanguage exts) = void $ setAll exts
where
setAll :: GhcMonad m => [String] -> m (Maybe String)
setAll exts = do
errs <- mapM setExtension exts
setAll exts' = do
errs <- mapM setExtension exts'
return $ msum errs
activateExtensions _ = return ()
@ -142,7 +137,7 @@ activateExtensions _ = return ()
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk code startLine = do
flags <- getSessionDynFlags
let
let
-- Try each parser in turn.
rawResults = map (tryParser code) (parsers flags)
@ -164,13 +159,13 @@ parseCodeChunk code startLine = do
failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)]
failures [] = []
failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest
failures (Failure msg (Loc ln col):rest) = (msg, ln, col) : failures rest
failures (_:rest) = failures rest
bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock
bestError errors = ParseError (Loc (line + startLine - 1) col) msg
bestError errors = ParseError (Loc (ln + startLine - 1) col) msg
where
(msg, line, col) = maximumBy compareLoc errors
(msg, ln, col) = maximumBy compareLoc errors
compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2
statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
@ -189,11 +184,11 @@ parseCodeChunk code startLine = do
_ -> False
tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
tryParser string (blockType, parser) =
case parser string of
tryParser string (blockType, psr) =
case psr string of
Parsed res -> Parsed (blockType res)
Failure err loc -> Failure err loc
otherwise -> error "tryParser failed, output was neither Parsed nor Failure"
_ -> error "tryParser failed, output was neither Parsed nor Failure"
parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]
parsers flags =
@ -204,10 +199,10 @@ parseCodeChunk code startLine = do
]
where
unparser :: Parser a -> String -> ParseOutput String
unparser parser code =
case runParser flags parser code of
Parsed out -> Parsed code
Partial out strs -> Partial code strs
unparser psr cd =
case runParser flags psr cd of
Parsed _ -> Parsed cd
Partial _ strs -> Partial cd strs
Failure err loc -> Failure err loc
-- | Find consecutive declarations of the same function and join them into a single declaration.
@ -239,11 +234,11 @@ joinFunctions blocks =
parsePragma :: String -- ^ Pragma string.
-> Int -- ^ Line number at which the directive appears.
-> CodeBlock -- ^ Pragma code block or a parse error.
parsePragma ('{':'-':'#':pragma) line =
parsePragma pragma _ln =
let commaToSpace :: Char -> Char
commaToSpace ',' = ' '
commaToSpace x = x
pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma
pragmas = words $ takeWhile (/= '#') $ map commaToSpace $ drop 3 pragma
in case pragmas of
--empty string pragmas are unsupported
[] -> Pragma (PragmaUnsupported "") []
@ -256,8 +251,8 @@ parsePragma ('{':'-':'#':pragma) line =
parseDirective :: String -- ^ Directive string.
-> Int -- ^ Line number at which the directive appears.
-> CodeBlock -- ^ Directive code block or a parse error.
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!' : directive
parseDirective (':':directive) line =
parseDirective (':':'!':directive) _ln = Directive ShellCmd $ '!' : directive
parseDirective (':':directive) ln =
case find rightDirective directives of
Just (directiveType, _) -> Directive directiveType arg
where arg = unwords restLine
@ -267,7 +262,7 @@ parseDirective (':':directive) line =
case words directive of
[] -> ""
first:_ -> first
in ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
in ParseError (Loc ln 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
where
rightDirective (_, dirname) =
case words directive of
@ -298,8 +293,8 @@ getModuleName moduleSrc = do
let output = runParser flags parserModule moduleSrc
case output of
Failure{} -> error "Module parsing failed."
Parsed mod ->
case unLoc <$> hsmodName (unLoc mod) of
Parsed mdl ->
case unLoc <$> hsmodName (unLoc mdl) of
Nothing -> error "Module must have a name."
Just name -> return $ split "." $ moduleNameString name
otherwise -> error "getModuleName failed, output was neither Parsed nor Failure"
_ -> error "getModuleName failed, output was neither Parsed nor Failure"

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

@ -27,10 +27,6 @@ module IHaskell.Eval.Util (
) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
-- GHC imports.
@ -38,18 +34,12 @@ import DynFlags
import FastString
import GHC
import GhcMonad
import HsImpExp
import HscTypes
import InteractiveEval
import Module
import Packages
import RdrName
import NameSet
import Name
import PprTyThing
import InstEnv (ClsInst(..))
import Unify (tcMatchTys)
import VarSet (mkVarSet)
import qualified Pretty
import qualified Outputable as O
@ -85,10 +75,10 @@ extensionFlag ext =
Nothing -> Nothing
where
-- Check if a FlagSpec matches an extension name.
flagMatches ext fs = ext == flagSpecName fs
flagMatches ex fs = ex == flagSpecName fs
-- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs
flagMatchesNo ex fs = ex == "No" ++ flagSpecName fs
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
pprDynFlags :: Bool -- ^ Whether to include flags which are on by default
@ -101,11 +91,11 @@ pprDynFlags show_all dflags =
, O.text "other dynamic, non-language, flag settings:" O.$$
O.nest 2 (O.vcat (map (setting opt) others))
, O.text "warning settings:" O.$$
O.nest 2 (O.vcat (map (setting wopt) warningFlags))
O.nest 2 (O.vcat (map (setting wopt) wFlags))
]
where
warningFlags = DynFlags.wWarningFlags
wFlags = DynFlags.wWarningFlags
opt = gopt
@ -139,6 +129,7 @@ pprDynFlags show_all dflags =
flgs1 = [Opt_PrintExplicitForalls]
flgs2 = [Opt_PrintExplicitKinds]
flgs3 :: [GeneralFlag]
flgs3 = [Opt_PrintBindResult, Opt_BreakOnException, Opt_BreakOnError, Opt_PrintEvldWithShow]
-- | Pretty-print the base language and active options (taken from `InteractiveUI` module of
@ -189,7 +180,7 @@ setExtension ext = do
case extensionFlag ext of
Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
Just flag -> do
setSessionDynFlags $
_ <- setSessionDynFlags $
case flag of
SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
@ -204,9 +195,8 @@ setFlags ext = do
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
-- First, try to check if this flag matches any extension name.
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags }
GHC.setProgramDynFlags restoredPkgs
_ <- GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
-- Create the parse errors.
@ -246,6 +236,7 @@ doc sdoc = do
string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
string_txt (Pretty.ZStr s1) s2 = CBS.unpack (fastZStringToByteString s1) ++ s2
#endif
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn
@ -345,15 +336,14 @@ evalImport imports = do
_ -> False
removeImport :: GhcMonad m => String -> m ()
removeImport moduleName = do
flags <- getSessionDynFlags
removeImport modName = do
ctx <- getContext
let ctx' = filter (not . (isImportOf $ mkModuleName moduleName)) ctx
let ctx' = filter (not . (isImportOf $ mkModuleName modName)) ctx
setContext ctx'
where
isImportOf :: ModuleName -> InteractiveImport -> Bool
isImportOf name (IIModule modName) = name == modName
isImportOf name (IIModule mName) = name == mName
isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl)
-- | Evaluate a series of declarations. Return all names which were bound by these declarations.
@ -376,10 +366,8 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
where
instEq :: ClsInst -> ClsInst -> Bool
-- Only support replacing instances on GHC 7.8 and up
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
= cls == cls' && isJust (tcMatchTys tpl_tys tpl_tys')
instEq c1 c2 =
is_cls c1 == is_cls c2 && isJust (tcMatchTys (is_tys c1) (is_tys c2))
-- | Get the type of an expression and convert it to a string.
@ -408,9 +396,9 @@ getDescription str = do
-- Filter out types that have parents in the same set. GHCi also does this.
let infos = catMaybes maybeInfos
allNames = mkNameSet $ map (getName . getType) infos
allNames = mkNameSet $ map (getName . getInfoType) infos
hasParent info =
case tyThingParent_maybe (getType info) of
case tyThingParent_maybe (getInfoType info) of
Just parent -> getName parent `elemNameSet` allNames
Nothing -> False
filteredOutput = filter (not . hasParent) infos
@ -423,9 +411,9 @@ getDescription str = do
getInfo' = getInfo False
#if MIN_VERSION_ghc(8,4,0)
getType (theType, _, _, _, _) = theType
getInfoType (theType, _, _, _, _) = theType
#else
getType (theType, _, _, _) = theType
getInfoType (theType, _, _, _) = theType
#endif
#if MIN_VERSION_ghc(8,4,0)

35
src/IHaskell/Eval/Widgets.hs
View File

@ -14,7 +14,6 @@ module IHaskell.Eval.Widgets (
import IHaskellPrelude
import Control.Concurrent.Chan (writeChan)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TChan
import Control.Monad (foldM)
@ -25,8 +24,6 @@ import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Display
import IHaskell.Eval.Util (unfoldM)
import IHaskell.IPython.Types (showMessageType)
import IHaskell.IPython.Message.UUID
import IHaskell.IPython.Message.Writer
import IHaskell.Types
-- All comm_open messages go here
@ -50,7 +47,7 @@ queue = atomically . writeTChan widgetMessages
widgetSend :: IHaskellWidget a
=> (Widget -> Value -> WidgetMsg)
-> a -> Value -> IO ()
widgetSend msgType widget value = queue $ msgType (Widget widget) value
widgetSend mtype widget value = queue $ mtype (Widget widget) value
-- | Send a message to open a comm
widgetSendOpen :: IHaskellWidget a => a -> Value -> IO ()
@ -82,7 +79,7 @@ widgetPublishDisplay widget disp = display disp >>= queue . DispMsg (Widget widg
-- | Send a `clear_output` message as a [method .= custom] message
widgetClearOutput :: IHaskellWidget a => a -> Bool -> IO ()
widgetClearOutput widget wait = queue $ ClrOutput (Widget widget) wait
widgetClearOutput widget w = queue $ ClrOutput (Widget widget) w
-- | Handle a single widget message. Takes necessary actions according to the message type, such as
-- opening comms, storing and updating widget representation in the kernel state etc.
@ -111,8 +108,8 @@ handleMessage send replyHeader state msg = do
then return state
else do
-- Send the comm open, with the initial state
header <- dupHeader replyHeader CommOpenMessage
send $ CommOpen header target_name target_module uuid value
hdr <- dupHeader replyHeader CommOpenMessage
send $ CommOpen hdr target_name target_module uuid value
-- Send anything else the widget requires.
open widget communicate
@ -130,8 +127,8 @@ handleMessage send replyHeader state msg = do
-- If the widget is not present in the state, we don't close it.
if present
then do
header <- dupHeader replyHeader CommCloseMessage
send $ CommClose header uuid value
hdr <- dupHeader replyHeader CommCloseMessage
send $ CommClose hdr uuid value
return newState
else return state
@ -148,9 +145,9 @@ handleMessage send replyHeader state msg = do
let dmsg = WidgetDisplay dispHeader $ unwrap disp
sendMessage widget (toJSON $ CustomContent $ toJSON dmsg)
ClrOutput widget wait -> do
header <- dupHeader replyHeader ClearOutputMessage
let cmsg = WidgetClear header wait
ClrOutput widget w -> do
hdr <- dupHeader replyHeader ClearOutputMessage
let cmsg = WidgetClear hdr w
sendMessage widget (toJSON $ CustomContent $ toJSON cmsg)
where
@ -161,8 +158,8 @@ handleMessage send replyHeader state msg = do
-- If the widget is present, we send an update message on its comm.
when present $ do
header <- dupHeader replyHeader CommDataMessage
send $ CommData header uuid value
hdr <- dupHeader replyHeader CommDataMessage
send $ CommData hdr uuid value
return state
unwrap :: Display -> [DisplayData]
@ -181,20 +178,20 @@ instance ToJSON WidgetDisplay where
data WidgetClear = WidgetClear MessageHeader Bool
instance ToJSON WidgetClear where
toJSON (WidgetClear replyHeader wait) =
let clrVal = toJSON $ ClearOutput replyHeader wait
toJSON (WidgetClear replyHeader w) =
let clrVal = toJSON $ ClearOutput replyHeader w
in toJSON $ IPythonMessage replyHeader clrVal ClearOutputMessage
data IPythonMessage = IPythonMessage MessageHeader Value MessageType
instance ToJSON IPythonMessage where
toJSON (IPythonMessage replyHeader val msgType) =
toJSON (IPythonMessage replyHeader val mtype) =
object
[ "header" .= replyHeader
, "parent_header" .= str ""
, "metadata" .= str "{}"
, "content" .= val
, "msg_type" .= (toJSON . showMessageType $ msgType)
, "msg_type" .= (toJSON . showMessageType $ mtype)
]
str :: String -> String
@ -206,4 +203,4 @@ widgetHandler :: (Message -> IO ())
-> KernelState
-> [WidgetMsg]
-> IO KernelState
widgetHandler sender header = foldM (handleMessage sender header)
widgetHandler sender hdr = foldM (handleMessage sender hdr)

42
src/IHaskell/Flags.hs
View File

@ -14,22 +14,17 @@ module IHaskell.Flags (
import IHaskellPrelude hiding (Arg(..))
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import Data.List (findIndex)
import IHaskell.Types
-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
data Args = Args IHaskellMode [Argument]
deriving Show
data Argument = ConfFile String -- ^ A file with commands to load at startup.
| OverwriteFiles -- ^ Present when output should overwrite existing files.
| OverwriteFiles -- ^ Present when output should overwrite existing files.
| GhcLibDir String -- ^ Where to find the GHC libraries.
| RTSFlags [String] -- ^ Options for the GHC runtime (e.g. heap-size limit
-- or number of threads).
@ -70,7 +65,7 @@ data IHaskellMode = ShowDefault String
-- | 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
let modeIndex = findIndex (`elem` modeFlgs) flags
in case modeIndex of
Nothing ->
-- Treat no mode as 'console'.
@ -82,18 +77,19 @@ parseFlags flags =
let (start, first:end) = splitAt idx flags
in process ihaskellArgs $ first : start ++ end
where
modeFlags = concatMap modeNames allModes
modeFlgs = concatMap modeNames allModes
allModes :: [Mode Args]
allModes = [installKernelSpec, kernel, convert]
-- | Get help text for a given IHaskell ode.
help :: IHaskellMode -> String
help mode = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode mode
help md = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode md
where
chooseMode InstallKernelSpec = installKernelSpec
chooseMode (Kernel _) = kernel
chooseMode ConvertLhs = convert
chooseMode (ShowDefault _) = error "IHaskell.Flags.help: Should never happen."
ghcLibFlag :: Flag Args
ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "<path>" "Library directory for GHC."
@ -101,8 +97,8 @@ ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "<path>" "Library directo
ghcRTSFlag :: Flag Args
ghcRTSFlag = flagReq ["use-rtsopts"] storeRTS "\"<flags>\""
"Runtime options (multithreading etc.). See `ghc +RTS -?`."
where storeRTS allRTSFlags (Args mode prev)
= fmap (Args mode . (:prev) . RTSFlags)
where storeRTS allRTSFlags (Args md prev)
= fmap (Args md . (:prev) . RTSFlags)
. parseRTS . words $ filter (/='"') allRTSFlags
parseRTS ("+RTS":fs) -- Ignore if this is included (we already wrap
= parseRTS fs -- the ihaskell-kernel call in +RTS <flags> -RTS anyway)
@ -115,13 +111,13 @@ ghcRTSFlag = flagReq ["use-rtsopts"] storeRTS "\"<flags>\""
kernelDebugFlag :: Flag Args
kernelDebugFlag = flagNone ["debug"] addDebug "Print debugging output from the kernel."
where
addDebug (Args mode prev) = Args mode (KernelDebug : prev)
addDebug (Args md prev) = Args md (KernelDebug : prev)
kernelStackFlag :: Flag Args
kernelStackFlag = flagNone ["stack"] addStack
"Inherit environment from `stack` when it is installed"
where
addStack (Args mode prev) = Args mode (KernelspecUseStack : prev)
addStack (Args md prev) = Args md (KernelspecUseStack : prev)
confFlag :: Flag Args
confFlag = flagReq ["conf", "c"] (store ConfFile) "<rc.hs>"
@ -131,12 +127,14 @@ installPrefixFlag :: Flag Args
installPrefixFlag = flagReq ["prefix"] (store KernelspecInstallPrefix) "<install-dir>"
"Installation prefix for kernelspec (see Jupyter's --prefix option)"
helpFlag :: Flag Args
helpFlag = flagHelpSimple (add Help)
add flag (Args mode flags) = Args mode $ flag : flags
add :: Argument -> Args -> Args
add flag (Args md flags) = Args md $ flag : flags
store :: (String -> Argument) -> String -> Args -> Either String Args
store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev
store constructor str (Args md prev) = Right $ Args md $ constructor str : prev
installKernelSpec :: Mode Args
installKernelSpec =
@ -168,14 +166,14 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
, helpFlag
]
consForce (Args mode prev) = Args mode (OverwriteFiles : prev)
consForce (Args md prev) = Args md (OverwriteFiles : prev)
unnamedArg = Arg (store ConvertFrom) "<file>" False
consStyle style (Args mode prev) = Args mode (ConvertLhsStyle style : prev)
consStyle style (Args md prev) = Args md (ConvertLhsStyle style : prev)
storeFormat constructor str (Args mode prev) =
storeFormat constructor str (Args md prev) =
case T.toLower (T.pack str) of
"lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev
"ipynb" -> Right $ Args mode $ constructor IpynbFile : prev
"lhs" -> Right $ Args md $ constructor LhsMarkdown : prev
"ipynb" -> Right $ Args md $ constructor IpynbFile : prev
_ -> Left $ "Unknown format requested: " ++ str
storeLhs str previousArgs =
@ -196,13 +194,11 @@ ihaskellArgs =
let noMode = mode "IHaskell" defaultReport descr noArgs [helpFlag, versionFlag]
defaultReport = Args (ShowDefault helpStr) []
descr = "Haskell for Interactive Computing."
helpFlag = flagHelpSimple (add Help)
versionFlag = flagVersion (add Version)
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
in noMode { modeGroupModes = toGroup allModes }
where
add flag (Args mode flags) = Args mode $ flag : flags
noArgs :: Arg a
noArgs = flagArg unexpected ""
where
unexpected a = error $ "Unexpected argument: " ++ a

81
src/IHaskell/IPython.hs
View File

@ -16,11 +16,7 @@ module IHaskell.IPython (
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent (threadDelay)
import System.Argv0
import qualified Shelly as SH
import qualified System.IO as IO
@ -32,12 +28,10 @@ import Data.Aeson.Text (encodeToTextBuilder)
import Data.Text.Lazy.Builder (toLazyText)
import Control.Monad (mplus)
import qualified System.IO.Strict as StrictIO
import qualified Paths_ihaskell as Paths
import qualified GHC.Paths
import IHaskell.Types
import System.Posix.Signals
import StringUtils (replace, split)
@ -66,9 +60,6 @@ defaultKernelSpecOptions = KernelSpecOptions
kernelName :: String
kernelName = "haskell"
kernelArgs :: [String]
kernelArgs = ["--kernel", kernelName]
ipythonCommand :: SH.Sh SH.FilePath
ipythonCommand = do
jupyterMay <- SH.which "jupyter"
@ -84,33 +75,6 @@ locateIPython = do
Nothing -> SH.errorExit "The Jupyter binary could not be located"
Just ipython -> return ipython
-- | Run the IPython command with any arguments. The kernel is set to IHaskell.
ipython :: Bool -- ^ Whether to suppress output.
-> [Text] -- ^ IPython command line arguments.
-> SH.Sh String -- ^ IPython output.
ipython suppress args = do
liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing
-- We have this because using `run` does not let us use stdin.
cmd <- ipythonCommand
SH.runHandles cmd args handles doNothing
where
handles = [SH.InHandle SH.Inherit, outHandle suppress, errorHandle suppress]
outHandle True = SH.OutHandle SH.CreatePipe
outHandle False = SH.OutHandle SH.Inherit
errorHandle True = SH.ErrorHandle SH.CreatePipe
errorHandle False = SH.ErrorHandle SH.Inherit
doNothing _ stdout _ = if suppress
then liftIO $ StrictIO.hGetContents stdout
else return ""
-- | Run while suppressing all output.
quietRun path args = SH.runHandles path args handles nothing
where
handles = [SH.InHandle SH.Inherit, SH.OutHandle SH.CreatePipe, SH.ErrorHandle SH.CreatePipe]
nothing _ _ _ = return ()
fp :: SH.FilePath -> FilePath
fp = T.unpack . SH.toTextIgnore
@ -125,17 +89,14 @@ ensure getDir = do
ihaskellDir :: SH.Sh FilePath
ihaskellDir = do
home <- maybe (error "$HOME not defined.") SH.fromText <$> SH.get_env "HOME"
fp <$> ensure (return (home SH.</> ".ihaskell"))
notebookDir :: SH.Sh SH.FilePath
notebookDir = ensure $ (SH.</> "notebooks") <$> ihaskellDir
fp <$> ensure (return (home SH.</> (".ihaskell" :: SH.FilePath)))
getIHaskellDir :: IO String
getIHaskellDir = SH.shelly ihaskellDir
defaultConfFile :: IO (Maybe String)
defaultConfFile = fmap (fmap fp) . SH.shelly $ do
filename <- (SH.</> "rc.hs") <$> ihaskellDir
filename <- (SH.</> ("rc.hs" :: SH.FilePath)) <$> ihaskellDir
exists <- SH.test_f filename
return $ if exists
then Just filename
@ -155,17 +116,17 @@ verifyIPythonVersion = do
Nothing -> badIPython
"No Jupyter / IPython detected -- install Jupyter 3.0+ before using IHaskell."
Just path -> do
stdout <- SH.silently (SH.run path ["--version"])
stderr <- SH.lastStderr
sout <- SH.silently (SH.run path ["--version"])
serr <- SH.lastStderr
let majorVersion = join . fmap listToMaybe . parseVersion . T.unpack
case mplus (majorVersion stderr) (majorVersion stdout) of
case mplus (majorVersion serr) (majorVersion sout) of
Nothing -> badIPython $ T.concat
[ "Detected Jupyter, but could not parse version number."
, "\n"
, "(stdout = "
, stdout
, sout
, ", stderr = "
, stderr
, serr
, ")"
]
@ -182,7 +143,7 @@ verifyIPythonVersion = do
-- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> SH.Sh ()
installKernelspec replace opts = void $ do
installKernelspec repl opts = void $ do
ihaskellPath <- getIHaskellPath
confFile <- liftIO $ kernelSpecConfFile opts
@ -195,7 +156,7 @@ installKernelspec replace opts = void $ do
++ ["--ghclib", kernelSpecGhcLibdir opts]
++ (case kernelSpecRTSOptions opts of
[] -> []
rtsOpts -> "+RTS" : kernelSpecRTSOptions opts ++ ["-RTS"])
_ -> "+RTS" : kernelSpecRTSOptions opts ++ ["-RTS"])
++ ["--stack" | kernelSpecUseStack opts]
let kernelSpec = KernelSpec
@ -208,7 +169,7 @@ installKernelspec replace opts = void $ do
-- shell out to IPython to install this kernelspec directory.
SH.withTmpDir $ \tmp -> do
let kernelDir = tmp SH.</> kernelName
let filename = kernelDir SH.</> "kernel.json"
let filename = kernelDir SH.</> ("kernel.json" :: SH.FilePath)
SH.mkdir_p kernelDir
SH.writefile filename $ LT.toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec
@ -219,36 +180,18 @@ installKernelspec replace opts = void $ do
ipython <- locateIPython
let replaceFlag = ["--replace" | replace]
let replaceFlag = ["--replace" | repl]
installPrefixFlag = maybe ["--user"] (\prefix -> ["--prefix", T.pack prefix]) (kernelSpecInstallPrefix opts)
cmd = concat [["kernelspec", "install"], installPrefixFlag, [SH.toTextIgnore kernelDir], replaceFlag]
SH.silently $ SH.run ipython cmd
kernelSpecCreated :: SH.Sh Bool
kernelSpecCreated = do
ipython <- locateIPython
out <- SH.silently $ SH.run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ T.lines out
return $ T.pack kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
subHome :: String -> IO String
subHome path = SH.shelly $ do
home <- T.unpack <$> fromMaybe "~" <$> SH.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.
path :: Text -> SH.Sh SH.FilePath
path exe = do
path <- SH.which $ SH.fromText exe
case path of
Nothing -> do
liftIO $ putStrLn $ "Could not find `" ++ T.unpack exe ++ "` executable."
fail $ "`" ++ T.unpack exe ++ "` not on $PATH."
Just exePath -> return exePath
-- | Parse an IPython version string into a list of integers.
parseVersion :: String -> Maybe [Int]
parseVersion versionStr =
@ -267,7 +210,7 @@ getIHaskellPath = do
-- If we have an absolute path, that's the IHaskell we're interested in.
if FP.isAbsolute f
then return f
else
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.
if FP.takeFileName f == f

29
src/IHaskell/IPython/Stdin.hs
View File

@ -26,16 +26,9 @@
module IHaskell.IPython.Stdin (fixStdin, recordParentHeader, recordKernelProfile) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent
import Control.Applicative ((<$>))
import Control.Concurrent.Chan
import Control.Monad
import GHC.IO.Handle
import GHC.IO.Handle.Types
import System.Posix.IO
@ -79,8 +72,8 @@ stdinOnce dir = do
loop stdinInput oldStdin newStdin = do
let FileHandle _ mvar = stdin
threadDelay $ 150 * 1000
empty <- isEmptyMVar mvar
if not empty
e <- isEmptyMVar mvar
if not e
then loop stdinInput oldStdin newStdin
else do
line <- getInputLine dir
@ -94,17 +87,17 @@ getInputLine dir = do
-- Send a request for input.
uuid <- UUID.random
parentHeader <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header")
let header = MessageHeader
{ username = username parentHeader
, identifiers = identifiers parentHeader
, parentHeader = Just parentHeader
parentHdr <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header")
let hdr = MessageHeader
{ username = username parentHdr
, identifiers = identifiers parentHdr
, parentHeader = Just parentHdr
, messageId = uuid
, sessionId = sessionId parentHeader
, sessionId = sessionId parentHdr
, metadata = Map.fromList []
, msgType = InputRequestMessage
}
let msg = RequestInput header ""
let msg = RequestInput hdr ""
writeChan req msg
-- Get the reply.
@ -112,8 +105,8 @@ getInputLine dir = do
return value
recordParentHeader :: String -> MessageHeader -> IO ()
recordParentHeader dir header =
writeFile (dir ++ "/.last-req-header") $ show header
recordParentHeader dir hdr =
writeFile (dir ++ "/.last-req-hdr") $ show hdr
recordKernelProfile :: String -> Profile -> IO ()
recordKernelProfile dir profile =

20
src/IHaskell/Publish.hs
View File

@ -25,7 +25,7 @@ publishResult :: (Message -> IO ()) -- ^ A function to send messages
-> Bool -- ^ Whether to use the pager
-> EvaluationResult -- ^ The evaluation result
-> IO ()
publishResult send replyHeader displayed updateNeeded pagerOutput usePager result = do
publishResult send replyHeader displayed updateNeeded poutput upager result = do
let final =
case result of
IntermediateResult{} -> False
@ -51,21 +51,21 @@ publishResult send replyHeader displayed updateNeeded pagerOutput usePager resul
-- If this has some pager output, store it for later.
let pager = pagerOut result
unless (null pager) $
if usePager
then modifyMVar_ pagerOutput (return . (++ pager))
if upager
then modifyMVar_ poutput (return . (++ pager))
else sendOutput $ Display pager
where
clearOutput = do
header <- dupHeader replyHeader ClearOutputMessage
send $ ClearOutput header True
hdr <- dupHeader replyHeader ClearOutputMessage
send $ ClearOutput hdr True
sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
sendOutput (Display outs) = do
header <- dupHeader replyHeader DisplayDataMessage
send $ PublishDisplayData header $ map (convertSvgToHtml . prependCss) outs
hdr <- dupHeader replyHeader DisplayDataMessage
send $ PublishDisplayData hdr $ map (convertSvgToHtml . prependCss) outs
convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
convertSvgToHtml (DisplayData MimeSvg s) = html $ makeSvgImg $ base64 $ E.encodeUtf8 s
convertSvgToHtml x = x
makeSvgImg :: Base64 -> String
@ -73,6 +73,6 @@ publishResult send replyHeader displayed updateNeeded pagerOutput usePager resul
base64data <>
"\"/>"
prependCss (DisplayData MimeHtml html) =
DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", html]
prependCss (DisplayData MimeHtml h) =
DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", h]
prependCss x = x

45
src/IHaskell/Types.hs
View File

@ -12,7 +12,7 @@ module IHaskell.Types (
MessageType(..),
dupHeader,
Username,
Metadata(..),
Metadata,
replyType,
ExecutionState(..),
StreamType(..),
@ -39,17 +39,8 @@ module IHaskell.Types (
import IHaskellPrelude
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Aeson (Value, (.=), object)
import Data.Aeson.Types (emptyObject)
import qualified Data.ByteString.Char8 as Char
import Data.Aeson (ToJSON, Value, (.=), object)
import Data.Function (on)
import Data.Semigroup
import Data.Serialize
import GHC.Generics
@ -100,6 +91,28 @@ class IHaskellDisplay a => IHaskellWidget a where
-> IO ()
close _ _ = return ()
-- | these instances cause the image, html etc. which look like:
--
-- > Display
-- > [Display]
-- > IO [Display]
-- > IO (IO Display)
--
-- 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 =<<)
instance IHaskellDisplay Display where
display = return
instance IHaskellDisplay DisplayData where
display disp = return $ Display [disp]
instance IHaskellDisplay a => IHaskellDisplay [a] where
display disps = do
displays <- mapM display disps
return $ ManyDisplay displays
data Widget = forall a. IHaskellWidget a => Widget a
deriving Typeable
@ -230,9 +243,9 @@ data WidgetMethod = UpdateState Value
| DisplayWidget
instance ToJSON WidgetMethod where
toJSON DisplayWidget = object ["method" .= "display"]
toJSON (UpdateState v) = object ["method" .= "update", "state" .= v]
toJSON (CustomContent v) = object ["method" .= "custom", "content" .= v]
toJSON DisplayWidget = object ["method" .= ("display" :: Text)]
toJSON (UpdateState v) = object ["method" .= ("update" :: Text), "state" .= v]
toJSON (CustomContent v) = object ["method" .= ("custom" :: Text), "content" .= v]
-- | Output of evaluation.
data EvaluationResult =
@ -252,7 +265,7 @@ data EvaluationResult =
-- | Duplicate a message header, giving it a new UUID and message type.
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
dupHeader header messageType = do
dupHeader hdr messageType = do
uuid <- liftIO random
return header { messageId = uuid, msgType = messageType }
return hdr { messageId = uuid, msgType = messageType }

30
src/IHaskellPrelude.hs
View File

@ -85,7 +85,7 @@ import Data.List as X hiding (head, last, tail, init, tra
elemIndices, elemIndex, findIndex, findIndices, zip5, zip6,
zip7, zipWith5, zipWith6, zipWith7, unzip5, unzip6, unzip6,
delete, union, lookup, intersect, insert, deleteBy,
deleteFirstBy, unionBy, intersectBy, group, groupBy, insertBy,
unionBy, intersectBy, group, groupBy, insertBy,
maximumBy, minimumBy, genericLength, genericDrop, genericTake,
genericSplitAt, genericIndex, genericReplicate, inits, tails)
@ -113,13 +113,27 @@ type LByteString = Data.ByteString.Lazy.ByteString
type LText = Data.Text.Lazy.Text
(headMay, tailMay, lastMay, initMay, maximumMay, minimumMay) =
(wrapEmpty head, wrapEmpty tail, wrapEmpty last,
wrapEmpty init, wrapEmpty maximum, wrapEmpty minimum)
where
wrapEmpty :: ([a] -> b) -> [a] -> Maybe b
wrapEmpty _ [] = Nothing
wrapEmpty f xs = Just (f xs)
headMay :: [a] -> Maybe a
headMay = wrapEmpty head
tailMay :: [a] -> Maybe [a]
tailMay = wrapEmpty tail
lastMay :: [a] -> Maybe a
lastMay = wrapEmpty last
initMay :: [a] -> Maybe [a]
initMay = wrapEmpty init
maximumMay :: Ord a => [a] -> Maybe a
maximumMay = wrapEmpty maximum
minimumMay :: Ord a => [a] -> Maybe a
minimumMay = wrapEmpty minimum
wrapEmpty :: ([a] -> b) -> [a] -> Maybe b
wrapEmpty _ [] = Nothing
wrapEmpty f xs = Just (f xs)
maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
maximumByMay _ [] = Nothing

1
src/StringUtils.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
module StringUtils (
strip,
lstrip,

28
src/tests/IHaskell/Test/Completion.hs
View File

@ -1,4 +1,9 @@
{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
{-# LANGUAGE CPP #-}
-- Shelly's types are kinda borked.
{-# OPTIONS_GHC -Wno-type-defaults #-}
module IHaskell.Test.Completion (testCompletions) where
import Prelude
@ -43,23 +48,20 @@ completionEventInDirectory string = withHsDirectory $ const $ completionEvent st
shouldHaveCompletionsInDirectory :: String -> [String] -> IO ()
shouldHaveCompletionsInDirectory string expected = do
(matched, completions) <- completionEventInDirectory string
let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected
(_, completions) <- completionEventInDirectory string
expected `shouldBeAmong` completions
completionHas :: String -> [String] -> IO ()
completionHas string expected = do
(matched, completions) <- ghc $ do
(_, completions) <- ghc $ do
initCompleter
completionEvent string
let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected
expected `shouldBeAmong` completions
initCompleter :: Interpreter ()
initCompleter = do
flags <- getSessionDynFlags
setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
_ <- setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
-- Import modules.
imports <- mapM parseImportDecl
@ -163,9 +165,8 @@ testCommandCompletion = describe "Completes commands" $ do
it "correctly interprets ~ as the environment HOME variable" $ do
let shouldHaveCompletions :: String -> [String] -> IO ()
shouldHaveCompletions string expected = do
(matched, completions) <- withHsHome $ completionEvent string
let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected
(_, completions) <- withHsHome $ completionEvent string
expected `shouldBeAmong` completions
":! cd ~/*" `shouldHaveCompletions` ["~/dir/"]
":! ~/*" `shouldHaveCompletions` ["~/dir/"]
@ -177,8 +178,6 @@ testCommandCompletion = describe "Completes commands" $ do
matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string)
matchText `shouldBe` expected
setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path)
it "generates the correct matchingText on `:! cd ~/*` " $
":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String)
@ -202,11 +201,11 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> do
where
cdEvent path = liftIO $ setCurrentDirectory path
wrap :: String -> Interpreter a -> Interpreter a
wrap path action = do
wrap path actn = do
initCompleter
pwd <- IHaskell.Eval.Evaluate.liftIO getCurrentDirectory
cdEvent path -- change to the temporary directory
out <- action -- run action
out <- actn -- run action
cdEvent pwd -- change back to the original directory
return out
@ -218,4 +217,5 @@ withHsDirectory = inDirectory [p "" </> p "dir", p "dir" </> p "dir1"]
, p "dir" </> p "file2.lhs"
]
where
p :: T.Text -> T.Text
p = id

38
src/tests/IHaskell/Test/Eval.hs
View File

@ -27,31 +27,31 @@ eval string = do
let publish evalResult =
case evalResult of
IntermediateResult{} -> return ()
FinalResult outs page [] -> do
FinalResult outs page _ -> do
modifyIORef outputAccum (outs :)
modifyIORef pagerAccum (page :)
noWidgetHandling s _ = return s
getTemporaryDirectory >>= setCurrentDirectory
let state = defaultKernelState { getLintStatus = LintOff }
interpret GHC.Paths.libdir False $ const $
IHaskell.Eval.Evaluate.evaluate state string publish noWidgetHandling
_ <- interpret GHC.Paths.libdir False $ const $
IHaskell.Eval.Evaluate.evaluate state string publish noWidgetHandling
out <- readIORef outputAccum
pagerOut <- readIORef pagerAccum
return (reverse out, unlines . map extractPlain . reverse $ pagerOut)
pagerout <- readIORef pagerAccum
return (reverse out, unlines . map extractPlain . reverse $ pagerout)
becomes :: String -> [String] -> IO ()
becomes string expected = evaluationComparing comparison string
where
comparison :: ([Display], String) -> IO ()
comparison (results, pageOut) = do
comparison (results, _pageOut) = do
when (length results /= length expected) $
expectationFailure $ "Expected result to have " ++ show (length expected)
++ " results. Got " ++ show results
forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) -> case extractPlain result of
"" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected
str -> str `shouldBe` expected
forM_ (zip results expected) $ \(ManyDisplay [Display result], expect) -> case extractPlain result of
"" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expect
str -> str `shouldBe` expect
evaluationComparing :: (([Display], String) -> IO b) -> String -> IO b
evaluationComparing comparison string = do
@ -66,27 +66,27 @@ evaluationComparing comparison string = do
pages :: String -> [String] -> IO ()
pages string expected = evaluationComparing comparison string
where
comparison (results, pageOut) =
comparison (_results, pageOut) =
strip (stripHtml pageOut) `shouldBe` strip (fixQuotes $ unlines expected)
-- A very, very hacky method for removing HTML
stripHtml str = go str
where
go ('<':str) =
case stripPrefix "script" str of
go ('<':xs) =
case stripPrefix "script" xs of
Nothing -> go' str
Just str -> dropScriptTag str
Just s -> dropScriptTag s
go (x:xs) = x : go xs
go [] = []
go' ('>':str) = go str
go' (x:xs) = go' xs
go' ('>':xs) = go xs
go' (_:xs) = go' xs
go' [] = error $ "Unending bracket html tag in string " ++ str
dropScriptTag str =
case stripPrefix "</script>" str of
Just str -> go str
Nothing -> dropScriptTag $ tail str
dropScriptTag str1 =
case stripPrefix "</script>" str1 of
Just s -> go s
Nothing -> dropScriptTag $ tail str
fixQuotes :: String -> String
fixQuotes = id

3
src/tests/IHaskell/Test/Parser.hs
View File

@ -6,8 +6,7 @@ import Prelude
import Data.String.Here (hereLit)
import Test.Hspec
import Test.Hspec.Contrib.HUnit
import Test.HUnit (assertBool, assertFailure)
import Test.HUnit (assertFailure)
import IHaskell.Test.Util (ghc, strip)
import IHaskell.Eval.Parser (parseString, getModuleName, unloc, layoutChunks, Located(..),

9
stack-8.0.yaml
View File

@ -1,3 +1,5 @@
resolver: lts-9.21
flags: {}
packages:
- .
@ -14,8 +16,13 @@ packages:
- ./ihaskell-display/ihaskell-plot
- ./ihaskell-display/ihaskell-static-canvas
- ./ihaskell-display/ihaskell-widgets
resolver: lts-9.21
extra-deps: []
ghc-options:
# Eventually we want "$locals": -Wall -Werror
ihaskell: -Wall -Werror
nix:
enable: false
packages:

4
stack-8.4.yaml
View File

@ -18,6 +18,10 @@ resolver: lts-12.8
extra-deps:
- magic-1.1
ghc-options:
# Eventually we want "$locals": -Wall -Werror
ihaskell: -Wall -Werror
nix:
enable: false
packages:

9
stack.yaml
View File

@ -1,3 +1,5 @@
resolver: lts-11.22
flags: {}
packages:
- .
@ -14,8 +16,13 @@ packages:
- ./ihaskell-display/ihaskell-plot
- ./ihaskell-display/ihaskell-static-canvas
- ./ihaskell-display/ihaskell-widgets
resolver: lts-11.22
ghc-options:
# Eventually we want "$locals": -Wall -Werror
ihaskell: -Wall -Werror
allow-newer: true
extra-deps:
- static-canvas-0.2.0.3
- diagrams-1.4