--------------------------------------------------------------------------------- GHCi Interactive debugging commands ---- Pepe Iborra (supported by Google SoC) 2006---- ToDo: lots of violation of layering here. This module should-- decide whether it is above the GHC API (import GHC and nothing-- else) or below it.-- -----------------------------------------------------------------------------moduleDebugger(pprintClosureCommand,showTerm,pprTypeAndContents)whereimportLinkerimportRtClosureInspectimportGhcMonadimportHscTypesimportIdimportNameimportVarhiding(varName)importVarSetimportUniqSupplyimportTcTypeimportGHCimportOutputableimportPprTyThingimportMonadUtilsimportDynFlagsimportExceptionimportControl.MonadimportData.ListimportData.MaybeimportData.IORefimportGHC.Exts--------------------------------------- | The :print & friends commands-------------------------------------pprintClosureCommand::GhcMonadm=>Bool->Bool->String->m()pprintClosureCommandbindThingsforcestr=dotythings<-(catMaybes.concat)`liftM`mapM(\w->GHC.parseNamew>>=mapMGHC.lookupName)(wordsstr)letids=[id|AnIdid<-tythings]-- Obtain the terms and the recovered type information(subst,terms)<-mapAccumLMgoemptyTvSubstids-- Apply the substitutions obtained after recovering the typesmodifySession$\hsc_env->hsc_env{hsc_IC=substInteractiveContext(hsc_IChsc_env)subst}-- Finally, print the Termsunqual<-GHC.getPrintUnqualdocterms<-mapMshowTermtermsdflags<-getDynFlagsliftIO$(printOutputForUserdflagsunqual.vcat)(zipWith(\iddocterm->pprid<+>char'='<+>docterm)idsdocterms)where-- Do the obtainTerm--bindSuspensions-computeSubstitution dancego::GhcMonadm=>TvSubst->Id->m(TvSubst,Term)gosubstid=doletid'=id`setIdType`substTysubst(idTypeid)term_<-GHC.obtainTermFromIdmaxBoundforceid'term<-tidyTermTyVarsterm_term'<-ifbindThings&&False==isUnliftedTypeKind(termTypeterm)thenbindSuspensionstermelsereturnterm-- Before leaving, we compare the type obtained to see if it's more specific-- Then, we extract a substitution,-- mapping the old tyvars to the reconstructed types.letreconstructed_type=termTypetermhsc_env<-getSessioncase(improveRTTITypehsc_env(idTypeid)(reconstructed_type))ofNothing->return(subst,term')Justsubst'->do{traceOptIfOpt_D_dump_rtti(fsep$[text"RTTI Improvement for",pprid,text"is the substitution:",pprsubst']);return(subst`unionTvSubst`subst',term')}tidyTermTyVars::GhcMonadm=>Term->mTermtidyTermTyVarst=withSession$\hsc_env->doletenv_tvs=tyThingsTyVars$ic_tythings$hsc_IChsc_envmy_tvs=termTyVarsttvs=env_tvs`minusVarSet`my_tvstyvarOccName=nameOccName.tyVarNametidyEnv=(initTidyOccEnv(maptyvarOccName(varSetElemstvs)),env_tvs`intersectVarSet`my_tvs)return$mapTermType(snd.tidyOpenTypetidyEnv)t-- | Give names, and bind in the interactive environment, to all the suspensions-- included (inductively) in a termbindSuspensions::GhcMonadm=>Term->mTermbindSuspensionst=dohsc_env<-getSessioninScope<-GHC.getBindingsletictxt=hsc_IChsc_envprefix="_t"alreadyUsedNames=map(occNameString.nameOccName.getName)inScopeavailNames=map((prefix++).show)[(1::Int)..]\\alreadyUsedNamesavailNames_var<-liftIO$newIORefavailNames(t',stuff)<-liftIO$foldTerm(nameSuspensionsAndGetInfosavailNames_var)tlet(names,tys,hvals)=unzip3stuffletids=[mkVanillaGlobalnamety|(name,ty)<-zipnamestys]new_ic=extendInteractiveContextictxt(mapAnIdids)liftIO$extendLinkEnv(zipnameshvals)modifySession$\_->hsc_env{hsc_IC=new_ic}returnt'where-- Processing suspensions. Give names and recopilate infonameSuspensionsAndGetInfos::IORef[String]->TermFold(IO(Term,[(Name,Type,HValue)]))nameSuspensionsAndGetInfosfreeNames=TermFold{fSuspension=doSuspensionfreeNames,fTerm=\tydcvtt->dott'<-sequencettlet(terms,names)=unziptt'return(Termtydcvterms,concatnames),fPrim=\tyn->return(Primtyn,[]),fNewtypeWrap=\tydct->do(term,names)<-treturn(NewtypeWraptydcterm,names),fRefWrap=\tyt->do(term,names)<-treturn(RefWraptyterm,names)}doSuspensionfreeNamescttyhval_name=doname<-atomicModifyIOReffreeNames(\x->(tailx,headx))n<-newGrimNamenamereturn(Suspensioncttyhval(Justn),[(n,ty,hval)])-- A custom Term printer to enable the use of Show instancesshowTerm::GhcMonadm=>Term->mSDocshowTermterm=dodflags<-GHC.getSessionDynFlagsifdoptOpt_PrintEvldWithShowdflagsthencPprTerm(liftM2(++)(\_y->[cPprShowable])cPprTermBase)termelsecPprTermcPprTermBasetermwherecPprShowableprect@Term{ty=ty,val=val}=ifnot(isFullyEvaluatedTermt)thenreturnNothingelsedohsc_env<-getSessiondflags<-GHC.getSessionDynFlagsdo(new_env,bname)<-bindToFreshNamehsc_envty"showme"setSessionnew_env-- XXX: this tries to disable logging of errors-- does this still do what it is intended to do-- with the changed error handling and logging?letnoop_log_____=return()expr="show "++showPprdflagsbname_<-GHC.setSessionDynFlagsdflags{log_action=noop_log}txt_<-withExtendedLinkEnv[(bname,val)](GHC.compileExprexpr)letmyprec=10-- application precedence. TODO Infix constructorslettxt=unsafeCoerce#txt_ifnot(nulltxt)thenreturn$Just$cparen(prec>=myprec&&needsParenstxt)(texttxt)elsereturnNothing`gfinally`dosetSessionhsc_envGHC.setSessionDynFlagsdflagscPprShowableprecNewtypeWrap{ty=new_ty,wrapped_term=t}=cPprShowableprect{ty=new_ty}cPprShowable__=returnNothingneedsParens('"':_)=False-- some simple heuristics to see whether parens-- are redundant in an arbitrary Show outputneedsParens('(':_)=FalseneedsParenstxt=' '`elem`txtbindToFreshNamehsc_envtyuserName=doname<-newGrimNameuserNameletid=AnId$mkVanillaGlobalnametynew_ic=extendInteractiveContext(hsc_IChsc_env)[id]return(hsc_env{hsc_IC=new_ic},name)-- Create new uniques and give them sequentially numbered namesnewGrimName::MonadIOm=>String->mNamenewGrimNameuserName=dous<-liftIO$mkSplitUniqSupply'b'letunique=uniqFromSupplyusoccname=mkOccNamevarNameuserNamename=mkInternalNameuniqueoccnamenoSrcSpanreturnnamepprTypeAndContents::GhcMonadm=>Id->mSDocpprTypeAndContentsid=dodflags<-GHC.getSessionDynFlagsletpefas=doptOpt_PrintExplicitForallsdflagspcontents=doptOpt_PrintBindContentsdflagspprdId=(pprTyThingpefas.AnId)idifpcontentsthendoletdepthBound=100-- If the value is an exception, make sure we catch it and-- show the exception, rather than propagating the exception out.e_term<-gtry$GHC.obtainTermFromIddepthBoundFalseiddocs_term<-casee_termofRightterm->showTermtermLeftexn->return(text"*** Exception:"<+>text(show(exn::SomeException)))return$pprdId<+>equals<+>docs_termelsereturnpprdId---------------------------------------------------------------- Utils traceOptIf::GhcMonadm=>DynFlag->SDoc->m()traceOptIfflagdoc=dodflags<-GHC.getSessionDynFlagswhen(doptflagdflags)$liftIO$printInfoForUserdflagsalwaysQualifydoc