("kind", keepGoing' kindOfType, completeIdentifier),
("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
("list", keepGoing' listCmd, noCompletion),
- ("module", keepGoing setContext, completeModule),
+ ("module", keepGoing setContext, completeSetModule),
("main", keepGoing runMain, completeFilename),
("print", keepGoing printCmd, completeExpression),
("quit", quit, noCompletion),
putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
return False
else do
- let mode = fileMode st
+ let mode = System.Posix.fileMode st
if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
|| (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
then do
(doCommand c)
where
printErrorAndKeepGoing err = do
- GHC.printExceptionAndWarnings err
+ GHC.printException err
return False
noSpace q = q >>= maybe (return Nothing)
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s = handleSourceError GHC.printExceptionAndWarnings $
+info s = handleSourceError GHC.printException $
withFlattenedDynflags $ do
{ let names = words s
; dflags <- getDynFlags
mb_stuffs <- mapM GHC.getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
unqual <- GHC.getPrintUnqual
- outputStrLn $ showSDocForUser unqual $
+ liftIO $ putStrLn $ showSDocForUser unqual $
vcat (intersperse (text "") $
map (pprInfo pefas) filtered)
changeDirectory dir = do
graph <- GHC.getModuleGraph
when (not (null graph)) $
- outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
prev_context <- GHC.getContext
GHC.setTargets []
_ <- GHC.load LoadAllTargets
trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
trySuccess act =
- handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+ handleSourceError (\e -> do GHC.printException e
return Failed) $ do
act
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+ handleSourceError (\e -> GHC.printException e) $
withFlattenedDynflags $ do
hv <- GHC.compileExpr new_expr
io (writeIORef macros_ref --
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+ handleSourceError (\e -> GHC.printException e) $
withFlattenedDynflags $ do
hv <- GHC.compileExpr expr
cmds <- io $ (unsafeCoerce# hv :: IO String)
checkModule m = do
let modl = GHC.mkModuleName m
prev_context <- GHC.getContext
- ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
- outputStrLn (showSDoc (
+ liftIO $ putStrLn $ showSDoc $
case GHC.moduleInfo r of
cm | Just scope <- GHC.modInfoTopLevelScope cm ->
let
in
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
- _ -> empty))
+ _ -> empty
return True
afterLoad (successIf ok) False prev_context
punctuate comma (map ppr mods)) <> text "."
case ok of
Failed ->
- outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
+ liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas)
Succeeded ->
- outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
+ liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas)
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+ = handleSourceError GHC.printException
$ withFlattenedDynflags
$ do
ty <- GHC.exprType str
kindOfType :: String -> InputT GHCi ()
kindOfType str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+ = handleSourceError GHC.printException
$ withFlattenedDynflags
$ do
ty <- GHC.typeKind str
withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
withFlattenedDynflags m
= do dflags <- GHC.getSessionDynFlags
- gbracket (GHC.setSessionDynFlags (ensureFlattenedLanguageFlags dflags))
+ gbracket (GHC.setSessionDynFlags dflags)
(\_ -> GHC.setSessionDynFlags dflags)
(\_ -> m)
let prettyThings = map (pretty pefas) things
prettyThings' | bang = annotate $ zip modNames prettyThings
| otherwise = prettyThings
- outputStrLn $ showSDocForUser unqual (vcat prettyThings')
+ liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings')
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
-- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
(dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
- handleFlagWarnings dflags' warns
+ liftIO $ handleFlagWarnings dflags' warns
if (not (null leftovers))
then ghcError $ errorsToGhcException leftovers
-- code for `:show'
showCmd :: String -> GHCi ()
-showCmd str = do
+showCmd str = withFlattenedDynflags $ do
st <- getGHCiState
case words str of
["args"] -> io $ putStrLn (show (args st))
io $ putStrLn $ showSDoc $ vcat $
text ("active package flags:"++if null pkg_flags then " none" else "")
: map showFlag pkg_flags
- pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
- io $ putStrLn $ showSDoc $ vcat $
- text "packages currently loaded:"
- : map (nest 2 . text . packageIdString)
- (sortBy (compare `on` packageIdFS) pkg_ids)
where showFlag (ExposePackage p) = text $ " -package " ++ p
showFlag (HidePackage p) = text $ " -hide-package " ++ p
showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
dflags <- getDynFlags
io $ putStrLn $ showSDoc $ vcat $
text "active language flags:" :
- [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
+ [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
-- -----------------------------------------------------------------------------
-- Completion
completeCmd, completeMacro, completeIdentifier, completeModule,
+ completeSetModule,
completeHomeModule, completeSetOptions, completeShowOptions,
completeHomeModuleOrFile, completeExpression
:: CompletionFunc GHCi
return $ filter (w `isPrefixOf`)
$ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
+completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
+ modules <- case m of
+ Just '-' -> do
+ (toplevs, exports) <- GHC.getContext
+ return $ map GHC.moduleName (nub (map fst exports) ++ toplevs)
+ _ -> do
+ dflags <- GHC.getSessionDynFlags
+ let pkg_mods = allExposedModules dflags
+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+ return $ loaded_mods ++ pkg_mods
+ return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules
+
completeHomeModule = wrapIdentCompleter listHomeModules
listHomeModules :: String -> GHCi [String]
wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
wrapIdentCompleter = wrapCompleter word_break_chars
+wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
+ $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
+ where
+ getModifier = find (`elem` modifChars)
+
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules dflags
= concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
-> (Name -> m ())
-> m ()
wantNameFromInterpretedModule noCanDo str and_then =
- handleSourceError (GHC.printExceptionAndWarnings) $ do
+ handleSourceError GHC.printException $ do
names <- GHC.parseName str
case names of
[] -> return ()
list2 [arg] | all isDigit arg = do
(toplevel, _) <- GHC.getContext
case toplevel of
- [] -> outputStrLn "No module to list"
+ [] -> liftIO $ putStrLn "No module to list"
(mod : _) -> listModuleLine mod (read arg)
list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
mod <- wantInterpretedModule arg1
noCanDo n why = printForUser $
text "cannot list source code for " <> ppr n <> text ": " <> why
list2 _other =
- outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
listModuleLine :: Module -> Int -> InputT GHCi ()
listModuleLine modl line = do
let output = BS.intercalate (BS.pack "\n") prefixed
utf8Decoded <- liftIO $ BS.useAsCStringLen output
$ \(p,n) -> utf8DecodeString (castPtr p) n
- outputStrLn utf8Decoded
+ liftIO $ putStrLn utf8Decoded
where
file = GHC.srcSpanFile span
line1 = GHC.srcSpanStartLine span
projects / ghc-hetmet.git / blobdiff