X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=51fcd8e8d39644df9f3940b26db5aed758efdc23;hb=6189bc57f7baf2a2dda8c714cf32e29792c708b7;hp=719714e3daec4c3045d982e891497b73a6d6f6e8;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 719714e..51fcd8e 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,43 +1,45 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.180 2004/11/26 16:20:36 simonmar Exp $ -- -- GHC Interactive User Interface -- --- (c) The GHC Team 2004 +-- (c) The GHC Team 2005 -- ----------------------------------------------------------------------------- module InteractiveUI ( - interactiveUI, -- :: CmState -> [FilePath] -> IO () + interactiveUI, ghciWelcomeMsg ) where -#include "../includes/ghcconfig.h" #include "HsVersions.h" -import CompManager -import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable, - isObjectLinkable, GhciMode(..) ) -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), - IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) -import FunDeps ( pprFundeps ) -import DriverFlags -import DriverState -import DriverUtil ( remove_spaces ) -import Linker ( showLinkerState, linkPackages ) -import Util -import Module ( showModMsg, lookupModuleEnv ) -import Name ( Name, NamedThing(..) ) -import OccName ( OccName, isSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) +-- The GHC interface +import qualified GHC +import GHC ( Session, verbosity, dopt, DynFlag(..), + mkModule, pprModule, Type, Module, SuccessFlag(..), + TyThing(..), Name ) import Outputable -import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset ) + +-- following all needed for :info... ToDo: remove +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), + IfaceConDecl(..), IfaceType, + pprIfaceDeclHead, pprParendIfaceType, + pprIfaceForAllPart, pprIfaceType ) +import FunDeps ( pprFundeps ) +import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import OccName ( OccName, parenSymOcc, occNameUserString ) +import BasicTypes ( StrictnessMark(..), defaultFixity ) + +-- Other random utilities import Panic hiding ( showException ) import Config -import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import StaticFlags ( opt_IgnoreDotGhci ) +import Linker ( showLinkerState ) +import Util ( removeSpaces, handle, global, toArgs, + looksLikeModuleName, prefixMatch ) #ifndef mingw32_HOST_OS -import DriverUtil( handle ) +import Util ( handle ) import System.Posix #if __GLASGOW_HASKELL__ > 504 hiding (getEnv) @@ -53,7 +55,7 @@ import System.Console.Readline as Readline import Control.Exception as Exception import Data.Dynamic -import Control.Concurrent +-- import Control.Concurrent import Numeric import Data.List @@ -61,13 +63,16 @@ import Data.Int ( Int64 ) import System.Cmd import System.CPUTime import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) import System.Directory -import System.IO as IO +import System.IO +import System.IO.Error as IO import Data.Char import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) +import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) @@ -151,10 +156,8 @@ helpText = " (eg. -v2, -fglasgow-exts, etc.)\n" -interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO () -interactiveUI dflags srcs maybe_expr = do - - cmstate <- cmInit Interactive dflags; +interactiveUI :: Session -> [FilePath] -> Maybe String -> IO () +interactiveUI session srcs maybe_expr = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block @@ -172,24 +175,23 @@ interactiveUI dflags srcs maybe_expr = do hSetBuffering stdout NoBuffering -- Initialise buffering for the *interpreted* I/O system - initInterpBuffering cmstate + initInterpBuffering session -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -- initial context is just the Prelude - cmstate <- cmSetContext cmstate [] ["Prelude"] + GHC.setContext session [] [prelude_mod] #ifdef USE_READLINE Readline.initialize #endif - startGHCi (runGHCi srcs dflags maybe_expr) + startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], - targets = srcs, - cmstate = cmstate, + session = session, options = [] } #ifdef USE_READLINE @@ -198,9 +200,9 @@ interactiveUI dflags srcs maybe_expr = do return () -runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi () -runGHCi paths dflags maybe_expr = do - read_dot_files <- io (readIORef v_Read_DotGHCi) +runGHCi :: [FilePath] -> Maybe String -> GHCi () +runGHCi paths maybe_expr = do + let read_dot_files = not opt_IgnoreDotGhci when (read_dot_files) $ do -- Read in ./.ghci. @@ -239,6 +241,7 @@ runGHCi paths dflags maybe_expr = do -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. is_tty <- io (hIsTerminalDevice stdin) + dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty case maybe_expr of @@ -247,7 +250,7 @@ runGHCi paths dflags maybe_expr = do interactiveLoop is_tty show_prompt Just expr -> do -- just evaluate the expression we were given - runCommand expr + runCommandEval expr return () -- and finally, exit @@ -284,7 +287,7 @@ checkPerms name = #ifdef mingw32_HOST_OS return True #else - DriverUtil.handle (\_ -> return False) $ do + Util.handle (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID if fileOwner st /= me then do @@ -303,15 +306,21 @@ checkPerms name = fileLoop :: Handle -> Bool -> GHCi () fileLoop hdl prompt = do - cmstate <- getCmState - (mod,imports) <- io (cmGetContext cmstate) + session <- getSession + (mod,imports) <- io (GHC.getContext session) when prompt (io (putStr (mkPrompt mod imports))) l <- io (IO.try (hGetLine hdl)) case l of - Left e | isEOFError e -> return () - | otherwise -> io (ioError e) + Left e | isEOFError e -> return () + | InvalidArgument <- etype -> return () + | otherwise -> io (ioError e) + where etype = ioeGetErrorType e + -- treat InvalidArgument in the same way as EOF: + -- this can happen if the user closed stdin, or + -- perhaps did getContents which closes stdin at + -- EOF. Right l -> - case remove_spaces l of + case removeSpaces l of "" -> fileLoop hdl prompt l -> do quit <- runCommand l if quit then return () else fileLoop hdl prompt @@ -319,19 +328,21 @@ fileLoop hdl prompt = do stringLoop :: [String] -> GHCi () stringLoop [] = return () stringLoop (s:ss) = do - case remove_spaces s of + case removeSpaces s of "" -> stringLoop ss l -> do quit <- runCommand l if quit then return () else stringLoop ss mkPrompt toplevs exports - = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> " + = showSDoc (hsep (map (\m -> char '*' <> pprModule m) toplevs) + <+> hsep (map pprModule exports) + <> text "> ") #ifdef USE_READLINE readlineLoop :: GHCi () readlineLoop = do - cmstate <- getCmState - (mod,imports) <- io (cmGetContext cmstate) + session <- getSession + (mod,imports) <- io (GHC.getContext session) io yield l <- io (readline (mkPrompt mod imports) `finally` setNonBlockingFD 0) @@ -340,7 +351,7 @@ readlineLoop = do case l of Nothing -> return () Just l -> - case remove_spaces l of + case removeSpaces l of "" -> readlineLoop l -> do io (addHistory l) @@ -351,6 +362,15 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle handler (doCommand c) +-- This version is for the GHC command-line option -e. The only difference +-- from runCommand is that it catches the ExitException exception and +-- exits, rather than printing out the exception. +runCommandEval c = ghciHandle handleEval (doCommand c) + where + handleEval (ExitException code) = io (exitWith code) + handleEval e = do showException e + io (exitWith (ExitFailure 1)) + -- This is the exception handler for exceptions generated by the -- user's code; it normally just prints out the exception. The -- handler must be recursive, in case showing the exception causes @@ -387,21 +407,19 @@ runStmt stmt | null (filter (not.isSpace) stmt) = return [] | otherwise = do st <- getGHCiState - cmstate <- getCmState - (new_cmstate, result) <- - io $ withProgName (progname st) $ withArgs (args st) $ - cmRunStmt cmstate stmt - setGHCiState st{cmstate = new_cmstate} + session <- getSession + result <- io $ withProgName (progname st) $ withArgs (args st) $ + GHC.runStmt session stmt case result of - CmRunFailed -> return [] - CmRunException e -> showException e >> return [] - CmRunOk names -> return names + GHC.RunFailed -> return [] + GHC.RunException e -> throw e -- this is caught by runCommand(Eval) + GHC.RunOk names -> return names -- possibly print the type and revert CAFs after evaluating an expression finishEvalExpr names = do b <- isOptionSet ShowType - cmstate <- getCmState - when b (mapM_ (showTypeOfName cmstate) names) + session <- getSession + when b (mapM_ (showTypeOfName session) names) flushInterpBuffers io installSignalHandlers @@ -409,12 +427,18 @@ finishEvalExpr names io (when b revertCAFs) return True -showTypeOfName :: CmState -> Name -> GHCi () -showTypeOfName cmstate n - = do maybe_str <- io (cmTypeOfName cmstate n) - case maybe_str of - Nothing -> return () - Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str)) +showTypeOfName :: Session -> Name -> GHCi () +showTypeOfName session n + = do maybe_tything <- io (GHC.lookupName session n) + case maybe_tything of + Nothing -> return () + Just thing -> showTyThing thing + +showForUser :: SDoc -> GHCi String +showForUser doc = do + session <- getSession + unqual <- io (GHC.getPrintUnqual session) + return $! showSDocForUser unqual doc specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) @@ -440,19 +464,19 @@ noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments")) GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) -no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ - " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" -flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" +no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ + " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" +flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr" -initInterpBuffering :: CmState -> IO () -initInterpBuffering cmstate - = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd +initInterpBuffering :: Session -> IO () +initInterpBuffering session + = do maybe_hval <- GHC.compileExpr session no_buf_cmd case maybe_hval of Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) other -> panic "interactiveUI:setBuffering" - maybe_hval <- cmCompileExpr cmstate flush_cmd + maybe_hval <- GHC.compileExpr session flush_cmd case maybe_hval of Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" @@ -481,19 +505,21 @@ help _ = io (putStr helpText) info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s - ; init_cms <- getCmState - ; mapM_ (infoThing init_cms) names } + ; session <- getSession + ; dflags <- getDynFlags + ; let exts = dopt Opt_GlasgowExts dflags + ; mapM_ (infoThing exts session) names } where - infoThing cms name - = do { stuff <- io (cmGetInfo cms name) - ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ - vcat (intersperse (text "") (map showThing stuff)))) } - -showThing :: GetInfoResult -> SDoc -showThing (wanted_str, (thing, fixity, src_loc, insts)) - = vcat [ showDecl want_name thing, + infoThing exts session name + = do { stuff <- io (GHC.getInfo session name) + ; unqual <- io (GHC.getPrintUnqual session) + ; io (putStrLn (showSDocForUser unqual $ + vcat (intersperse (text "") (map (showThing exts) stuff)))) } + +showThing :: Bool -> GHC.GetInfoResult -> SDoc +showThing exts (wanted_str, thing, fixity, src_loc, insts) + = vcat [ showWithLoc src_loc (showDecl exts want_name thing), show_fixity fixity, - show_loc src_loc, vcat (map show_inst insts)] where want_name occ = wanted_str == occNameUserString occ @@ -502,31 +528,35 @@ showThing (wanted_str, (thing, fixity, src_loc, insts)) | fix == defaultFixity = empty | otherwise = ppr fix <+> text wanted_str + show_inst (inst_ty, loc) + = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty) + +showWithLoc :: SrcLoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> show_loc loc) + -- The tab tries to make them line up a bit + where show_loc loc -- The ppr function for SrcLocs is a bit wonky | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc | otherwise = comment <+> ppr loc comment = ptext SLIT("--") - show_inst (iface_inst, loc) - = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst)) - 2 (char '\t' <> show_loc loc) - -- The tab tries to make them line up a bit -- Now there is rather a lot of goop just to print declarations in a -- civilised way with "..." for the parts we are less interested in. -showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc -showDecl want_name (IfaceForeign {ifName = tc}) +showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc +showDecl exts want_name (IfaceForeign {ifName = tc}) = ppr tc <+> ptext SLIT("is a foreign type") -showDecl want_name (IfaceId {ifName = var, ifType = ty}) - = ppr var <+> dcolon <+> ppr ty +showDecl exts want_name (IfaceId {ifName = var, ifType = ty}) + = ppr var <+> dcolon <+> showIfaceType exts ty -showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) +showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 2 (equals <+> ppr mono_ty) -showDecl want_name (IfaceData {ifName = tycon, +showDecl exts want_name (IfaceData {ifName = tycon, ifTyVars = tyvars, ifCons = condecls}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) @@ -573,15 +603,23 @@ showDecl want_name (IfaceData {ifName = tycon, ppr_str MarkedUnboxed = ptext SLIT("!!") ppr_str NotMarkedStrict = empty -showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, +showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs}) = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars - <+> pprFundeps fds <+> ptext SLIT("where")) + <+> pprFundeps fds <+> opt_where) 2 (vcat (ppr_trim show_op sigs)) where + opt_where | null sigs = empty + | otherwise = ptext SLIT("where") show_op (IfaceClassOp op dm ty) - | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty) - | otherwise = Nothing + | want_name clas || want_name op + = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty) + | otherwise + = Nothing + +showIfaceType :: Bool -> IfaceType -> SDoc +showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls +showIfaceType False ty = ppr ty -- otherwise, print without the foralls ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] ppr_trim show xs @@ -594,8 +632,7 @@ ppr_trim show xs ppr_bndr :: OccName -> SDoc -- Wrap operators in () -ppr_bndr occ | isSymOcc occ = parens (ppr occ) - | otherwise = ppr occ +ppr_bndr occ = parenSymOcc occ (ppr occ) ----------------------------------------------------------------------------- @@ -603,25 +640,24 @@ ppr_bndr occ | isSymOcc occ = parens (ppr occ) addModule :: [FilePath] -> GHCi () addModule files = do - state <- getGHCiState io (revertCAFs) -- always revert CAFs on load/add. files <- mapM expandPath files - let new_targets = files ++ targets state - graph <- io (cmDepAnal (cmstate state) new_targets) - (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph) - setGHCiState state{ cmstate = cmstate1, targets = new_targets } - setContextAfterLoad mods - dflags <- getDynFlags - modulesLoadedMsg ok mods dflags + targets <- mapM (io . GHC.guessTarget) files + session <- getSession + io (mapM_ (GHC.addTarget session) targets) + ok <- io (GHC.load session Nothing) + afterLoad ok session changeDirectory :: String -> GHCi () changeDirectory dir = do - state <- getGHCiState - when (targets state /= []) $ + session <- getSession + graph <- io (GHC.getModuleGraph session) + when (not (null graph)) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" - cmstate1 <- io (cmUnload (cmstate state)) - setGHCiState state{ cmstate = cmstate1, targets = [] } + io (GHC.setTargets session []) + io (GHC.load session Nothing) setContextAfterLoad [] + io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -642,14 +678,14 @@ defineMacro s = do let new_expr = '(' : definition ++ ") :: String -> IO String" -- compile the expression - cms <- getCmState - maybe_hv <- io (cmCompileExpr cms new_expr) + cms <- getSession + maybe_hv <- io (GHC.compileExpr cms new_expr) case maybe_hv of Nothing -> return () Just hv -> io (writeIORef commands -- ((macro_name, keepGoing (runMacro hv)) : cmds)) -runMacro :: HValue{-String -> IO String-} -> String -> GHCi () +runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi () runMacro fun s = do str <- io ((unsafeCoerce# fun :: String -> IO String) s) stringLoop (lines str) @@ -673,60 +709,58 @@ loadModule fs = timeIt (loadModule' fs) loadModule' :: [FilePath] -> GHCi () loadModule' files = do - state <- getGHCiState + session <- getSession + + -- unload first + io (GHC.setTargets session []) + io (GHC.load session Nothing) -- expand tildes files <- mapM expandPath files + targets <- io (mapM GHC.guessTarget files) - -- do the dependency anal first, so that if it fails we don't throw - -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) files) - - -- Dependency anal ok, now unload everything - cmstate1 <- io (cmUnload (cmstate state)) - setGHCiState state{ cmstate = cmstate1, targets = [] } + -- NOTE: we used to do the dependency anal first, so that if it + -- fails we didn't throw away the current set of modules. This would + -- require some re-working of the GHC interface, so we'll leave it + -- as a ToDo for now. - io (revertCAFs) -- always revert CAFs on load. - (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph) - setGHCiState state{ cmstate = cmstate2, targets = files } - - setContextAfterLoad mods - dflags <- getDynFlags - modulesLoadedMsg ok mods dflags + io (GHC.setTargets session targets) + ok <- io (GHC.load session Nothing) + afterLoad ok session reloadModule :: String -> GHCi () reloadModule "" = do - state <- getGHCiState - case targets state of - [] -> io (putStr "no current target\n") - paths -> do - -- do the dependency anal first, so that if it fails we don't throw - -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) paths) - - io (revertCAFs) -- always revert CAFs on reload. - (cmstate1, ok, mods) - <- io (cmLoadModules (cmstate state) graph) - setGHCiState state{ cmstate=cmstate1 } - setContextAfterLoad mods - dflags <- getDynFlags - modulesLoadedMsg ok mods dflags - + io (revertCAFs) -- always revert CAFs on reload. + session <- getSession + ok <- io (GHC.load session Nothing) + afterLoad ok session reloadModule _ = noArgs ":reload" -setContextAfterLoad [] = setContext prel +afterLoad ok session = do + io (revertCAFs) -- always revert CAFs on load. + graph <- io (GHC.getModuleGraph session) + let mods = map GHC.ms_mod graph + setContextAfterLoad mods + modulesLoadedMsg ok mods + +setContextAfterLoad [] = do + session <- getSession + io (GHC.setContext session [] [prelude_mod]) setContextAfterLoad (m:_) = do - cmstate <- getCmState - b <- io (cmModuleIsInterpreted cmstate m) - if b then setContext ('*':m) else setContext m + session <- getSession + b <- io (GHC.moduleIsInterpreted session m) + if b then io (GHC.setContext session [m] []) + else io (GHC.setContext session [] [m]) -modulesLoadedMsg ok mods dflags = +modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi () +modulesLoadedMsg ok mods = do + dflags <- getDynFlags when (verbosity dflags > 0) $ do let mod_commas | null mods = text "none." | otherwise = hsep ( - punctuate comma (map text mods)) <> text "." + punctuate comma (map pprModule mods)) <> text "." case ok of Failed -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) @@ -736,19 +770,22 @@ modulesLoadedMsg ok mods dflags = typeOfExpr :: String -> GHCi () typeOfExpr str - = do cms <- getCmState - maybe_tystr <- io (cmTypeOfExpr cms str) - case maybe_tystr of - Nothing -> return () - Just tystr -> io (putStrLn tystr) + = do cms <- getSession + maybe_ty <- io (GHC.exprType cms str) + case maybe_ty of + Nothing -> return () + Just ty -> do ty' <- cleanType ty + tystr <- showForUser (ppr ty') + io (putStrLn (str ++ " :: " ++ tystr)) kindOfType :: String -> GHCi () kindOfType str - = do cms <- getCmState - maybe_tystr <- io (cmKindOfType cms str) - case maybe_tystr of + = do cms <- getSession + maybe_ty <- io (GHC.typeKind cms str) + case maybe_ty of Nothing -> return () - Just tystr -> io (putStrLn tystr) + Just ty -> do tystr <- showForUser (ppr ty) + io (putStrLn (str ++ " :: " ++ tystr)) quit :: String -> GHCi Bool quit _ = return True @@ -767,25 +804,27 @@ browseCmd m = _ -> throwDyn (CmdLineError "syntax: :browse ") browseModule m exports_only = do - cms <- getCmState + s <- getSession - is_interpreted <- io (cmModuleIsInterpreted cms m) + let modl = mkModule m + is_interpreted <- io (GHC.moduleIsInterpreted s modl) when (not is_interpreted && not exports_only) $ throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified - (as,bs) <- io (cmGetContext cms) - cms1 <- io (if exports_only then cmSetContext cms [] [prel,m] - else cmSetContext cms [m] []) - cms2 <- io (cmSetContext cms1 as bs) + (as,bs) <- io (GHC.getContext s) + io (if exports_only then GHC.setContext s [] [prelude_mod,modl] + else GHC.setContext s [modl] []) + io (GHC.setContext s as bs) - things <- io (cmBrowseModule cms2 m exports_only) - - let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context + things <- io (GHC.browseModule s modl exports_only) + unqual <- io (GHC.getPrintUnqual s) + dflags <- getDynFlags + let exts = dopt Opt_GlasgowExts dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl (const True)) things) + vcat (map (showDecl exts (const True)) things) ))) ----------------------------------------------------------------------------- @@ -804,47 +843,46 @@ setContext str sensible m = looksLikeModuleName m newContext mods = do - cms <- getCmState - (as,bs) <- separate cms mods [] [] - let bs' = if null as && prel `notElem` bs then prel:bs else bs - cms' <- io (cmSetContext cms as bs') - setCmState cms' - -separate cmstate [] as bs = return (as,bs) -separate cmstate (('*':m):ms) as bs = do - b <- io (cmModuleIsInterpreted cmstate m) - if b then separate cmstate ms (m:as) bs + session <- getSession + (as,bs) <- separate session mods [] [] + let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs + io (GHC.setContext session as bs') + +separate :: Session -> [String] -> [Module] -> [Module] + -> GHCi ([Module],[Module]) +separate session [] as bs = return (as,bs) +separate session (('*':m):ms) as bs = do + let modl = mkModule m + b <- io (GHC.moduleIsInterpreted session modl) + if b then separate session ms (modl:as) bs else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) -separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs) +separate session (m:ms) as bs = separate session ms as (mkModule m:bs) -prel = "Prelude" +prelude_mod = mkModule "Prelude" addToContext mods = do - cms <- getCmState - (as,bs) <- io (cmGetContext cms) + cms <- getSession + (as,bs) <- io (GHC.getContext cms) (as',bs') <- separate cms mods [] [] let as_to_add = as' \\ (as ++ bs) bs_to_add = bs' \\ (as ++ bs) - cms' <- io (cmSetContext cms - (as ++ as_to_add) (bs ++ bs_to_add)) - setCmState cms' + io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add)) removeFromContext mods = do - cms <- getCmState - (as,bs) <- io (cmGetContext cms) + cms <- getSession + (as,bs) <- io (GHC.getContext cms) (as_to_remove,bs_to_remove) <- separate cms mods [] [] let as' = as \\ (as_to_remove ++ bs_to_remove) bs' = bs \\ (as_to_remove ++ bs_to_remove) - cms' <- io (cmSetContext cms as' bs') - setCmState cms' + io (GHC.setContext cms as' bs') ---------------------------------------------------------------------------- -- Code for `:set' @@ -887,12 +925,9 @@ setOptions wds = let (plus_opts, minus_opts) = partition isPlus wds mapM_ setOpt plus_opts - -- now, the GHC flags - leftovers <- io $ processStaticFlags minus_opts - -- then, dynamic flags dflags <- getDynFlags - (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags + (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts setDynFlags dflags' -- update things if the users wants more packages @@ -953,13 +988,15 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" +{- ToDo newPackages new_pkgs = do -- The new packages are already in v_Packages - state <- getGHCiState - cmstate1 <- io (cmUnload (cmstate state)) - setGHCiState state{ cmstate = cmstate1, targets = [] } + session <- getSession + io (GHC.setTargets session []) + io (GHC.load session Nothing) dflags <- getDynFlags io (linkPackages dflags new_pkgs) setContextAfterLoad [] +-} -- --------------------------------------------------------------------------- -- code for `:show' @@ -972,32 +1009,32 @@ showCmd str = _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") showModules = do - cms <- getCmState - let (mg, hpt) = cmGetModInfo cms - mapM_ (showModule hpt) mg - - -showModule :: HomePackageTable -> ModSummary -> GHCi () -showModule hpt mod_summary - = case lookupModuleEnv hpt mod of - Nothing -> panic "missing linkable" - Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn)) - where - obj_linkable = isObjectLinkable (hm_linkable mod_info) - where - mod = ms_mod mod_summary - locn = ms_location mod_summary + session <- getSession + let show_one ms = do m <- io (GHC.showModule session ms) + io (putStrLn m) + graph <- io (GHC.getModuleGraph session) + mapM_ show_one graph showBindings = do - cms <- getCmState - let - unqual = cmGetPrintUnqual cms --- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b))) - showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b))) - - io (mapM_ showBinding (cmGetBindings cms)) + s <- getSession + unqual <- io (GHC.getPrintUnqual s) + bindings <- io (GHC.getBindings s) + mapM_ showTyThing bindings return () +showTyThing (AnId id) = do + ty' <- cleanType (GHC.idType id) + str <- showForUser (ppr id <> text " :: " <> ppr ty') + io (putStrLn str) +showTyThing _ = return () + +-- if -fglasgow-exts is on we show the foralls, otherwise we don't. +cleanType :: Type -> GHCi Type +cleanType ty = do + dflags <- getDynFlags + if dopt Opt_GlasgowExts dflags + then return ty + else return $! GHC.dropForAlls ty ----------------------------------------------------------------------------- -- GHCi monad @@ -1006,8 +1043,7 @@ data GHCiState = GHCiState { progname :: String, args :: [String], - targets :: [FilePath], - cmstate :: CmState, + session :: GHC.Session, options :: [GHCiOption] } @@ -1034,12 +1070,14 @@ getGHCiState = GHCi $ \r -> readIORef r setGHCiState s = GHCi $ \r -> writeIORef r s -- for convenience... -getCmState = getGHCiState >>= return . cmstate -setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms} - -getDynFlags = getCmState >>= return . cmGetDFlags - -setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags) +getSession = getGHCiState >>= return . session + +getDynFlags = do + s <- getSession + io (GHC.getSessionDynFlags s) +setDynFlags dflags = do + s <- getSession + io (GHC.setSessionDynFlags s dflags) isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt