X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=b7c8e324d7a63d71da0d959207c360b54d2cca4c;hb=d4da7630f82ea1e808a632623351b6a35e772689;hp=138992f10a0555ca5ea1c67513eb38315d864a19;hpb=ab13303c49618c6224d7c5b5397ac9a98d2e5b6f;p=ghc-hetmet.git diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 138992f..b7c8e32 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -63,15 +63,16 @@ pprintClosureCommand session bindThings force str = do -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: Session -> Id -> IO (Maybe TvSubst) go cms id = do - term_ <- obtainTerm cms force id - term <- tidyTermTyVars cms term_ - term' <- if not bindThings then return term + term_ <- withSession cms $ \hsc_env -> obtainTerm hsc_env 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 + showterm <- printTerm cms term' + unqual <- GHC.getPrintUnqual cms let showSDocForUserOneLine unqual doc = showDocWith LeftMode (doc (mkErrStyle unqual)) - (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm) + (putStrLn . showSDocForUserOneLine unqual) + (ppr id <+> char '=' <+> showterm) -- 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. @@ -143,7 +144,8 @@ bindSuspensions cms@(Session ref) t = do where -- Processing suspensions. Give names and recopilate info - nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)])) + nameSuspensionsAndGetInfos :: IORef [String] -> + TermFold (IO (Term, [(Name,Type,HValue)])) nameSuspensionsAndGetInfos freeNames = TermFold { fSuspension = doSuspension freeNames @@ -203,7 +205,7 @@ newGrimName cms userName = do us <- mkSplitUniqSupply 'b' let unique = uniqFromSupply us occname = mkOccName varName userName - name = mkInternalName unique occname noSrcLoc + name = mkInternalName unique occname noSrcSpan return name skolemSubst subst = subst `setTvSubstEnv`