X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=9e8af51dcf205601f0f1256f2f674522abbb24b1;hb=c4854c781cdf7046fe6ec064c805fa838e31e933;hp=685cf843f71856ac8f69ef586f77f17a253e246c;hpb=d011e9110e2d9b0dd7a8f18f2e0cada8e537f86b;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 685cf84..9e8af51 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.81 2001/07/17 14:53:48 rrt Exp $ +-- $Id: InteractiveUI.hs,v 1.92 2001/10/15 15:05:17 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -8,6 +8,7 @@ ----------------------------------------------------------------------------- {-# OPTIONS -#include "Linker.h" #-} +{-# OPTIONS -#include "SchedAPI.h" #-} module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "../includes/config.h" @@ -15,7 +16,8 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where import Packages import CompManager -import HscTypes ( GhciMode(..) ) +import HscTypes ( GhciMode(..), TyThing(..) ) +import MkIface ( ifaceTyCls ) import ByteCodeLink import DriverFlags import DriverState @@ -23,7 +25,16 @@ import DriverUtil import Linker import Finder ( flushPackageCache ) import Util -import Name ( Name ) +import Id ( isRecordSelector, recordSelectorFieldLabel, + isDataConWrapId, idName ) +import Class ( className ) +import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon ) +import FieldLabel ( fieldLabelTyCon ) +import SrcLoc ( isGoodSrcLoc ) +import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, + NamedThing(..) ) +import OccName ( isSymOcc ) +import BasicTypes ( defaultFixity ) import Outputable import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset ) import Panic ( GhcException(..) ) @@ -71,6 +82,7 @@ builtin_commands = [ ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), + ("info", keepGoing info), ("load", keepGoing loadModule), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), @@ -88,12 +100,13 @@ shortHelpText = "use :? for help.\n" helpText = "\ \ Commands available from the prompt:\n\ -\\ +\\ \ evaluate/run \n\ \ :add ... add module(s) to the current target set\n\ \ :cd change directory to \n\ \ :def define a command :\n\ \ :help, :? display this list of commands\n\ +\ :info [ ...] display information about the given names\n\ \ :load ... load module(s) and their dependents\n\ \ :module set the context for expression evaluation to \n\ \ :reload reload the current module set\n\ @@ -159,31 +172,36 @@ interactiveUI cmstate paths cmdline_libs = do runGHCi :: GHCi () runGHCi = do - -- Read in ./.ghci. - let file = "./.ghci" - exists <- io (doesFileExist file) - when exists $ do - dir_ok <- io (checkPerms ".") - file_ok <- io (checkPerms file) - when (dir_ok && file_ok) $ do - either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) - case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False - - -- Read in $HOME/.ghci - either_dir <- io (IO.try (getEnv "HOME")) - case either_dir of - Left e -> return () - Right dir -> do - cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - let file = dir ++ "/.ghci" - ok <- io (checkPerms file) - either_hdl <- io (IO.try (openFile file ReadMode)) - case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False + read_dot_files <- io (readIORef v_Read_DotGHCi) + + when (read_dot_files) $ do + -- Read in ./.ghci. + let file = "./.ghci" + exists <- io (doesFileExist file) + when exists $ do + dir_ok <- io (checkPerms ".") + file_ok <- io (checkPerms file) + when (dir_ok && file_ok) $ do + either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) + case either_hdl of + Left e -> return () + Right hdl -> fileLoop hdl False + + when (read_dot_files) $ do + -- Read in $HOME/.ghci + either_dir <- io (IO.try (getEnv "HOME")) + case either_dir of + Left e -> return () + Right dir -> do + cwd <- io (getCurrentDirectory) + when (dir /= cwd) $ do + let file = dir ++ "/.ghci" + ok <- io (checkPerms file) + when ok $ do + either_hdl <- io (IO.try (openFile file ReadMode)) + case either_hdl of + Left e -> return () + Right hdl -> fileLoop hdl False -- read commands from stdin #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS @@ -200,11 +218,10 @@ runGHCi = do -- and aren't world writable. Otherwise, we could be accidentally -- running code planted by a malicious third party. --- Furthermore, We only read ./.ghci if both . and ./.ghci are --- owned by the current user and aren't writable by anyone else. I --- think this is sufficient: we don't need to check .. and --- ../.. etc. because "." always refers to the same directory while a --- process is running. +-- Furthermore, We only read ./.ghci if . is owned by the current user +-- and isn't writable by anyone else. I think this is sufficient: we +-- don't need to check .. and ../.. etc. because "." always refers to +-- the same directory while a process is running. checkPerms :: String -> IO Bool checkPerms name = @@ -364,6 +381,65 @@ noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments")) help :: String -> GHCi () help _ = io (putStr helpText) +info :: String -> GHCi () +info "" = throwDyn (CmdLineError "syntax: `:i '") +info s = do + let names = words s + state <- getGHCiState + dflags <- io getDynFlags + let + infoThings cms [] = return cms + infoThings cms (name:names) = do + (cms, unqual, stuff) <- io (cmInfoThing cms dflags name) + io (putStrLn (showSDocForUser unqual ( + vcat (intersperse (text "") (map showThing stuff)))) + ) + infoThings cms names + + showThing (ty_thing, fixity) + = vcat [ text "-- " <> showTyThing ty_thing, + showFixity fixity (getName ty_thing), + ppr (ifaceTyThing ty_thing) ] + + showFixity fix name + | fix == defaultFixity = empty + | otherwise = ppr fix <+> + (if isSymOcc (nameOccName name) + then ppr name + else char '`' <> ppr name <> char '`') + + showTyThing (AClass cl) + = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] + showTyThing (ATyCon ty) + | isPrimTyCon ty + = hcat [ppr ty, text " is a primitive type constructor"] + | otherwise + = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)] + showTyThing (AnId id) + = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)] + + idDescr id + | isRecordSelector id = + case tyConClass_maybe (fieldLabelTyCon ( + recordSelectorFieldLabel id)) of + Nothing -> text "record selector" + Just c -> text "method in class " <> ppr c + | isDataConWrapId id = text "data constructor" + | otherwise = text "variable" + + -- also print out the source location for home things + showSrcLoc name + | isHomePackageName name && isGoodSrcLoc loc + = hsep [ text ", defined at", ppr loc ] + | otherwise + = empty + where loc = nameSrcLoc name + + cms <- infoThings (cmstate state) names + setGHCiState state{ cmstate = cms } + return () + + addModule :: String -> GHCi () addModule str = do let files = words str @@ -643,7 +719,8 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) -io m = GHCi $ \s -> m >>= \a -> return a +io :: IO a -> GHCi a +io m = GHCi { unGHCi = \s -> m >>= return } ----------------------------------------------------------------------------- -- recursive exception handlers @@ -684,6 +761,12 @@ linkPackages cmdline_lib_specs pkgs = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ] lib_paths <- readIORef v_Library_paths mapM_ (preloadLib lib_paths) cmdline_lib_specs + if (null cmdline_lib_specs) + then return () + else do putStr "final link ... " + ok <- resolveObjs + if ok then putStrLn "done." + else throwDyn (InstallationError "linking extra libraries/objects failed") where -- Packages that are already linked into GHCi. For mingw32, we only -- skip gmp and rts, since std and after need to load the msvcrt.dll @@ -701,7 +784,7 @@ linkPackages cmdline_lib_specs pkgs case lib_spec of Left static_ish -> do b <- preload_static lib_paths static_ish - putStrLn (if b then "done" else "not found") + putStrLn (if b then "done." else "not found") Right dll_unadorned -> -- We add "" to the set of paths to try, so that -- if none of the real paths match, we force addDLL @@ -757,8 +840,9 @@ linkPackage loaded_in_ghci pkg mapM loadClassified sos_first putStr "linking ... " - resolveObjs - putStrLn "done." + ok <- resolveObjs + if ok then putStrLn "done." + else panic ("can't load package `" ++ name pkg ++ "'") where isRight (Right _) = True isRight (Left _) = False