Strings and comments only: 'to to ' fixes
[ghc.git] / compiler / ghci / Debugger.hs
1 -----------------------------------------------------------------------------
2 --
3 -- GHCi Interactive debugging commands
4 --
5 -- Pepe Iborra (supported by Google SoC) 2006
6 --
7 -- ToDo: lots of violation of layering here. This module should
8 -- decide whether it is above the GHC API (import GHC and nothing
9 -- else) or below it.
10 --
11 -----------------------------------------------------------------------------
12
13 module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
14
15 import Linker
16 import RtClosureInspect
17
18 import GhcMonad
19 import HscTypes
20 import Id
21 import Name
22 import Var hiding ( varName )
23 import VarSet
24 import UniqSupply
25 import Type
26 import Kind
27 import GHC
28 import Outputable
29 import PprTyThing
30 import MonadUtils
31 import DynFlags
32 import Exception
33
34 import Control.Monad
35 import Data.List
36 import Data.Maybe
37 import Data.IORef
38
39 import GHC.Exts
40
41 -------------------------------------
42 -- | The :print & friends commands
43 -------------------------------------
44 pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
45 pprintClosureCommand bindThings force str = do
46 tythings <- (catMaybes . concat) `liftM`
47 mapM (\w -> GHC.parseName w >>=
48 mapM GHC.lookupName)
49 (words str)
50 let ids = [id | AnId id <- tythings]
51
52 -- Obtain the terms and the recovered type information
53 (subst, terms) <- mapAccumLM go emptyTvSubst ids
54
55 -- Apply the substitutions obtained after recovering the types
56 modifySession $ \hsc_env ->
57 hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
58
59 -- Finally, print the Terms
60 unqual <- GHC.getPrintUnqual
61 docterms <- mapM showTerm terms
62 dflags <- getDynFlags
63 liftIO $ (printOutputForUser dflags unqual . vcat)
64 (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
65 ids
66 docterms)
67 where
68 -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
69 go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
70 go subst id = do
71 let id' = id `setIdType` substTy subst (idType id)
72 term_ <- GHC.obtainTermFromId maxBound force id'
73 term <- tidyTermTyVars term_
74 term' <- if bindThings &&
75 False == isUnliftedTypeKind (termType term)
76 then bindSuspensions term
77 else return term
78 -- Before leaving, we compare the type obtained to see if it's more specific
79 -- Then, we extract a substitution,
80 -- mapping the old tyvars to the reconstructed types.
81 let reconstructed_type = termType term
82 hsc_env <- getSession
83 case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
84 Nothing -> return (subst, term')
85 Just subst' -> do { traceOptIf Opt_D_dump_rtti
86 (fsep $ [text "RTTI Improvement for", ppr id,
87 text "is the substitution:" , ppr subst'])
88 ; return (subst `unionTvSubst` subst', term')}
89
90 tidyTermTyVars :: GhcMonad m => Term -> m Term
91 tidyTermTyVars t =
92 withSession $ \hsc_env -> do
93 let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env
94 my_tvs = termTyVars t
95 tvs = env_tvs `minusVarSet` my_tvs
96 tyvarOccName = nameOccName . tyVarName
97 tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
98 , env_tvs `intersectVarSet` my_tvs)
99 return$ mapTermType (snd . tidyOpenType tidyEnv) t
100
101 -- | Give names, and bind in the interactive environment, to all the suspensions
102 -- included (inductively) in a term
103 bindSuspensions :: GhcMonad m => Term -> m Term
104 bindSuspensions t = do
105 hsc_env <- getSession
106 inScope <- GHC.getBindings
107 let ictxt = hsc_IC hsc_env
108 prefix = "_t"
109 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
110 availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
111 availNames_var <- liftIO $ newIORef availNames
112 (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
113 let (names, tys, hvals) = unzip3 stuff
114 let ids = [ mkVanillaGlobal name ty
115 | (name,ty) <- zip names tys]
116 new_ic = extendInteractiveContext ictxt (map AnId ids)
117 liftIO $ extendLinkEnv (zip names hvals)
118 modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
119 return t'
120 where
121
122 -- Processing suspensions. Give names and recopilate info
123 nameSuspensionsAndGetInfos :: IORef [String] ->
124 TermFold (IO (Term, [(Name,Type,HValue)]))
125 nameSuspensionsAndGetInfos freeNames = TermFold
126 {
127 fSuspension = doSuspension freeNames
128 , fTerm = \ty dc v tt -> do
129 tt' <- sequence tt
130 let (terms,names) = unzip tt'
131 return (Term ty dc v terms, concat names)
132 , fPrim = \ty n ->return (Prim ty n,[])
133 , fNewtypeWrap =
134 \ty dc t -> do
135 (term, names) <- t
136 return (NewtypeWrap ty dc term, names)
137 , fRefWrap = \ty t -> do
138 (term, names) <- t
139 return (RefWrap ty term, names)
140 }
141 doSuspension freeNames ct ty hval _name = do
142 name <- atomicModifyIORef freeNames (\x->(tail x, head x))
143 n <- newGrimName name
144 return (Suspension ct ty hval (Just n), [(n,ty,hval)])
145
146
147 -- A custom Term printer to enable the use of Show instances
148 showTerm :: GhcMonad m => Term -> m SDoc
149 showTerm term = do
150 dflags <- GHC.getSessionDynFlags
151 if gopt Opt_PrintEvldWithShow dflags
152 then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
153 else cPprTerm cPprTermBase term
154 where
155 cPprShowable prec t@Term{ty=ty, val=val} =
156 if not (isFullyEvaluatedTerm t)
157 then return Nothing
158 else do
159 hsc_env <- getSession
160 dflags <- GHC.getSessionDynFlags
161 do
162 (new_env, bname) <- bindToFreshName hsc_env ty "showme"
163 setSession new_env
164 -- XXX: this tries to disable logging of errors
165 -- does this still do what it is intended to do
166 -- with the changed error handling and logging?
167 let noop_log _ _ _ _ _ = return ()
168 expr = "show " ++ showPpr dflags bname
169 _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
170 txt_ <- withExtendedLinkEnv [(bname, val)]
171 (GHC.compileExpr expr)
172 let myprec = 10 -- application precedence. TODO Infix constructors
173 let txt = unsafeCoerce# txt_
174 if not (null txt) then
175 return $ Just $ cparen (prec >= myprec && needsParens txt)
176 (text txt)
177 else return Nothing
178 `gfinally` do
179 setSession hsc_env
180 GHC.setSessionDynFlags dflags
181 cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
182 cPprShowable prec t{ty=new_ty}
183 cPprShowable _ _ = return Nothing
184
185 needsParens ('"':_) = False -- some simple heuristics to see whether parens
186 -- are redundant in an arbitrary Show output
187 needsParens ('(':_) = False
188 needsParens txt = ' ' `elem` txt
189
190
191 bindToFreshName hsc_env ty userName = do
192 name <- newGrimName userName
193 let id = AnId $ mkVanillaGlobal name ty
194 new_ic = extendInteractiveContext (hsc_IC hsc_env) [id]
195 return (hsc_env {hsc_IC = new_ic }, name)
196
197 -- Create new uniques and give them sequentially numbered names
198 newGrimName :: MonadIO m => String -> m Name
199 newGrimName userName = do
200 us <- liftIO $ mkSplitUniqSupply 'b'
201 let unique = uniqFromSupply us
202 occname = mkOccName varName userName
203 name = mkInternalName unique occname noSrcSpan
204 return name
205
206 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
207 pprTypeAndContents id = do
208 dflags <- GHC.getSessionDynFlags
209 let pefas = gopt Opt_PrintExplicitForalls dflags
210 pcontents = gopt Opt_PrintBindContents dflags
211 pprdId = (PprTyThing.pprTyThing pefas . AnId) id
212 if pcontents
213 then do
214 let depthBound = 100
215 -- If the value is an exception, make sure we catch it and
216 -- show the exception, rather than propagating the exception out.
217 e_term <- gtry $ GHC.obtainTermFromId depthBound False id
218 docs_term <- case e_term of
219 Right term -> showTerm term
220 Left exn -> return (text "*** Exception:" <+>
221 text (show (exn :: SomeException)))
222 return $ pprdId <+> equals <+> docs_term
223 else return pprdId
224
225 --------------------------------------------------------------
226 -- Utils
227
228 traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
229 traceOptIf flag doc = do
230 dflags <- GHC.getSessionDynFlags
231 when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc