+quit :: String -> GHCi Bool
+quit _ = return True
+
+shellEscape :: String -> GHCi Bool
+shellEscape str = io (system str >> return False)
+
+-----------------------------------------------------------------------------
+-- Browing a module's contents
+
+browseCmd :: String -> GHCi ()
+browseCmd m =
+ case words m of
+ ['*':m] | looksLikeModuleName m -> browseModule m False
+ [m] | looksLikeModuleName m -> browseModule m True
+ _ -> throwDyn (CmdLineError "syntax: :browse <module>")
+
+browseModule m exports_only = do
+ cms <- getCmState
+ dflags <- io getDynFlags
+
+ is_interpreted <- io (cmModuleIsInterpreted cms m)
+ 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 dflags [] [prel,m]
+ else cmSetContext cms dflags [m] [])
+ cms2 <- io (cmSetContext cms1 dflags as bs)
+
+ (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
+
+ setCmState cms3
+
+ let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
+
+ things' = filter wantToSee things
+
+ wantToSee (AnId id) = not (isImplicitId id)
+ wantToSee (ADataCon _) = False -- They'll come via their TyCon
+ wantToSee _ = True
+
+ thing_names = map getName things
+
+ thingDecl thing@(AnId id) = ifaceTyThing thing
+
+ thingDecl thing@(AClass c) =
+ let rn_decl = ifaceTyThing thing in
+ case rn_decl of
+ ClassDecl { tcdSigs = cons } ->
+ rn_decl{ tcdSigs = filter methodIsVisible cons }
+ other -> other
+ where
+ methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
+
+ thingDecl thing@(ATyCon t) =
+ let rn_decl = ifaceTyThing thing in
+ case rn_decl of
+ TyData { tcdCons = DataCons cons } ->
+ rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
+ other -> other
+ where
+ conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
+
+ io (putStrLn (showSDocForUser unqual (
+ vcat (map (ppr . thingDecl) things')))
+ )
+
+ where
+
+-----------------------------------------------------------------------------
+-- Setting the module context
+
+setContext str
+ | all sensible mods = fn mods
+ | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ where
+ (fn, mods) = case str of
+ '+':stuff -> (addToContext, words stuff)
+ '-':stuff -> (removeFromContext, words stuff)
+ stuff -> (newContext, words stuff)
+
+ sensible ('*':m) = looksLikeModuleName m
+ sensible m = looksLikeModuleName m
+
+newContext mods = do
+ cms <- getCmState
+ dflags <- io getDynFlags
+ (as,bs) <- separate cms mods [] []
+ let bs' = if null as && prel `notElem` bs then prel:bs else bs
+ cms' <- io (cmSetContext cms dflags 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
+ else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
+separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
+
+prel = "Prelude"
+
+
+addToContext mods = do
+ cms <- getCmState
+ dflags <- io getDynFlags
+ (as,bs) <- io (cmGetContext cms)
+
+ (as',bs') <- separate cms mods [] []
+
+ let as_to_add = as' \\ (as ++ bs)
+ bs_to_add = bs' \\ (as ++ bs)
+
+ cms' <- io (cmSetContext cms dflags
+ (as ++ as_to_add) (bs ++ bs_to_add))
+ setCmState cms'
+
+
+removeFromContext mods = do
+ cms <- getCmState
+ dflags <- io getDynFlags
+ (as,bs) <- io (cmGetContext 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 dflags as' bs')
+ setCmState cms'
+
+----------------------------------------------------------------------------
+-- Code for `:set'
+
+-- set options in the interpreter. Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected. ToDo:
+-- figure out which ones & disallow them.
+
+setCmd :: String -> GHCi ()
+setCmd ""
+ = do st <- getGHCiState
+ let opts = options st
+ io $ putStrLn (showSDoc (
+ text "options currently set: " <>
+ if null opts
+ then text "none."
+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
+ ))
+setCmd str
+ = case words str of
+ ("args":args) -> setArgs args
+ ("prog":prog) -> setProg prog
+ wds -> setOptions wds
+
+setArgs args = do
+ st <- getGHCiState
+ setGHCiState st{ args = args }
+
+setProg [prog] = do
+ st <- getGHCiState
+ setGHCiState st{ progname = prog }
+setProg _ = do
+ io (hPutStrLn stderr "syntax: :set prog <progname>")
+
+setOptions wds =
+ do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let (plus_opts, minus_opts) = partition isPlus wds
+ mapM_ setOpt plus_opts
+
+ -- now, the GHC flags
+ pkgs_before <- io (readIORef v_ExplicitPackages)
+ leftovers <- io (processArgs static_flags minus_opts [])
+ pkgs_after <- io (readIORef v_ExplicitPackages)
+
+ -- update things if the users wants more packages
+ let new_packages = pkgs_after \\ pkgs_before
+ when (not (null new_packages)) $
+ newPackages new_packages
+
+ -- don't forget about the extra command-line flags from the
+ -- extra_ghc_opts fields in the new packages
+ new_package_details <- io (getPackageDetails new_packages)
+ let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
+ pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
+
+ -- then, dynamic flags
+ io $ do
+ restoreDynFlags
+ leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
+ saveDynFlags
+
+ if (not (null leftovers))
+ then throwDyn (CmdLineError ("unrecognised flags: " ++
+ unwords leftovers))
+ else return ()
+
+
+unsetOptions :: String -> GHCi ()
+unsetOptions str
+ = do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let opts = words str
+ (minus_opts, rest1) = partition isMinus opts
+ (plus_opts, rest2) = partition isPlus rest1
+
+ if (not (null rest2))
+ then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
+ else do
+
+ mapM_ unsetOpt plus_opts
+
+ -- can't do GHC flags for now
+ if (not (null minus_opts))
+ then throwDyn (CmdLineError "can't unset GHC command-line flags")
+ else return ()
+
+isMinus ('-':s) = True
+isMinus _ = False
+
+isPlus ('+':s) = True
+isPlus _ = False
+
+setOpt ('+':str)
+ = case strToGHCiOpt str of
+ Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
+ Just o -> setOption o
+
+unsetOpt ('+':str)
+ = case strToGHCiOpt str of
+ Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
+ Just o -> unsetOption o
+
+strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "s" = Just ShowTiming
+strToGHCiOpt "t" = Just ShowType
+strToGHCiOpt "r" = Just RevertCAFs
+strToGHCiOpt _ = Nothing
+
+optToStr :: GHCiOption -> String
+optToStr ShowTiming = "s"
+optToStr ShowType = "t"
+optToStr RevertCAFs = "r"
+
+newPackages new_pkgs = do -- The new packages are already in v_Packages
+ state <- getGHCiState
+ dflags <- io getDynFlags
+ cmstate1 <- io (cmUnload (cmstate state) dflags)
+ setGHCiState state{ cmstate = cmstate1, targets = [] }
+ io (linkPackages dflags new_pkgs)
+ setContextAfterLoad []
+
+-- ---------------------------------------------------------------------------
+-- code for `:show'
+
+showCmd str =
+ case words str of
+ ["modules" ] -> showModules
+ ["bindings"] -> showBindings
+ ["linker"] -> io showLinkerState
+ _ -> 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
+
+showBindings = do
+ cms <- getCmState
+ let
+ unqual = cmGetPrintUnqual cms
+ showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
+
+ io (mapM_ showBinding (cmGetBindings cms))
+ return ()