X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=c457d8a68d213b733598484a51129a0c3a7720f8;hb=cfb69428a10e245bc5b64417803b637693977b24;hp=6b8f9844ec2dd5e712246359989b71ff0f5cf5d2;hpb=0f84e2ce427b68295d057cb1ce2cab8f8d12742d;p=ghc-hetmet.git diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 6b8f984..c457d8a 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -140,7 +140,7 @@ builtin_commands = [ ("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), @@ -497,7 +497,7 @@ checkPerms name = 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 @@ -657,7 +657,7 @@ runStmt stmt step -- 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 @@ -815,7 +815,8 @@ help _ = io (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") -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 @@ -826,7 +827,7 @@ info s = handleSourceError GHC.printExceptionAndWarnings $ do 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) @@ -856,7 +857,8 @@ runMain :: String -> GHCi () 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 @@ -974,7 +976,8 @@ defineMacro overwrite s = do 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)])) @@ -1001,7 +1004,8 @@ undefineMacro str = mapM_ undef (words str) 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) @@ -1045,7 +1049,7 @@ checkModule m = do 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 @@ -1054,7 +1058,7 @@ checkModule m = do in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) - _ -> empty)) + _ -> empty return True afterLoad (successIf ok) False prev_context @@ -1084,7 +1088,7 @@ afterLoad ok retain_context prev_context = do 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 () @@ -1157,14 +1161,16 @@ modulesLoadedMsg ok mods = do 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 @@ -1172,7 +1178,9 @@ typeOfExpr str 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 @@ -1182,6 +1190,13 @@ quit _ = return True 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 @@ -1210,7 +1225,7 @@ browseCmd bang m = -- 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, @@ -1285,7 +1300,7 @@ browseModule bang modl exports_only = do 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)) @@ -1323,6 +1338,7 @@ setContext str playCtxtCmd:: Bool -> CtxtCmd -> GHCi () playCtxtCmd fail cmd = do + withFlattenedDynflags $ do (prev_as,prev_bs) <- GHC.getContext case cmd of SetContext as bs -> do @@ -1403,15 +1419,13 @@ setCmd "" )) 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 @@ -1566,7 +1580,7 @@ optToStr RevertCAFs = "r" -- 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)) @@ -1631,11 +1645,6 @@ showPackages = do 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 @@ -1646,12 +1655,13 @@ showLanguages = do 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 @@ -1697,6 +1707,18 @@ completeModule = wrapIdentCompleter $ \w -> do 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] @@ -1734,6 +1756,12 @@ wrapCompleter breakChars fun = completeWord Nothing breakChars 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))) @@ -1852,7 +1880,7 @@ forceCmd = pprintCommand False True 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 @@ -1983,7 +2011,7 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = do - breakSwitch $ words argLine + withFlattenedDynflags $ breakSwitch $ words argLine breakSwitch :: [String] -> GHCi () breakSwitch [] = do @@ -2116,7 +2144,10 @@ end_bold :: String 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 -> @@ -2135,13 +2166,13 @@ listCmd "" = do 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 @@ -2166,7 +2197,7 @@ list2 [arg] = do noCanDo n why = printForUser $ text "cannot list source code for " <> ppr n <> text ": " <> why list2 _other = - outputStrLn "syntax: :list [ | | ]" + liftIO $ putStrLn "syntax: :list [ | | ]" listModuleLine :: Module -> Int -> InputT GHCi () listModuleLine modl line = do @@ -2207,7 +2238,7 @@ listAround span do_highlight = 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