mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-15 19:06:06 +00:00
Fix various unused binding/match/etc related warnings
Add `-Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches` and fix all the things.
This commit is contained in:
Erik de Castro Lopo
parent
df39a6d235
commit
7115fe470a
@ -49,7 +49,7 @@ data-files:
|
||||
library
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures -Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches
|
||||
build-depends:
|
||||
aeson >=1.0,
|
||||
base >=4.9,
|
||||
@ -125,7 +125,7 @@ executable ihaskell
|
||||
|
||||
-- Other library packages from which modules are imported.
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures -Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches
|
||||
build-depends:
|
||||
ihaskell -any,
|
||||
base >=4.9 && < 4.13,
|
||||
@ -152,7 +152,7 @@ Test-Suite hspec
|
||||
IHaskell.Test.Util
|
||||
IHaskell.Test.Parser
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures
|
||||
ghc-options: -Wincomplete-patterns -Wmissing-signatures -Wunused-do-bind -Wunused-local-binds -Wunused-top-binds -Wunused-matches
|
||||
build-depends:
|
||||
base,
|
||||
ihaskell,
|
||||
|
||||
18
main/Main.hs
18
main/Main.hs
@ -56,18 +56,6 @@ import GHC hiding (extensions, language, convert)
|
||||
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
|
||||
@ -121,7 +109,7 @@ 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.
|
||||
@ -170,7 +158,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 }
|
||||
@ -469,7 +457,7 @@ handleComm send kernelState req replyHeader = do
|
||||
pgrOut <- liftIO $ readMVar pagerOutput
|
||||
liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
|
||||
return kernelState { openComms = Map.delete uuid widgets }
|
||||
x ->
|
||||
_ ->
|
||||
-- Only sensible thing to do.
|
||||
return kernelState
|
||||
|
||||
|
||||
@ -15,16 +15,16 @@ 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 +34,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
|
||||
|
||||
@ -101,7 +101,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 []
|
||||
@ -110,7 +110,6 @@ complete code posOffset = do
|
||||
return $ filter (candidate `isPrefixOf`) unqualNames
|
||||
|
||||
Qualified moduleName candidate -> do
|
||||
trueName <- getTrueModuleName moduleName
|
||||
let prefix = intercalate "." [moduleName, candidate]
|
||||
completions = filter (prefix `isPrefixOf`) qualNames
|
||||
return completions
|
||||
@ -123,8 +122,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 ++
|
||||
@ -145,33 +143,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.
|
||||
@ -246,9 +227,9 @@ completionType line loc target
|
||||
go acc rest =
|
||||
case rest of
|
||||
'"':'\\':rem -> go ('"' : acc) rem
|
||||
'"':rem -> acc
|
||||
'"':_ -> acc
|
||||
' ':'\\':rem -> go (' ' : acc) rem
|
||||
' ':rem -> acc
|
||||
' ':_ -> acc
|
||||
x:rem -> go (x : acc) rem
|
||||
[] -> acc
|
||||
|
||||
@ -268,7 +249,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 [] = []
|
||||
|
||||
@ -217,13 +217,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]
|
||||
@ -239,13 +232,15 @@ initializeImports = do
|
||||
|
||||
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
|
||||
|
||||
@ -525,7 +520,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
|
||||
@ -589,7 +584,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) =
|
||||
@ -604,9 +599,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
|
||||
@ -679,7 +674,7 @@ evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $
|
||||
let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
|
||||
replace " " "\\ " $
|
||||
replace "\"" "\\\"" directory
|
||||
execStmt cmd execOptions
|
||||
_ <- execStmt cmd execOptions
|
||||
return mempty
|
||||
else return $ displayError $ printf "No such directory: '%s'" directory
|
||||
cmd -> liftIO $ do
|
||||
@ -863,8 +858,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
|
||||
@ -916,7 +911,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
|
||||
@ -1027,7 +1022,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
|
||||
@ -1055,10 +1050,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.
|
||||
@ -1084,7 +1079,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
|
||||
@ -1098,11 +1093,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
|
||||
@ -1113,20 +1108,6 @@ doLoadModule name modName = do
|
||||
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)
|
||||
|
||||
@ -1185,7 +1166,7 @@ capturedEval output stmt = do
|
||||
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
|
||||
@ -1208,9 +1189,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
|
||||
|
||||
@ -1236,7 +1214,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.
|
||||
@ -1270,7 +1248,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
|
||||
@ -1317,7 +1295,7 @@ 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
|
||||
@ -1353,9 +1331,6 @@ formatErrorWithClass cls =
|
||||
where
|
||||
fixDollarSigns = replace "$" "<span>$</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) =
|
||||
|
||||
@ -34,7 +34,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
|
||||
|
||||
@ -149,7 +149,7 @@ createModule mode (Located line block) =
|
||||
stmtToModule :: String -> ParseResult ExtsModule
|
||||
stmtToModule stmtStr =
|
||||
case parseStmtWithMode mode stmtStr of
|
||||
ParseOk stmt -> ParseOk mod
|
||||
ParseOk _ -> ParseOk mod
|
||||
ParseFailed a b -> ParseFailed a b
|
||||
where
|
||||
mod = moduleWithDecls decl
|
||||
|
||||
@ -37,12 +37,12 @@ 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]
|
||||
@ -61,9 +61,9 @@ 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
|
||||
|
||||
|
||||
@ -193,7 +193,7 @@ parseCodeChunk code startLine = do
|
||||
case parser string of
|
||||
Parsed res -> Parsed (blockType res)
|
||||
Failure err loc -> Failure err loc
|
||||
otherwise -> error "tryParser failed, output was neither Parsed nor Failure"
|
||||
_ -> error "tryParser failed, output was neither Parsed nor Failure"
|
||||
|
||||
parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]
|
||||
parsers flags =
|
||||
@ -206,8 +206,8 @@ parseCodeChunk code startLine = do
|
||||
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
|
||||
Parsed _ -> Parsed code
|
||||
Partial _ strs -> Partial code strs
|
||||
Failure err loc -> Failure err loc
|
||||
|
||||
-- | Find consecutive declarations of the same function and join them into a single declaration.
|
||||
@ -239,7 +239,7 @@ 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 _line =
|
||||
let commaToSpace :: Char -> Char
|
||||
commaToSpace ',' = ' '
|
||||
commaToSpace x = x
|
||||
@ -256,7 +256,7 @@ 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 = Directive ShellCmd $ '!' : directive
|
||||
parseDirective (':':directive) line =
|
||||
case find rightDirective directives of
|
||||
Just (directiveType, _) -> Directive directiveType arg
|
||||
@ -302,4 +302,4 @@ getModuleName moduleSrc = do
|
||||
case unLoc <$> hsmodName (unLoc mod) 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"
|
||||
|
||||
@ -190,7 +190,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
|
||||
@ -205,9 +205,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.
|
||||
@ -348,7 +347,6 @@ evalImport imports = do
|
||||
|
||||
removeImport :: GhcMonad m => String -> m ()
|
||||
removeImport moduleName = do
|
||||
flags <- getSessionDynFlags
|
||||
ctx <- getContext
|
||||
let ctx' = filter (not . (isImportOf $ mkModuleName moduleName)) ctx
|
||||
setContext ctx'
|
||||
@ -378,10 +376,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.
|
||||
|
||||
@ -66,9 +66,6 @@ defaultKernelSpecOptions = KernelSpecOptions
|
||||
kernelName :: String
|
||||
kernelName = "haskell"
|
||||
|
||||
kernelArgs :: [String]
|
||||
kernelArgs = ["--kernel", kernelName]
|
||||
|
||||
ipythonCommand :: SH.Sh SH.FilePath
|
||||
ipythonCommand = do
|
||||
jupyterMay <- SH.which "jupyter"
|
||||
@ -84,34 +81,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 :: SH.FilePath -> [Text] -> SH.Sh ()
|
||||
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
|
||||
|
||||
@ -128,9 +97,6 @@ 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
|
||||
|
||||
getIHaskellDir :: IO String
|
||||
getIHaskellDir = SH.shelly ihaskellDir
|
||||
|
||||
@ -196,7 +162,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
|
||||
@ -226,30 +192,12 @@ installKernelspec replace opts = void $ do
|
||||
|
||||
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 =
|
||||
|
||||
@ -43,24 +43,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
|
||||
@ -164,9 +160,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/"]
|
||||
@ -178,8 +173,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)
|
||||
|
||||
|
||||
@ -34,8 +34,8 @@ eval string = do
|
||||
|
||||
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)
|
||||
@ -44,7 +44,7 @@ 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
|
||||
@ -66,7 +66,7 @@ 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
|
||||
@ -80,7 +80,7 @@ pages string expected = evaluationComparing comparison string
|
||||
go [] = []
|
||||
|
||||
go' ('>':str) = go str
|
||||
go' (x:xs) = go' xs
|
||||
go' (_:xs) = go' xs
|
||||
go' [] = error $ "Unending bracket html tag in string " ++ str
|
||||
|
||||
dropScriptTag str =
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user