+-----------------------------------------------------------------------------
+-- 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 (isDataConId id || isDataConWrapId id)
+ 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'
+