Rewrite the unsafe code dealing with unboxed primitives in RtClosureInspect
[ghc.git] / compiler / ghci / RtClosureInspect.hs
1 -----------------------------------------------------------------------------
2 --
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
4 --
5 -- Pepe Iborra (supported by Google SoC) 2006
6 --
7 -----------------------------------------------------------------------------
8
9 module RtClosureInspect(
10
11 cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
12
13 Term(..),
14 pprTerm,
15 cPprTerm,
16 cPprTermBase,
17 termType,
18 foldTerm,
19 TermFold(..),
20 idTermFold,
21 idTermFoldM,
22 isFullyEvaluated,
23 isPointed,
24 isFullyEvaluatedTerm,
25 mapTermType,
26 termTyVars
27 -- unsafeDeepSeq,
28 ) where
29
30 #include "HsVersions.h"
31
32 import ByteCodeItbls ( StgInfoTable )
33 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
34 import ByteCodeLink ( HValue )
35 import HscTypes ( HscEnv )
36
37 import DataCon
38 import Type
39 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
40 import TcType
41 import TcMType
42 import TcUnify
43 import TcGadt
44 import TyCon
45 import Var
46 import Name
47 import VarEnv
48 import OccName
49 import VarSet
50 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
51
52 import TysPrim
53 import PrelNames
54 import TysWiredIn
55
56 import Constants
57 import Outputable
58 import Maybes
59 import Panic
60 import FiniteMap
61
62 import GHC.Arr ( Array(..) )
63 import GHC.Ptr ( Ptr(..), castPtr )
64 import GHC.Exts
65
66 import Control.Monad
67 import Data.Maybe
68 import Data.Array.Base
69 import Data.List ( partition, nub )
70 import Foreign
71
72 ---------------------------------------------
73 -- * A representation of semi evaluated Terms
74 ---------------------------------------------
75 {-
76 A few examples in this representation:
77
78 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
79
80 > (('a',_,_),_,('b',_,_)) =
81 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
82 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
83 , Suspension
84 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
85 -}
86
87 data Term = Term { ty :: Type
88 , dc :: DataCon
89 , val :: HValue
90 , subTerms :: [Term] }
91
92 | Prim { ty :: Type
93 , value :: [Word] }
94
95 | Suspension { ctype :: ClosureType
96 , mb_ty :: Maybe Type
97 , val :: HValue
98 , bound_to :: Maybe Name -- Useful for printing
99 }
100
101 isTerm Term{} = True
102 isTerm _ = False
103 isSuspension Suspension{} = True
104 isSuspension _ = False
105 isPrim Prim{} = True
106 isPrim _ = False
107
108 termType t@(Suspension {}) = mb_ty t
109 termType t = Just$ ty t
110
111 isFullyEvaluatedTerm :: Term -> Bool
112 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
113 isFullyEvaluatedTerm Suspension {} = False
114 isFullyEvaluatedTerm Prim {} = True
115
116 instance Outputable (Term) where
117 ppr = head . cPprTerm cPprTermBase
118
119 -------------------------------------------------------------------------
120 -- Runtime Closure Datatype and functions for retrieving closure related stuff
121 -------------------------------------------------------------------------
122 data ClosureType = Constr
123 | Fun
124 | Thunk Int
125 | ThunkSelector
126 | Blackhole
127 | AP
128 | PAP
129 | Indirection Int
130 | Other Int
131 deriving (Show, Eq)
132
133 data Closure = Closure { tipe :: ClosureType
134 , infoPtr :: Ptr ()
135 , infoTable :: StgInfoTable
136 , ptrs :: Array Int HValue
137 , nonPtrs :: [Word]
138 }
139
140 instance Outputable ClosureType where
141 ppr = text . show
142
143 #include "../includes/ClosureTypes.h"
144
145 aP_CODE = AP
146 pAP_CODE = PAP
147 #undef AP
148 #undef PAP
149
150 getClosureData :: a -> IO Closure
151 getClosureData a =
152 case unpackClosure# a of
153 (# iptr, ptrs, nptrs #) -> do
154 itbl <- peek (Ptr iptr)
155 let tipe = readCType (BCI.tipe itbl)
156 elems = BCI.ptrs itbl
157 ptrsList = Array 0 (fromIntegral$ elems) ptrs
158 nptrs_data = [W# (indexWordArray# nptrs i)
159 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
160 ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
161
162 readCType :: Integral a => a -> ClosureType
163 readCType i
164 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
165 | i >= FUN && i <= FUN_STATIC = Fun
166 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
167 | i == THUNK_SELECTOR = ThunkSelector
168 | i == BLACKHOLE = Blackhole
169 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
170 | fromIntegral i == aP_CODE = AP
171 | i == AP_STACK = AP
172 | fromIntegral i == pAP_CODE = PAP
173 | otherwise = Other (fromIntegral i)
174
175 isConstr, isIndirection :: ClosureType -> Bool
176 isConstr Constr = True
177 isConstr _ = False
178
179 isIndirection (Indirection _) = True
180 --isIndirection ThunkSelector = True
181 isIndirection _ = False
182
183 isThunk (Thunk _) = True
184 isThunk ThunkSelector = True
185 isThunk AP = True
186 isThunk _ = False
187
188 isFullyEvaluated :: a -> IO Bool
189 isFullyEvaluated a = do
190 closure <- getClosureData a
191 case tipe closure of
192 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
193 return$ and are_subs_evaluated
194 otherwise -> return False
195 where amapM f = sequence . amap' f
196
197 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
198 (# e #) -> f e)
199 [0 .. i - i0]
200
201 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
202 {-
203 unsafeDeepSeq :: a -> b -> b
204 unsafeDeepSeq = unsafeDeepSeq1 2
205 where unsafeDeepSeq1 0 a b = seq a $! b
206 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
207 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
208 -- | unsafePerformIO (isFullyEvaluated a) = b
209 | otherwise = case unsafePerformIO (getClosureData a) of
210 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
211 where tipe = unsafePerformIO (getClosureType a)
212 -}
213 isPointed :: Type -> Bool
214 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
215 isPointed _ = True
216
217 extractUnboxed :: [Type] -> Closure -> [[Word]]
218 extractUnboxed tt clos = go tt (nonPtrs clos)
219 where sizeofType t
220 | Just (tycon,_) <- splitTyConApp_maybe t
221 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
222 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
223 go [] _ = []
224 go (t:tt) xx
225 | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
226 = x : go tt rest
227
228 sizeofTyCon = sizeofPrimRep . tyConPrimRep
229
230 -----------------------------------
231 -- * Traversals for Terms
232 -----------------------------------
233
234 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
235 , fPrim :: Type -> [Word] -> a
236 , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
237 }
238
239 foldTerm :: TermFold a -> Term -> a
240 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
241 foldTerm tf (Prim ty v ) = fPrim tf ty v
242 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
243
244 idTermFold :: TermFold Term
245 idTermFold = TermFold {
246 fTerm = Term,
247 fPrim = Prim,
248 fSuspension = Suspension
249 }
250 idTermFoldM :: Monad m => TermFold (m Term)
251 idTermFoldM = TermFold {
252 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
253 fPrim = (return.). Prim,
254 fSuspension = (((return.).).). Suspension
255 }
256
257 mapTermType f = foldTerm idTermFold {
258 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
259 fSuspension = \ct mb_ty hval n ->
260 Suspension ct (fmap f mb_ty) hval n }
261
262 termTyVars = foldTerm TermFold {
263 fTerm = \ty _ _ tt ->
264 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
265 fSuspension = \_ mb_ty _ _ ->
266 maybe emptyVarEnv tyVarsOfType mb_ty,
267 fPrim = \ _ _ -> emptyVarEnv }
268 where concatVarEnv = foldr plusVarEnv emptyVarEnv
269 ----------------------------------
270 -- Pretty printing of terms
271 ----------------------------------
272
273 app_prec::Int
274 app_prec = 10
275
276 pprTerm :: Int -> Term -> SDoc
277 pprTerm p Term{dc=dc, subTerms=tt}
278 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
279 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
280 <+> hsep (map (pprTerm1 True) tt)
281 -}
282 | null tt = ppr dc
283 | otherwise = cparen (p >= app_prec)
284 (ppr dc <+> sep (map (pprTerm app_prec) tt))
285
286 where fixity = undefined
287
288 pprTerm _ t = pprTerm1 t
289
290 pprTerm1 Prim{value=words, ty=ty} = text$ repPrim (tyConAppTyCon ty) words
291 pprTerm1 t@Term{} = pprTerm 0 t
292 pprTerm1 Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
293 pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
294 | Just _ <- splitFunTy_maybe ty = ptext SLIT("<function>")
295 | otherwise = parens$ ppr n <> text "::" <> ppr ty
296
297
298 cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
299 cPprTerm custom = go 0 where
300 go prec t@Term{subTerms=tt, dc=dc} = do
301 let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)]
302 first_success <- firstJustM mb_customDocs
303 case first_success of
304 Just doc -> return$ cparen (prec>app_prec+1) doc
305 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
306 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
307 return$ cparen (prec >= app_prec)
308 (ppr dc <+> sep pprSubterms)
309 go _ t = return$ pprTerm1 t
310 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
311 firstJustM [] = return Nothing
312
313 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
314 cPprTermBase pprP =
315 [
316 ifTerm isTupleDC (\_ -> liftM (parens . hcat . punctuate comma)
317 . mapM (pprP (-1)) . subTerms)
318 , ifTerm (isDC consDataCon) (\ p Term{subTerms=[h,t]} -> doList p h t)
319 , ifTerm (isDC intDataCon) (coerceShow$ \(a::Int)->a)
320 , ifTerm (isDC charDataCon) (coerceShow$ \(a::Char)->a)
321 -- , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
322 , ifTerm (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
323 , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
324 , ifTerm isIntegerDC (coerceShow$ \(a::Integer)->a)
325 ]
326 where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing
327 isIntegerDC Term{dc=dc} =
328 dataConName dc `elem` [ smallIntegerDataConName
329 , largeIntegerDataConName]
330 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
331 isDC a_dc Term{dc=dc} = a_dc == dc
332 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
333 --TODO pprinting of list terms is not lazy
334 doList p h t = do
335 let elems = h : getListTerms t
336 isConsLast = termType(last elems) /= termType h
337 print_elems <- mapM (pprP 5) elems
338 return$ if isConsLast
339 then cparen (p >= 5) . hsep . punctuate (space<>colon)
340 $ print_elems
341 else brackets (hcat$ punctuate comma print_elems)
342
343 where Just a /= Just b = not (a `coreEqType` b)
344 _ /= _ = True
345 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
346 getListTerms t@Term{subTerms=[]} = []
347 getListTerms t@Suspension{} = [t]
348 getListTerms t = pprPanic "getListTerms" (ppr t)
349
350 repPrim :: TyCon -> [Word] -> String
351 repPrim t = rep where
352 rep x
353 | t == charPrimTyCon = show (build x :: Char)
354 | t == intPrimTyCon = show (build x :: Int)
355 | t == wordPrimTyCon = show (build x :: Word)
356 | t == floatPrimTyCon = show (build x :: Float)
357 | t == doublePrimTyCon = show (build x :: Double)
358 | t == int32PrimTyCon = show (build x :: Int32)
359 | t == word32PrimTyCon = show (build x :: Word32)
360 | t == int64PrimTyCon = show (build x :: Int64)
361 | t == word64PrimTyCon = show (build x :: Word64)
362 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
363 | t == stablePtrPrimTyCon = "<stablePtr>"
364 | t == stableNamePrimTyCon = "<stableName>"
365 | t == statePrimTyCon = "<statethread>"
366 | t == realWorldTyCon = "<realworld>"
367 | t == threadIdPrimTyCon = "<ThreadId>"
368 | t == weakPrimTyCon = "<Weak>"
369 | t == arrayPrimTyCon = "<array>"
370 | t == byteArrayPrimTyCon = "<bytearray>"
371 | t == mutableArrayPrimTyCon = "<mutableArray>"
372 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
373 | t == mutVarPrimTyCon= "<mutVar>"
374 | t == mVarPrimTyCon = "<mVar>"
375 | t == tVarPrimTyCon = "<tVar>"
376 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
377 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
378 -----------------------------------
379 -- Type Reconstruction
380 -----------------------------------
381
382 -- The Type Reconstruction monad
383 type TR a = TcM a
384
385 runTR :: HscEnv -> TR Term -> IO Term
386 runTR hsc_env c = do
387 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
388 case mb_term of
389 Nothing -> panic "Can't unify"
390 Just term -> return term
391
392 trIO :: IO a -> TR a
393 trIO = liftTcM . ioToTcRn
394
395 addConstraint :: TcType -> TcType -> TR ()
396 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
397
398 {-
399 A parallel fold over two Type values,
400 compensating for missing newtypes on both sides.
401 This is necessary because newtypes are not present
402 in runtime, but since sometimes there is evidence
403 available we do our best to reconstruct them.
404 Evidence can come from DataCon signatures or
405 from compile-time type inference.
406 I am using the words congruence and rewriting
407 because what we are doing here is an approximation
408 of unification modulo a set of equations, which would
409 come from newtype definitions. These should be the
410 equality coercions seen in System Fc. Rewriting
411 is performed, taking those equations as rules,
412 before launching unification.
413
414 It doesn't make sense to rewrite everywhere,
415 or we would end up with all newtypes. So we rewrite
416 only in presence of evidence.
417 The lhs comes from the heap structure of ptrs,nptrs.
418 The rhs comes from a DataCon type signature.
419 Rewriting in the rhs is restricted to the result type.
420
421 Note that it is very tricky to make this 'rewriting'
422 work with the unification implemented by TcM, where
423 substitutions are 'inlined'. The order in which
424 constraints are unified is vital for this (or I am
425 using TcM wrongly).
426 -}
427 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
428 congruenceNewtypes = go True
429 where
430 go rewriteRHS lhs rhs
431 -- TyVar lhs inductive case
432 | Just tv <- getTyVar_maybe lhs
433 = recoverM (return (lhs,rhs)) $ do
434 Indirect ty_v <- readMetaTyVar tv
435 (lhs', rhs') <- go rewriteRHS ty_v rhs
436 writeMutVar (metaTvRef tv) (Indirect lhs')
437 return (lhs, rhs')
438 -- TyVar rhs inductive case
439 | Just tv <- getTyVar_maybe rhs
440 = recoverM (return (lhs,rhs)) $ do
441 Indirect ty_v <- readMetaTyVar tv
442 (lhs', rhs') <- go rewriteRHS lhs ty_v
443 writeMutVar (metaTvRef tv) (Indirect rhs')
444 return (lhs', rhs)
445 -- FunTy inductive case
446 | Just (l1,l2) <- splitFunTy_maybe lhs
447 , Just (r1,r2) <- splitFunTy_maybe rhs
448 = do (l2',r2') <- go True l2 r2
449 (l1',r1') <- go False l1 r1
450 return (mkFunTy l1' l2', mkFunTy r1' r2')
451 -- TyconApp Inductive case; this is the interesting bit.
452 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
453 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
454
455 let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
456 then (tycon_r, rewrite tycon_r lhs)
457 else (tycon_l, args_l)
458 (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
459 then (tycon_l, rewrite tycon_l rhs)
460 else (tycon_r, args_r)
461 (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
462 return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
463
464 | otherwise = return (lhs,rhs)
465
466 where rewrite newtyped_tc lame_tipe
467 | (tvs, tipe) <- newTyConRep newtyped_tc
468 = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
469 Just subst -> substTys subst (map mkTyVarTy tvs)
470 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
471
472 newVar :: Kind -> TR TcTyVar
473 newVar = liftTcM . newFlexiTyVar
474
475 liftTcM = id
476
477 -- | Returns the instantiated type scheme ty', and the substitution sigma
478 -- such that sigma(ty') = ty
479 instScheme :: Type -> TR (TcType, TvSubst)
480 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
481 (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
482 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
483
484 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
485 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
486 tv <- liftM mkTyVarTy (newVar argTypeKind)
487 case mb_ty of
488 Nothing -> go tv tv hval >>= zonkTerm
489 Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
490 Just ty -> do
491 (ty',rev_subst) <- instScheme (sigmaType ty)
492 addConstraint tv ty'
493 term <- go tv tv hval >>= zonkTerm
494 --restore original Tyvars
495 return$ mapTermType (substTy rev_subst) term
496 where
497 go tv ty a = do
498 let monomorphic = not(isTyVarTy tv) -- This is a convention. The ancestor tests for
499 -- monomorphism and passes a type instead of a tv
500 clos <- trIO $ getClosureData a
501 case tipe clos of
502 -- Thunks we may want to force
503 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
504 -- force blackholes, because it would almost certainly result in deadlock,
505 -- and showing the '_' is more useful.
506 t | isThunk t && force -> seq a $ go tv ty a
507 -- We always follow indirections
508 Indirection _ -> go tv ty $! (ptrs clos ! 0)
509 -- The interesting case
510 Constr -> do
511 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
512 case m_dc of
513 Nothing -> panic "Can't find the DataCon for a term"
514 Just dc -> do
515 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
516 subTtypes = matchSubTypes dc ty
517 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
518 subTermTvs <- sequence
519 [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
520 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
521 -- It is vital for newtype reconstruction that the unification step is done
522 -- right here, _before_ the subterms are RTTI reconstructed.
523 when (not monomorphic) $ do
524 let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
525 instScheme(dataConRepType dc) >>= addConstraint myType . fst
526 subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
527 [ appArr (go tv t) (ptrs clos) i
528 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
529 let unboxeds = extractUnboxed subTtypesNP clos
530 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
531 subTerms = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
532 return (Term tv dc a subTerms)
533 -- The otherwise case: can be a Thunk,AP,PAP,etc.
534 otherwise ->
535 return (Suspension (tipe clos) (Just tv) a Nothing)
536
537 -- Access the array of pointers and recurse down. Needs to be done with
538 -- care of no introducing a thunk! or go will fail to do its job
539 appArr f arr (I# i#) = case arr of
540 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
541 (# e #) -> f e
542
543 matchSubTypes dc ty
544 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
545 , null (dataConExTyVars dc) --TODO Handle the case of extra existential tyvars
546 = dataConInstArgTys dc ty_args
547
548 | otherwise = dataConRepArgTys dc
549
550 -- This is used to put together pointed and nonpointed subterms in the
551 -- correct order.
552 reOrderTerms _ _ [] = []
553 reOrderTerms pointed unpointed (ty:tys)
554 | isPointed ty = ASSERT2(not(null pointed)
555 , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
556 head pointed : reOrderTerms (tail pointed) unpointed tys
557 | otherwise = ASSERT2(not(null unpointed)
558 , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
559 head unpointed : reOrderTerms pointed (tail unpointed) tys
560
561 isMonomorphic ty | isForAllTy ty = False
562 isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
563
564 zonkTerm :: Term -> TcM Term
565 zonkTerm = foldTerm idTermFoldM {
566 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
567 zonkTcType ty >>= \ty' ->
568 return (Term ty' dc v tt)
569 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
570 return (Suspension ct ty v b)}
571
572
573 -- Is this defined elsewhere?
574 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
575 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
576
577 {-
578 Example of Type Reconstruction
579 --------------------------------
580 Suppose we have an existential type such as
581
582 data Opaque = forall a. Opaque a
583
584 And we have a term built as:
585
586 t = Opaque (map Just [[1,1],[2,2]])
587
588 The type of t as far as the typechecker goes is t :: Opaque
589 If we seq the head of t, we obtain:
590
591 t - O (_1::a)
592
593 seq _1 ()
594
595 t - O ( (_3::b) : (_4::[b]) )
596
597 seq _3 ()
598
599 t - O ( (Just (_5::c)) : (_4::[b]) )
600
601 At this point, we know that b = (Maybe c)
602
603 seq _5 ()
604
605 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
606
607 At this point, we know that c = [d]
608
609 seq _6 ()
610
611 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
612
613 At this point, we know that d = Integer
614
615 The fully reconstructed expressions, with propagation, would be:
616
617 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
618 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
619 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
620
621
622 For reference, the type of the thing inside the opaque is
623 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
624
625 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
626 -}