("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
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
- | null (filter (not.isSpace) stmt) = return False
- | x@('i':'m':'p':'o':'r':'t':' ':_) <- stmt = keepGoing' (importContext True) x
+ | null (filter (not.isSpace) stmt)
+ = return False
+ | "import " `isPrefixOf` stmt
+ = do newContextCmd (Import stmt); return False
| otherwise
= do
#if __GLASGOW_HASKELL__ >= 611
-- a file, otherwise the read buffer can't be flushed).
_ <- liftIO $ IO.try $ hFlushAll stdin
#endif
- result <- GhciMonad.runStmt stmt step
+ result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step
afterRunStmt (const True) result
--afterRunStmt :: GHC.RunResult -> GHCi Bool
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s = handleSourceError GHC.printExceptionAndWarnings $ do
+info s = handleSourceError GHC.printExceptionAndWarnings $
+ withFlattenedDynflags $ do
{ let names = words s
; dflags <- getDynFlags
; let pefas = dopt Opt_PrintExplicitForalls dflags
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)
runMain s = case toArgs s of
Left err -> io (hPutStrLn stderr err)
Right args ->
- do dflags <- getDynFlags
+ withFlattenedDynflags $ do
+ dflags <- getDynFlags
case mainFunIs dflags of
Nothing -> doWithArgs args "main"
Just f -> doWithArgs args f
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+ withFlattenedDynflags $ do
hv <- GHC.compileExpr new_expr
io (writeIORef macros_ref --
(filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+ withFlattenedDynflags $ do
hv <- GHC.compileExpr expr
cmds <- io $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds)
prev_context <- GHC.getContext
ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings 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
loaded_mod_names = map GHC.moduleName loaded_mods
modulesLoadedMsg ok loaded_mod_names
- lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
+ withFlattenedDynflags $ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
if keep_ctxt
then do
st <- getGHCiState
- let mem = remembered_ctx st
- playCmd (Left x) = playCtxtCmd False x
- playCmd (Right x) = importContext False x
- mapM_ playCmd mem
+ mapM_ (playCtxtCmd False) (remembered_ctx st)
else do
st <- getGHCiState
setGHCiState st{ remembered_ctx = [] }
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) $ do
+ = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+ $ withFlattenedDynflags
+ $ do
ty <- GHC.exprType str
dflags <- getDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
kindOfType :: String -> InputT GHCi ()
kindOfType str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+ $ withFlattenedDynflags
+ $ do
ty <- GHC.typeKind str
printForUser $ text str <+> dcolon <+> ppr ty
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
+withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
+withFlattenedDynflags m
+ = do dflags <- GHC.getSessionDynFlags
+ gbracket (GHC.setSessionDynFlags (ensureFlattenedExtensionFlags dflags))
+ (\_ -> GHC.setSessionDynFlags dflags)
+ (\_ -> m)
+
-----------------------------------------------------------------------------
-- Browsing a module's contents
-- indicate import modules, to aid qualifying unqualified names
-- with sorted, sort items alphabetically
browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
-browseModule bang modl exports_only = do
+browseModule bang modl exports_only = withFlattenedDynflags $ do
-- :browse! reports qualifiers wrt current context
current_unqual <- GHC.getPrintUnqual
-- Temporarily set the context to the module we're interested in,
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))
-----------------------------------------------------------------------------
-- Setting the module context
-importContext :: Bool -> String -> GHCi ()
-importContext fail str
- = do
- (as,bs) <- GHC.getContext
- x <- do_checks fail
- case Monad.join x of
- Nothing -> return ()
- (Just a) -> do
- m <- loadModuleName a
- GHC.setContext as (bs++[(m,Just a)])
- st <- getGHCiState
- let cmds = remembered_ctx st
- setGHCiState st{ remembered_ctx = cmds++[Right str] }
- where
- do_checks True = liftM Just (GhciMonad.parseImportDecl str)
- do_checks False = trymaybe (GhciMonad.parseImportDecl str)
+newContextCmd :: CtxtCmd -> GHCi ()
+newContextCmd cmd = do
+ playCtxtCmd True cmd
+ st <- getGHCiState
+ let cmds = remembered_ctx st
+ setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
setContext :: String -> GHCi ()
setContext str
- | all sensible strs = do
- playCtxtCmd True (cmd, as, bs)
- st <- getGHCiState
- let cmds = remembered_ctx st
- setGHCiState st{ remembered_ctx = cmds ++ [Left (cmd,as,bs)] }
+ | all sensible strs = newContextCmd cmd
| otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
where
- (cmd, strs, as, bs) =
+ (cmd, strs) =
case str of
'+':stuff -> rest AddModules stuff
'-':stuff -> rest RemModules stuff
stuff -> rest SetContext stuff
- rest cmd stuff = (cmd, strs, as, bs)
+ rest cmd stuff = (cmd as bs, strs)
where strs = words stuff
(as,bs) = partitionWith starred strs
starred ('*':m) = Left m
starred m = Right m
-playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
-playCtxtCmd fail (cmd, as, bs)
- = do
- (as',bs') <- do_checks fail
+playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
+playCtxtCmd fail cmd = do
+ withFlattenedDynflags $ do
(prev_as,prev_bs) <- GHC.getContext
- (new_as, new_bs) <-
- case cmd of
- SetContext -> do
+ case cmd of
+ SetContext as bs -> do
+ (as',bs') <- do_checks as bs
prel_mod <- getPrelude
- let bs'' = if null as && prel_mod `notElem` (map fst bs') then (prel_mod,Nothing):bs'
- else bs'
- return (as', bs'')
- AddModules -> do
+ let bs'' = if null as && prel_mod `notElem` (map fst bs')
+ then (prel_mod,Nothing):bs'
+ else bs'
+ GHC.setContext as' bs''
+
+ AddModules as bs -> do
+ (as',bs') <- do_checks as bs
-- it should replace the old stuff, not the other way around
-- need deleteAllBy, not deleteFirstsBy for sameFst
let remaining_as = prev_as \\ (as' ++ map fst bs')
remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
- return (remaining_as ++ as', remaining_bs ++ bs')
- RemModules -> do
+ GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs')
+
+ RemModules as bs -> do
+ (as',bs') <- do_checks as bs
let new_as = prev_as \\ (as' ++ map fst bs')
new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
- return (new_as, new_bs)
- GHC.setContext new_as new_bs
+ GHC.setContext new_as new_bs
+
+ Import str -> do
+ m_idecl <- maybe_fail $ GHC.parseImportDecl str
+ case m_idecl of
+ Nothing -> return ()
+ Just idecl -> do
+ m_mdl <- maybe_fail $ loadModuleName idecl
+ case m_mdl of
+ Nothing -> return ()
+ Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)])
+
where
- do_checks True = do
- as' <- mapM wantInterpretedModule as
- bs' <- mapM lookupModule bs
- return (as', map contextualize bs')
- do_checks False = do
- as' <- mapM (trymaybe . wantInterpretedModule) as
- bs' <- mapM (trymaybe . lookupModule) bs
- return (catMaybes as', map contextualize (catMaybes bs'))
+ maybe_fail | fail = liftM Just
+ | otherwise = trymaybe
+
+ do_checks as bs = do
+ as' <- mapM (maybe_fail . wantInterpretedModule) as
+ bs' <- mapM (maybe_fail . lookupModule) bs
+ return (catMaybes as', map contextualize (catMaybes bs'))
+
contextualize x = (x,Nothing)
deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
))
io $ putStrLn (showSDoc (
vcat (text "other dynamic, non-language, flag settings:"
- :map (flagSetting dflags) nonLanguageDynFlags)
+ :map (flagSetting dflags) others)
))
where flagSetting dflags (str, f, _)
| dopt f dflags = text " " <> text "-f" <> text str
| otherwise = text " " <> text "-fno-" <> text str
(ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
DynFlags.fFlags
- nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
- others
flags = [Opt_PrintExplicitForalls
,Opt_PrintBindResult
,Opt_BreakOnException
-- 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)))
pprintCommand :: Bool -> Bool -> String -> GHCi ()
pprintCommand bind force str = do
- pprintClosureCommand bind force str
+ withFlattenedDynflags $ pprintClosureCommand bind force str
stepCmd :: String -> GHCi ()
stepCmd [] = doContinue (const True) GHC.SingleStep
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
- breakSwitch $ words argLine
+ withFlattenedDynflags $ breakSwitch $ words argLine
breakSwitch :: [String] -> GHCi ()
breakSwitch [] = do
end_bold = "\ESC[0m"
listCmd :: String -> InputT GHCi ()
-listCmd "" = do
+listCmd c = withFlattenedDynflags $ listCmd' c
+
+listCmd' :: String -> InputT GHCi ()
+listCmd' "" = do
mb_span <- lift getCurrentBreakSpan
case mb_span of
Nothing ->
printForUser (text "Unable to list source for" <+>
ppr span
$$ text "Try" <+> doWhat)
-listCmd str = list2 (words str)
+listCmd' str = list2 (words str)
list2 :: [String] -> InputT GHCi ()
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