Refactoring only
[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 HscTypes
19 import IdInfo
20 --import Id
21 import Name
22 import Var hiding ( varName )
23 import VarSet
24 import Name
25 import UniqSupply
26 import TcType
27 import GHC
28 import DynFlags
29 import InteractiveEval
30 import Outputable
31 import SrcLoc
32 import PprTyThing
33
34 import Control.Exception
35 import Control.Monad
36 import Data.List
37 import Data.Maybe
38 import Data.IORef
39
40 import System.IO
41 import GHC.Exts
42
43 -------------------------------------
44 -- | The :print & friends commands
45 -------------------------------------
46 pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
47 pprintClosureCommand session bindThings force str = do
48 tythings <- (catMaybes . concat) `liftM`
49 mapM (\w -> GHC.parseName session w >>=
50 mapM (GHC.lookupName session))
51 (words str)
52 let ids = [id | AnId id <- tythings]
53
54 -- Obtain the terms and the recovered type information
55 (terms, substs) <- unzip `liftM` mapM (go session) ids
56
57 -- Apply the substitutions obtained after recovering the types
58 modifySession session $ \hsc_env ->
59 hsc_env{hsc_IC = foldr (flip substInteractiveContext)
60 (hsc_IC hsc_env)
61 (map skolemiseSubst substs)}
62 -- Finally, print the Terms
63 unqual <- GHC.getPrintUnqual session
64 docterms <- mapM (showTerm session) terms
65 (printForUser stdout unqual . vcat)
66 (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
67 ids
68 docterms)
69 where
70
71 -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
72 go :: Session -> Id -> IO (Term, TvSubst)
73 go cms id = do
74 term_ <- GHC.obtainTerm cms force id
75 term <- tidyTermTyVars cms term_
76 term' <- if bindThings &&
77 False == isUnliftedTypeKind (termType term)
78 then bindSuspensions cms term
79 else return term
80 -- Before leaving, we compare the type obtained to see if it's more specific
81 -- Then, we extract a substitution,
82 -- mapping the old tyvars to the reconstructed types.
83 let reconstructed_type = termType term
84 subst = unifyRTTI (idType id) (reconstructed_type)
85 return (term',subst)
86
87 tidyTermTyVars :: Session -> Term -> IO Term
88 tidyTermTyVars (Session ref) t = do
89 hsc_env <- readIORef ref
90 let env_tvs = ic_tyvars (hsc_IC hsc_env)
91 my_tvs = termTyVars t
92 tvs = env_tvs `minusVarSet` my_tvs
93 tyvarOccName = nameOccName . tyVarName
94 tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
95 , env_tvs `intersectVarSet` my_tvs)
96 return$ mapTermType (snd . tidyOpenType tidyEnv) t
97
98 -- | Give names, and bind in the interactive environment, to all the suspensions
99 -- included (inductively) in a term
100 bindSuspensions :: Session -> Term -> IO Term
101 bindSuspensions cms@(Session ref) t = do
102 hsc_env <- readIORef ref
103 inScope <- GHC.getBindings cms
104 let ictxt = hsc_IC hsc_env
105 prefix = "_t"
106 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
107 availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
108 availNames_var <- newIORef availNames
109 (t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
110 let (names, tys, hvals) = unzip3 stuff
111 let tys' = map (fst.skolemiseTy) tys
112 let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
113 | (name,ty) <- zip names tys']
114 new_tyvars = tyVarsOfTypes tys'
115 new_ic = extendInteractiveContext ictxt ids new_tyvars
116 extendLinkEnv (zip names hvals)
117 writeIORef ref (hsc_env {hsc_IC = new_ic })
118 return t'
119 where
120
121 -- Processing suspensions. Give names and recopilate info
122 nameSuspensionsAndGetInfos :: IORef [String] ->
123 TermFold (IO (Term, [(Name,Type,HValue)]))
124 nameSuspensionsAndGetInfos freeNames = TermFold
125 {
126 fSuspension = doSuspension freeNames
127 , fTerm = \ty dc v tt -> do
128 tt' <- sequence tt
129 let (terms,names) = unzip tt'
130 return (Term ty dc v terms, concat names)
131 , fPrim = \ty n ->return (Prim ty n,[])
132 , fNewtypeWrap =
133 \ty dc t -> do
134 (term, names) <- t
135 return (NewtypeWrap ty dc term, names)
136 , fRefWrap = \ty t -> do
137 (term, names) <- t
138 return (RefWrap ty term, names)
139 }
140 doSuspension freeNames ct ty hval _name = do
141 name <- atomicModifyIORef freeNames (\x->(tail x, head x))
142 n <- newGrimName name
143 return (Suspension ct ty hval (Just n), [(n,ty,hval)])
144
145
146 -- A custom Term printer to enable the use of Show instances
147 showTerm :: Session -> Term -> IO SDoc
148 showTerm cms@(Session ref) term = do
149 dflags <- GHC.getSessionDynFlags cms
150 if dopt Opt_PrintEvldWithShow dflags
151 then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
152 else cPprTerm cPprTermBase term
153 where
154 cPprShowable prec t@Term{ty=ty, val=val} =
155 if not (isFullyEvaluatedTerm t)
156 then return Nothing
157 else do
158 hsc_env <- readIORef ref
159 dflags <- GHC.getSessionDynFlags cms
160 do
161 (new_env, bname) <- bindToFreshName hsc_env ty "showme"
162 writeIORef ref (new_env)
163 let noop_log _ _ _ _ = return ()
164 expr = "show " ++ showSDoc (ppr bname)
165 GHC.setSessionDynFlags cms dflags{log_action=noop_log}
166 mb_txt <- withExtendedLinkEnv [(bname, val)]
167 (GHC.compileExpr cms expr)
168 let myprec = 10 -- application precedence. TODO Infix constructors
169 case mb_txt of
170 Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
171 -> return $ Just$ cparen (prec >= myprec &&
172 needsParens txt)
173 (text txt)
174 _ -> return Nothing
175 `finally` do
176 writeIORef ref hsc_env
177 GHC.setSessionDynFlags cms dflags
178 cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
179 cPprShowable prec t{ty=new_ty}
180 cPprShowable prec RefWrap{wrapped_term=t} = cPprShowable prec t
181 cPprShowable _ _ = return Nothing
182
183 needsParens ('"':_) = False -- some simple heuristics to see whether parens
184 -- are redundant in an arbitrary Show output
185 needsParens ('(':_) = False
186 needsParens txt = ' ' `elem` txt
187
188
189 bindToFreshName hsc_env ty userName = do
190 name <- newGrimName userName
191 let ictxt = hsc_IC hsc_env
192 tmp_ids = ic_tmp_ids ictxt
193 id = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
194 new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
195 return (hsc_env {hsc_IC = new_ic }, name)
196
197 -- Create new uniques and give them sequentially numbered names
198 newGrimName :: String -> IO Name
199 newGrimName userName = do
200 us <- mkSplitUniqSupply 'b'
201 let unique = uniqFromSupply us
202 occname = mkOccName varName userName
203 name = mkInternalName unique occname noSrcSpan
204 return name
205
206 pprTypeAndContents :: Session -> [Id] -> IO SDoc
207 pprTypeAndContents session ids = do
208 dflags <- GHC.getSessionDynFlags session
209 let pefas = dopt Opt_PrintExplicitForalls dflags
210 pcontents = dopt Opt_PrintBindContents dflags
211 if pcontents
212 then do
213 let depthBound = 100
214 terms <- mapM (GHC.obtainTermB session depthBound False) ids
215 docs_terms <- mapM (showTerm session) terms
216 return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
217 (map (pprTyThing pefas . AnId) ids)
218 docs_terms
219 else return $ vcat $ map (pprTyThing pefas . AnId) ids