--
-----------------------------------------------------------------------------
-module Debugger (pprintClosureCommand) where
+module Debugger (pprintClosureCommand, showTerm) where
import Linker
import RtClosureInspect
mapM (\w -> GHC.parseName session w >>=
mapM (GHC.lookupName session))
(words str)
- substs <- catMaybes `liftM` mapM (go session)
- [id | AnId id <- tythings]
- modifySession session $ \hsc_env ->
- hsc_env{hsc_IC = foldr (flip substInteractiveContext)
- (hsc_IC hsc_env)
+ let ids = [id | AnId id <- tythings]
+
+ -- Obtain the terms and the recovered type information
+ (terms, substs) <- unzip `liftM` mapM (go session) ids
+
+ -- Apply the substitutions obtained after recovering the types
+ modifySession session $ \hsc_env ->
+ hsc_env{hsc_IC = foldr (flip substInteractiveContext)
+ (hsc_IC hsc_env)
(map skolemiseSubst substs)}
- where
+ -- Finally, print the Terms
+ unqual <- GHC.getPrintUnqual session
+ let showSDocForUserOneLine unqual doc =
+ showDocWith LeftMode (doc (mkErrStyle unqual))
+ docterms <- mapM (showTerm session) terms
+ (putStrLn . showSDocForUserOneLine unqual . vcat)
+ (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
+ ids
+ docterms)
+ where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
- go :: Session -> Id -> IO (Maybe TvSubst)
- go cms id = do
- term_ <- withSession cms $ \hsc_env -> obtainTerm hsc_env force id
+ go :: Session -> Id -> IO (Term, TvSubst)
+ go cms id = do
+ term_ <- GHC.obtainTerm cms force id
term <- tidyTermTyVars cms term_
- term' <- if not bindThings then return term
- else bindSuspensions cms term
- showterm <- printTerm cms term'
- unqual <- GHC.getPrintUnqual cms
- let showSDocForUserOneLine unqual doc =
- showDocWith LeftMode (doc (mkErrStyle unqual))
- (putStrLn . showSDocForUserOneLine unqual)
- (ppr id <+> char '=' <+> showterm)
+ term' <- if not bindThings then return term
+ else bindSuspensions cms term
-- Before leaving, we compare the type obtained to see if it's more specific
- -- Then, we extract a substitution,
+ -- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let Just reconstructed_type = termType term
- mb_subst = computeRTTIsubst (idType id) (reconstructed_type)
-
- ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id))
- return mb_subst
+ Just subst = computeRTTIsubst (idType id) (reconstructed_type)
+ return (term',subst)
tidyTermTyVars :: Session -> Term -> IO Term
tidyTermTyVars (Session ref) t = do
pred (GHC.resumeSpan $ head resumes) -> do
printForUser $ ptext SLIT("Stopped at") <+>
ppr (GHC.resumeSpan $ head resumes)
- printTypeOfNames session names
+-- printTypeOfNames session names
+ printTypeAndContentOfNames session names
maybe (return ()) runBreakCmd mb_info
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
return (case run_result of GHC.RunOk _ -> True; _ -> False)
+ where printTypeAndContentOfNames session names = do
+ let namesSorted = sortBy compareNames names
+ tythings <- catMaybes `liftM`
+ io (mapM (GHC.lookupName session) names)
+ docs_ty <- mapM showTyThing tythings
+ terms <- mapM (io . GHC.obtainTerm session False)
+ [ id | (AnId id, Just _) <- zip tythings docs_ty]
+ docs_terms <- mapM (io . showTerm session) terms
+ printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts)
+ (catMaybes docs_ty)
+ docs_terms
+
runBreakCmd :: GHC.BreakInfo -> GHCi ()
runBreakCmd info = do
let mod = GHC.breakInfo_module info
compareTyThings :: TyThing -> TyThing -> Ordering
t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
-printTyThing :: TyThing -> GHCi ()
-printTyThing (AnId id) = do
+showTyThing :: TyThing -> GHCi (Maybe SDoc)
+showTyThing (AnId id) = do
ty' <- cleanType (GHC.idType id)
- printForUser $ ppr id <> text " :: " <> ppr ty'
-printTyThing _ = return ()
+ return $ Just $ ppr id <> text " :: " <> ppr ty'
+showTyThing _ = return Nothing
+
+printTyThing :: TyThing -> GHCi ()
+printTyThing tyth = do
+ mb_x <- showTyThing tyth
+ case mb_x of
+ Just x -> printForUser x
+ Nothing -> return ()
-- if -fglasgow-exts is on we show the foralls, otherwise we don't.
cleanType :: Type -> GHCi Type
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1,
+ GHC.obtainTerm, GHC.obtainTerm1, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
getHistorySpan :: Session -> History -> IO SrcSpan
getHistorySpan sess h = withSession sess $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
+
+obtainTerm :: Session -> Bool -> Id -> IO Term
+obtainTerm sess force id = withSession sess $ \hsc_env ->
+ InteractiveEval.obtainTerm hsc_env force id
+
+obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
+obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env ->
+ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
#endif
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1, reconstructType,
+ Term(..), obtainTerm, obtainTerm1, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where