Make sure PatSyns only get added once to tcg_patsyns
[ghc.git] / compiler / typecheck / TcBinds.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[TcBinds]{TcBinds}
6 -}
7
8 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
9
10 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
11 tcValBinds, tcHsBootSigs, tcPolyCheck,
12 tcSpecPrags, tcSpecWrapper,
13 tcVectDecls, addTypecheckedBinds,
14 TcSigInfo(..), TcSigFun,
15 TcPragEnv, mkPragEnv,
16 tcUserTypeSig, instTcTySig, chooseInferredQuantifiers,
17 instTcTySigFromId, tcExtendTyVarEnvFromSig,
18 badBootDeclErr, mkExport ) where
19
20 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
21 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
22 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
23 import DynFlags
24 import HsSyn
25 import HscTypes( isHsBootOrSig )
26 import TcRnMonad
27 import TcEnv
28 import TcUnify
29 import TcSimplify
30 import TcEvidence
31 import TcHsType
32 import TcPat
33 import TcMType
34 import ConLike
35 import Inst( deeplyInstantiate )
36 import FamInstEnv( normaliseType )
37 import FamInst( tcGetFamInstEnvs )
38 import TyCon
39 import TcType
40 import TysPrim
41 import TysWiredIn
42 import Id
43 import Var
44 import VarSet
45 import VarEnv( TidyEnv )
46 import Module
47 import Name
48 import NameSet
49 import NameEnv
50 import SrcLoc
51 import Bag
52 import ListSetOps
53 import ErrUtils
54 import Digraph
55 import Maybes
56 import Util
57 import BasicTypes
58 import Outputable
59 import FastString
60 import Type(mkStrLitTy, tidyOpenType)
61 import PrelNames( mkUnboundName, gHC_PRIM )
62 import TcValidity (checkValidType)
63
64 import Control.Monad
65 import Data.List (partition)
66
67 #include "HsVersions.h"
68
69 {- *********************************************************************
70 * *
71 A useful helper function
72 * *
73 ********************************************************************* -}
74
75 addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv
76 addTypecheckedBinds tcg_env binds
77 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
78 -- Do not add the code for record-selector bindings
79 -- when compiling hs-boot files
80 | otherwise = tcg_env { tcg_binds = foldr unionBags
81 (tcg_binds tcg_env)
82 binds }
83
84 {-
85 ************************************************************************
86 * *
87 \subsection{Type-checking bindings}
88 * *
89 ************************************************************************
90
91 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
92 it needs to know something about the {\em usage} of the things bound,
93 so that it can create specialisations of them. So @tcBindsAndThen@
94 takes a function which, given an extended environment, E, typechecks
95 the scope of the bindings returning a typechecked thing and (most
96 important) an LIE. It is this LIE which is then used as the basis for
97 specialising the things bound.
98
99 @tcBindsAndThen@ also takes a "combiner" which glues together the
100 bindings and the "thing" to make a new "thing".
101
102 The real work is done by @tcBindWithSigsAndThen@.
103
104 Recursive and non-recursive binds are handled in essentially the same
105 way: because of uniques there are no scoping issues left. The only
106 difference is that non-recursive bindings can bind primitive values.
107
108 Even for non-recursive binding groups we add typings for each binder
109 to the LVE for the following reason. When each individual binding is
110 checked the type of its LHS is unified with that of its RHS; and
111 type-checking the LHS of course requires that the binder is in scope.
112
113 At the top-level the LIE is sure to contain nothing but constant
114 dictionaries, which we resolve at the module level.
115
116 Note [Polymorphic recursion]
117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 The game plan for polymorphic recursion in the code above is
119
120 * Bind any variable for which we have a type signature
121 to an Id with a polymorphic type. Then when type-checking
122 the RHSs we'll make a full polymorphic call.
123
124 This fine, but if you aren't a bit careful you end up with a horrendous
125 amount of partial application and (worse) a huge space leak. For example:
126
127 f :: Eq a => [a] -> [a]
128 f xs = ...f...
129
130 If we don't take care, after typechecking we get
131
132 f = /\a -> \d::Eq a -> let f' = f a d
133 in
134 \ys:[a] -> ...f'...
135
136 Notice the the stupid construction of (f a d), which is of course
137 identical to the function we're executing. In this case, the
138 polymorphic recursion isn't being used (but that's a very common case).
139 This can lead to a massive space leak, from the following top-level defn
140 (post-typechecking)
141
142 ff :: [Int] -> [Int]
143 ff = f Int dEqInt
144
145 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
146 f' is another thunk which evaluates to the same thing... and you end
147 up with a chain of identical values all hung onto by the CAF ff.
148
149 ff = f Int dEqInt
150
151 = let f' = f Int dEqInt in \ys. ...f'...
152
153 = let f' = let f' = f Int dEqInt in \ys. ...f'...
154 in \ys. ...f'...
155
156 Etc.
157
158 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
159 which would make the space leak go away in this case
160
161 Solution: when typechecking the RHSs we always have in hand the
162 *monomorphic* Ids for each binding. So we just need to make sure that
163 if (Method f a d) shows up in the constraints emerging from (...f...)
164 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
165 to the "givens" when simplifying constraints. That's what the "lies_avail"
166 is doing.
167
168 Then we get
169
170 f = /\a -> \d::Eq a -> letrec
171 fm = \ys:[a] -> ...fm...
172 in
173 fm
174 -}
175
176 tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
177 -- The TcGblEnv contains the new tcg_binds and tcg_spects
178 -- The TcLclEnv has an extended type envt for the new bindings
179 tcTopBinds (ValBindsOut binds sigs)
180 = do { -- Pattern synonym bindings populate the global environment
181 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
182 do { gbl <- getGblEnv
183 ; lcl <- getLclEnv
184 ; return (gbl, lcl) }
185 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
186
187 ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
188 `addTypecheckedBinds` map snd binds' }
189
190 ; return (tcg_env', tcl_env) }
191 -- The top level bindings are flattened into a giant
192 -- implicitly-mutually-recursive LHsBinds
193
194 tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
195
196 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
197 tcRecSelBinds (ValBindsOut binds sigs)
198 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
199 do { (rec_sel_binds, tcg_env) <- discardWarnings $
200 tcValBinds TopLevel binds sigs getGblEnv
201 ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
202 ; return tcg_env' }
203 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
204
205 tcHsBootSigs :: HsValBinds Name -> TcM [Id]
206 -- A hs-boot file has only one BindGroup, and it only has type
207 -- signatures in it. The renamer checked all this
208 tcHsBootSigs (ValBindsOut binds sigs)
209 = do { checkTc (null binds) badBootDeclErr
210 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
211 where
212 tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
213 where
214 f (L _ name)
215 = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
216 ; return (mkVanillaGlobal name sigma_ty) }
217 -- Notice that we make GlobalIds, not LocalIds
218 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
219 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
220
221 badBootDeclErr :: MsgDoc
222 badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
223
224 ------------------------
225 tcLocalBinds :: HsLocalBinds Name -> TcM thing
226 -> TcM (HsLocalBinds TcId, thing)
227
228 tcLocalBinds EmptyLocalBinds thing_inside
229 = do { thing <- thing_inside
230 ; return (EmptyLocalBinds, thing) }
231
232 tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
233 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
234 ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
235 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
236
237 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
238 = do { (given_ips, ip_binds') <-
239 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
240
241 -- If the binding binds ?x = E, we must now
242 -- discharge any ?x constraints in expr_lie
243 -- See Note [Implicit parameter untouchables]
244 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
245 [] given_ips thing_inside
246
247 ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
248 where
249 ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
250
251 -- I wonder if we should do these one at at time
252 -- Consider ?x = 4
253 -- ?y = ?x + 1
254 tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
255 = do { ty <- newFlexiTyVarTy openTypeKind
256 ; let p = mkStrLitTy $ hsIPNameFS ip
257 ; ip_id <- newDict ipClass [ p, ty ]
258 ; expr' <- tcMonoExpr expr ty
259 ; let d = toDict ipClass p ty `fmap` expr'
260 ; return (ip_id, (IPBind (Right ip_id) d)) }
261 tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
262
263 -- Coerces a `t` into a dictionry for `IP "x" t`.
264 -- co : t -> IP "x" t
265 toDict ipClass x ty = HsWrap $ mkWpCastR $ TcCoercion $
266 wrapIP $ mkClassPred ipClass [x,ty]
267
268 {-
269 Note [Implicit parameter untouchables]
270 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
271 We add the type variables in the types of the implicit parameters
272 as untouchables, not so much because we really must not unify them,
273 but rather because we otherwise end up with constraints like this
274 Num alpha, Implic { wanted = alpha ~ Int }
275 The constraint solver solves alpha~Int by unification, but then
276 doesn't float that solved constraint out (it's not an unsolved
277 wanted). Result disaster: the (Num alpha) is again solved, this
278 time by defaulting. No no no.
279
280 However [Oct 10] this is all handled automatically by the
281 untouchable-range idea.
282
283 Note [Placeholder PatSyn kinds]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 Consider this (Trac #9161)
286
287 {-# LANGUAGE PatternSynonyms, DataKinds #-}
288 pattern A = ()
289 b :: A
290 b = undefined
291
292 Here, the type signature for b mentions A. But A is a pattern
293 synonym, which is typechecked (for very good reasons; a view pattern
294 in the RHS may mention a value binding) as part of a group of
295 bindings. It is entirely reasonable to reject this, but to do so
296 we need A to be in the kind environment when kind-checking the signature for B.
297
298 Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding
299 A -> AGlobal (AConLike (PatSynCon _|_))
300 to the environment. Then TcHsType.tcTyVar will find A in the kind environment,
301 and will give a 'wrongThingErr' as a result. But the lookup of A won't fail.
302
303 The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in
304 tcTyVar, doesn't look inside the TcTyThing.
305
306 Note [Inlining and hs-boot files]
307 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
308 Consider this example (Trac #10083):
309
310 ---------- RSR.hs-boot ------------
311 module RSR where
312 data RSR
313 eqRSR :: RSR -> RSR -> Bool
314
315 ---------- SR.hs ------------
316 module SR where
317 import {-# SOURCE #-} RSR
318 data SR = MkSR RSR
319 eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
320
321 ---------- RSR.hs ------------
322 module RSR where
323 import SR
324 data RSR = MkRSR SR -- deriving( Eq )
325 eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
326 foo x y = not (eqRSR x y)
327
328 When compiling RSR we get this code
329
330 RSR.eqRSR :: RSR -> RSR -> Bool
331 RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
332 case ds1 of _ { RSR.MkRSR s1 ->
333 case ds2 of _ { RSR.MkRSR s2 ->
334 SR.eqSR s1 s2 }}
335
336 RSR.foo :: RSR -> RSR -> Bool
337 RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)
338
339 Now, when optimising foo:
340 Inline eqRSR (small, non-rec)
341 Inline eqSR (small, non-rec)
342 but the result of inlining eqSR from SR is another call to eqRSR, so
343 everything repeats. Neither eqSR nor eqRSR are (apparently) loop
344 breakers.
345
346 Solution: when compiling RSR, add a NOINLINE pragma to every function
347 exported by the boot-file for RSR (if it exists).
348
349 ALAS: doing so makes the boostrappted GHC itself slower by 8% overall
350 (on Trac #9872a-d, and T1969. So I un-did this change, and
351 parked it for now. Sigh.
352 -}
353
354 tcValBinds :: TopLevelFlag
355 -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
356 -> TcM thing
357 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
358
359 tcValBinds top_lvl binds sigs thing_inside
360 = do { -- Typecheck the signature
361 ; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds $
362 -- See Note [Placeholder PatSyn kinds]
363 tcTySigs sigs
364
365 ; _self_boot <- tcSelfBootInfo
366 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
367
368 -- ------- See Note [Inlining and hs-boot files] (change parked) --------
369 -- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files]
370 -- , SelfBoot { sb_ids = boot_id_names } <- self_boot
371 -- = foldNameSet add_no_inl prag_fn1 boot_id_names
372 -- | otherwise
373 -- = prag_fn1
374 -- add_no_inl boot_id_name prag_fn
375 -- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name)
376 -- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma)
377 -- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module")
378
379 -- Extend the envt right away with all the Ids
380 -- declared with complete type signatures
381 -- Do not extend the TcIdBinderStack; instead
382 -- we extend it on a per-rhs basis in tcExtendForRhs
383 ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
384 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
385 { thing <- thing_inside
386 -- See Note [Pattern synonym builders don't yield dependencies]
387 ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
388 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
389 ; return (extra_binds, thing) }
390 ; return (binds' ++ extra_binds', thing) }}
391 where
392 patsyns = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
393 patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
394 = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
395 placeholder_patsyn_tything
396 = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
397
398 ------------------------
399 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
400 -> [(RecFlag, LHsBinds Name)] -> TcM thing
401 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
402 -- Typecheck a whole lot of value bindings,
403 -- one strongly-connected component at a time
404 -- Here a "strongly connected component" has the strightforward
405 -- meaning of a group of bindings that mention each other,
406 -- ignoring type signatures (that part comes later)
407
408 tcBindGroups _ _ _ [] thing_inside
409 = do { thing <- thing_inside
410 ; return ([], thing) }
411
412 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
413 = do { (group', (groups', thing))
414 <- tc_group top_lvl sig_fn prag_fn group $
415 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
416 ; return (group' ++ groups', thing) }
417
418 ------------------------
419 tc_group :: forall thing.
420 TopLevelFlag -> TcSigFun -> TcPragEnv
421 -> (RecFlag, LHsBinds Name) -> TcM thing
422 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
423
424 -- Typecheck one strongly-connected component of the original program.
425 -- We get a list of groups back, because there may
426 -- be specialisations etc as well
427
428 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
429 -- A single non-recursive binding
430 -- We want to keep non-recursive things non-recursive
431 -- so that we desugar unlifted bindings correctly
432 = do { let bind = case bagToList binds of
433 [bind] -> bind
434 [] -> panic "tc_group: empty list of binds"
435 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
436 ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
437 ; return ( [(NonRecursive, bind')], thing) }
438
439 tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
440 = -- To maximise polymorphism, we do a new
441 -- strongly-connected-component analysis, this time omitting
442 -- any references to variables with type signatures.
443 -- (This used to be optional, but isn't now.)
444 -- See Note [Polymorphic recursion] in HsBinds.
445 do { traceTc "tc_group rec" (pprLHsBinds binds)
446 ; when hasPatSyn $ recursivePatSynErr binds
447 ; (binds1, thing) <- go sccs
448 ; return ([(Recursive, binds1)], thing) }
449 -- Rec them all together
450 where
451 hasPatSyn = anyBag (isPatSyn . unLoc) binds
452 isPatSyn PatSynBind{} = True
453 isPatSyn _ = False
454
455 sccs :: [SCC (LHsBind Name)]
456 sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
457
458 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
459 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
460 ; (binds2, thing) <- tcExtendLetEnv top_lvl ids1 $
461 go sccs
462 ; return (binds1 `unionBags` binds2, thing) }
463 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
464
465 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
466 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
467
468 tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
469
470 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
471 recursivePatSynErr binds
472 = failWithTc $
473 hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
474 2 (vcat $ map pprLBind . bagToList $ binds)
475 where
476 pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
477 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
478 pprLoc loc
479
480 tc_single :: forall thing.
481 TopLevelFlag -> TcSigFun -> TcPragEnv
482 -> LHsBind Name -> TcM thing
483 -> TcM (LHsBinds TcId, thing)
484 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
485 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
486 ; thing <- setGblEnv tcg_env thing_inside
487 ; return (aux_binds, thing)
488 }
489 where
490 tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
491 tc_pat_syn_decl = case sig_fn name of
492 Nothing -> tcInferPatSynDecl psb
493 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
494 Just _ -> panic "tc_single"
495
496 tc_single top_lvl sig_fn prag_fn lbind thing_inside
497 = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
498 NonRecursive NonRecursive
499 [lbind]
500 ; thing <- tcExtendLetEnv top_lvl ids thing_inside
501 ; return (binds1, thing) }
502
503 ------------------------
504 type BKey = Int -- Just number off the bindings
505
506 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
507 -- See Note [Polymorphic recursion] in HsBinds.
508 mkEdges sig_fn binds
509 = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
510 Just key <- [lookupNameEnv key_map n], no_sig n ])
511 | (bind, key) <- keyd_binds
512 ]
513 where
514 no_sig :: Name -> Bool
515 no_sig n = noCompleteSig (sig_fn n)
516
517 keyd_binds = bagToList binds `zip` [0::BKey ..]
518
519 key_map :: NameEnv BKey -- Which binding it comes from
520 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
521 , bndr <- collectHsBindBinders bind ]
522
523 ------------------------
524 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
525 -> RecFlag -- Whether the group is really recursive
526 -> RecFlag -- Whether it's recursive after breaking
527 -- dependencies based on type signatures
528 -> [LHsBind Name] -- None are PatSynBind
529 -> TcM (LHsBinds TcId, [TcId])
530
531 -- Typechecks a single bunch of values bindings all together,
532 -- and generalises them. The bunch may be only part of a recursive
533 -- group, because we use type signatures to maximise polymorphism
534 --
535 -- Returns a list because the input may be a single non-recursive binding,
536 -- in which case the dependency order of the resulting bindings is
537 -- important.
538 --
539 -- Knows nothing about the scope of the bindings
540 -- None of the bindings are pattern synonyms
541
542 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
543 = setSrcSpan loc $
544 recoverM (recoveryCode binder_names sig_fn) $ do
545 -- Set up main recover; take advantage of any type sigs
546
547 { traceTc "------------------------------------------------" Outputable.empty
548 ; traceTc "Bindings for {" (ppr binder_names)
549 ; dflags <- getDynFlags
550 ; type_env <- getLclTypeEnv
551 ; let plan = decideGeneralisationPlan dflags type_env
552 binder_names bind_list sig_fn
553 ; traceTc "Generalisation plan" (ppr plan)
554 ; result@(tc_binds, poly_ids) <- case plan of
555 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
556 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
557 CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
558
559 -- Check whether strict bindings are ok
560 -- These must be non-recursive etc, and are not generalised
561 -- They desugar to a case expression in the end
562 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
563 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
564 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
565 ])
566
567 ; return result }
568 where
569 binder_names = collectHsBindListBinders bind_list
570 loc = foldr1 combineSrcSpans (map getLoc bind_list)
571 -- The mbinds have been dependency analysed and
572 -- may no longer be adjacent; so find the narrowest
573 -- span that includes them all
574
575 ------------------
576 tcPolyNoGen -- No generalisation whatsoever
577 :: RecFlag -- Whether it's recursive after breaking
578 -- dependencies based on type signatures
579 -> TcPragEnv -> TcSigFun
580 -> [LHsBind Name]
581 -> TcM (LHsBinds TcId, [TcId])
582
583 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
584 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
585 (LetGblBndr prag_fn)
586 bind_list
587 ; mono_ids' <- mapM tc_mono_info mono_infos
588 ; return (binds', mono_ids') }
589 where
590 tc_mono_info (name, _, mono_id)
591 = do { mono_ty' <- zonkTcType (idType mono_id)
592 -- Zonk, mainly to expose unboxed types to checkStrictBinds
593 ; let mono_id' = setIdType mono_id mono_ty'
594 ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
595 ; return mono_id' }
596 -- NB: tcPrags generates error messages for
597 -- specialisation pragmas for non-overloaded sigs
598 -- Indeed that is why we call it here!
599 -- So we can safely ignore _specs
600
601 ------------------
602 tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
603 -- dependencies based on type signatures
604 -> TcPragEnv
605 -> TcIdSigInfo
606 -> LHsBind Name
607 -> TcM (LHsBinds TcId, [TcId])
608 -- There is just one binding,
609 -- it binds a single variable,
610 -- it has a complete type signature,
611 tcPolyCheck rec_tc prag_fn
612 sig@(TISI { sig_bndr = CompleteSig poly_id
613 , sig_skols = skol_prs
614 , sig_theta = theta
615 , sig_tau = tau
616 , sig_ctxt = ctxt
617 , sig_loc = loc })
618 bind
619 = do { ev_vars <- newEvVars theta
620 ; let skol_info = SigSkol ctxt (mkPhiTy theta tau)
621 prag_sigs = lookupPragEnv prag_fn name
622 skol_tvs = map snd skol_prs
623 -- Find the location of the original source type sig, if
624 -- there is was one. This will appear in messages like
625 -- "type variable x is bound by .. at <loc>"
626 name = idName poly_id
627 ; (ev_binds, (binds', [mono_info]))
628 <- setSrcSpan loc $
629 checkConstraints skol_info skol_tvs ev_vars $
630 tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind]
631
632 ; spec_prags <- tcSpecPrags poly_id prag_sigs
633 ; poly_id <- addInlinePrags poly_id prag_sigs
634
635 ; let (_, _, mono_id) = mono_info
636 export = ABE { abe_wrap = idHsWrapper
637 , abe_poly = poly_id
638 , abe_mono = mono_id
639 , abe_prags = SpecPrags spec_prags }
640 abs_bind = L loc $ AbsBinds
641 { abs_tvs = skol_tvs
642 , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
643 , abs_exports = [export], abs_binds = binds' }
644 ; return (unitBag abs_bind, [poly_id]) }
645
646 tcPolyCheck _rec_tc _prag_fn sig _bind
647 = pprPanic "tcPolyCheck" (ppr sig)
648
649 ------------------
650 tcPolyInfer
651 :: RecFlag -- Whether it's recursive after breaking
652 -- dependencies based on type signatures
653 -> TcPragEnv -> TcSigFun
654 -> Bool -- True <=> apply the monomorphism restriction
655 -> [LHsBind Name]
656 -> TcM (LHsBinds TcId, [TcId])
657 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
658 = do { (tclvl, wanted, (binds', mono_infos))
659 <- pushLevelAndCaptureConstraints $
660 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
661
662 ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
663 sigs = [ sig | (_, Just sig, _) <- mono_infos ]
664 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
665 ; (qtvs, givens, ev_binds)
666 <- simplifyInfer tclvl mono sigs name_taus wanted
667
668 ; let inferred_theta = map evVarPred givens
669 ; exports <- checkNoErrs $
670 mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
671
672 ; loc <- getSrcSpanM
673 ; let poly_ids = map abe_poly exports
674 abs_bind = L loc $
675 AbsBinds { abs_tvs = qtvs
676 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
677 , abs_exports = exports, abs_binds = binds' }
678
679 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
680 ; return (unitBag abs_bind, poly_ids) }
681 -- poly_ids are guaranteed zonked by mkExport
682
683 --------------
684 mkExport :: TcPragEnv
685 -> [TyVar] -> TcThetaType -- Both already zonked
686 -> MonoBindInfo
687 -> TcM (ABExport Id)
688 -- Only called for generalisation plan IferGen, not by CheckGen or NoGen
689 --
690 -- mkExport generates exports with
691 -- zonked type variables,
692 -- zonked poly_ids
693 -- The former is just because no further unifications will change
694 -- the quantified type variables, so we can fix their final form
695 -- right now.
696 -- The latter is needed because the poly_ids are used to extend the
697 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
698
699 -- Pre-condition: the qtvs and theta are already zonked
700
701 mkExport prag_fn qtvs theta mono_info@(poly_name, mb_sig, mono_id)
702 = do { mono_ty <- zonkTcType (idType mono_id)
703 ; poly_id <- case mb_sig of
704 Just sig | Just poly_id <- completeIdSigPolyId_maybe sig
705 -> return poly_id
706 _other -> checkNoErrs $
707 mkInferredPolyId qtvs theta
708 poly_name mb_sig mono_ty
709 -- The checkNoErrs ensures that if the type is ambiguous
710 -- we don't carry on to the impedence matching, and generate
711 -- a duplicate ambiguity error. There is a similar
712 -- checkNoErrs for complete type signatures too.
713
714 -- NB: poly_id has a zonked type
715 ; poly_id <- addInlinePrags poly_id prag_sigs
716 ; spec_prags <- tcSpecPrags poly_id prag_sigs
717 -- tcPrags requires a zonked poly_id
718
719 -- See Note [Impedence matching]
720 -- NB: we have already done checkValidType, including an ambiguity check,
721 -- on the type; either when we checked the sig or in mkInferredPolyId
722 ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
723 poly_ty = idType poly_id
724 ; wrap <- if sel_poly_ty `eqType` poly_ty
725 then return idHsWrapper -- Fast path; also avoids complaint when we infer
726 -- an ambiguouse type and have AllowAmbiguousType
727 -- e..g infer x :: forall a. F a -> Int
728 else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
729 tcSubType_NC sig_ctxt sel_poly_ty poly_ty
730
731 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
732 ; when warn_missing_sigs $ localSigWarn poly_id mb_sig
733
734 ; return (ABE { abe_wrap = wrap
735 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
736 , abe_poly = poly_id
737 , abe_mono = mono_id
738 , abe_prags = SpecPrags spec_prags}) }
739 where
740 prag_sigs = lookupPragEnv prag_fn poly_name
741 sig_ctxt = InfSigCtxt poly_name
742
743 mkInferredPolyId :: [TyVar] -> TcThetaType
744 -> Name -> Maybe TcIdSigInfo -> TcType
745 -> TcM TcId
746 mkInferredPolyId qtvs inferred_theta poly_name mb_sig mono_ty
747 = do { fam_envs <- tcGetFamInstEnvs
748 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
749 -- Unification may not have normalised the type,
750 -- (see Note [Lazy flattening] in TcFlatten) so do it
751 -- here to make it as uncomplicated as possible.
752 -- Example: f :: [F Int] -> Bool
753 -- should be rewritten to f :: [Char] -> Bool, if possible
754 --
755 -- We can discard the coercion _co, because we'll reconstruct
756 -- it in the call to tcSubType below
757
758 ; (my_tvs, theta') <- chooseInferredQuantifiers
759 inferred_theta (tyVarsOfType mono_ty') mb_sig
760
761 ; let qtvs' = filter (`elemVarSet` my_tvs) qtvs -- Maintain original order
762 inferred_poly_ty = mkSigmaTy qtvs' theta' mono_ty'
763
764 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr my_tvs, ppr theta'
765 , ppr inferred_poly_ty])
766 ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
767 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
768 -- See Note [Validity of inferred types]
769
770 ; return (mkLocalId poly_name inferred_poly_ty) }
771
772
773 chooseInferredQuantifiers :: TcThetaType -> TcTyVarSet -> Maybe TcIdSigInfo
774 -> TcM (TcTyVarSet, TcThetaType)
775 chooseInferredQuantifiers inferred_theta tau_tvs Nothing
776 = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
777 -- Include kind variables! Trac #7916
778
779 ; my_theta <- pickQuantifiablePreds free_tvs inferred_theta
780 ; return (free_tvs, my_theta) }
781
782 chooseInferredQuantifiers inferred_theta tau_tvs
783 (Just (TISI { sig_bndr = bndr_info
784 , sig_ctxt = ctxt
785 , sig_theta = annotated_theta }))
786 | PartialSig { sig_cts = extra } <- bndr_info
787 , Nothing <- extra
788 = do { annotated_theta <- zonkTcThetaType annotated_theta
789 ; let free_tvs = closeOverKinds (tyVarsOfTypes annotated_theta
790 `unionVarSet` tau_tvs)
791 ; traceTc "ciq" (vcat [ ppr bndr_info, ppr annotated_theta, ppr free_tvs])
792 ; return (free_tvs, annotated_theta) }
793
794 | PartialSig { sig_cts = extra } <- bndr_info
795 , Just loc <- extra
796 = do { annotated_theta <- zonkTcThetaType annotated_theta
797 ; let free_tvs = closeOverKinds (tyVarsOfTypes annotated_theta
798 `unionVarSet` tau_tvs)
799 ; my_theta <- pickQuantifiablePreds free_tvs inferred_theta
800
801 -- Report the inferred constraints for an extra-constraints wildcard/hole as
802 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
803 -- case, the extra inferred constraints are accepted without complaining.
804 -- Returns the annotated constraints combined with the inferred constraints.
805 ; let inferred_diff = minusList my_theta annotated_theta
806 final_theta = annotated_theta ++ inferred_diff
807 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
808 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
809 ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
810 ; traceTc "completeTheta" $
811 vcat [ ppr bndr_info
812 , ppr annotated_theta, ppr inferred_theta
813 , ppr inferred_diff ]
814 ; case partial_sigs of
815 True | warn_partial_sigs -> reportWarning msg
816 | otherwise -> return ()
817 False -> reportError msg
818
819 ; return (free_tvs, final_theta) }
820
821 | otherwise = pprPanic "chooseInferredQuantifiers" (ppr bndr_info)
822
823 where
824 pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
825 mk_msg inferred_diff suppress_hint
826 = vcat [ hang ((text "Found constraint wildcard") <+> quotes (char '_'))
827 2 (text "standing for") <+> quotes (pprTheta inferred_diff)
828 , if suppress_hint then empty else pts_hint
829 , typeSigCtxt ctxt bndr_info ]
830
831
832 mk_impedence_match_msg :: MonoBindInfo
833 -> TcType -> TcType
834 -> TidyEnv -> TcM (TidyEnv, SDoc)
835 -- This is a rare but rather awkward error messages
836 mk_impedence_match_msg (name, mb_sig, _) inf_ty sig_ty tidy_env
837 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
838 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
839 ; let msg = vcat [ ptext (sLit "When checking that the inferred type")
840 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
841 , ptext (sLit "is as general as its") <+> what <+> ptext (sLit "signature")
842 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
843 ; return (tidy_env2, msg) }
844 where
845 what = case mb_sig of
846 Nothing -> ptext (sLit "inferred")
847 Just sig | isPartialSig sig -> ptext (sLit "(partial)")
848 | otherwise -> empty
849
850
851 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
852 mk_inf_msg poly_name poly_ty tidy_env
853 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
854 ; let msg = vcat [ ptext (sLit "When checking the inferred type")
855 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
856 ; return (tidy_env1, msg) }
857
858
859 -- | Warn the user about polymorphic local binders that lack type signatures.
860 localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM ()
861 localSigWarn id mb_sig
862 | Just _ <- mb_sig = return ()
863 | not (isSigmaTy (idType id)) = return ()
864 | otherwise = warnMissingSig msg id
865 where
866 msg = ptext (sLit "Polymorphic local binding with no type signature:")
867
868 warnMissingSig :: SDoc -> Id -> TcM ()
869 warnMissingSig msg id
870 = do { env0 <- tcInitTidyEnv
871 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
872 ; addWarnTcM (env1, mk_msg tidy_ty) }
873 where
874 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
875
876 {-
877 Note [Partial type signatures and generalisation]
878 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
879 When we have a partial type signature, like
880 f :: _ -> Int
881 then we *always* use the InferGen plan, and hence tcPolyInfer.
882 We do this even for a local binding with -XMonoLocalBinds.
883 Reasons:
884 * The TcSigInfo for 'f' has a unification variable for the '_',
885 whose TcLevel is one level deeper than the current level.
886 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
887 the TcLevel like InferGen, so we lose the level invariant.
888
889 * The signature might be f :: forall a. _ -> a
890 so it really is polymorphic. It's not clear what it would
891 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
892 in the (Just sig) case, checks that if there is a signature
893 then we are using LetLclBndr, and hence a nested AbsBinds with
894 increased TcLevel
895
896 It might be possible to fix these difficulties somehow, but there
897 doesn't seem much point. Indeed, adding a partial type signature is a
898 way to get per-binding inferred generalisation.
899
900 Note [Validity of inferred types]
901 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
902 We need to check inferred type for validity, in case it uses language
903 extensions that are not turned on. The principle is that if the user
904 simply adds the inferred type to the program source, it'll compile fine.
905 See #8883.
906
907 Examples that might fail:
908 - the type might be ambiguous
909
910 - an inferred theta that requires type equalities e.g. (F a ~ G b)
911 or multi-parameter type classes
912 - an inferred type that includes unboxed tuples
913
914
915 Note [Impedence matching]
916 ~~~~~~~~~~~~~~~~~~~~~~~~~
917 Consider
918 f 0 x = x
919 f n x = g [] (not x)
920
921 g [] y = f 10 y
922 g _ y = f 9 y
923
924 After typechecking we'll get
925 f_mono_ty :: a -> Bool -> Bool
926 g_mono_ty :: [b] -> Bool -> Bool
927 with constraints
928 (Eq a, Num a)
929
930 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
931 The types we really want for f and g are
932 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
933 g :: forall b. [b] -> Bool -> Bool
934
935 We can get these by "impedance matching":
936 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
937 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
938
939 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
940 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
941
942 Suppose the shared quantified tyvars are qtvs and constraints theta.
943 Then we want to check that
944 f's final inferred polytype is more polymorphic than
945 forall qtvs. theta => f_mono_ty
946 and the proof is the impedance matcher.
947
948 Notice that the impedance matcher may do defaulting. See Trac #7173.
949
950 It also cleverly does an ambiguity check; for example, rejecting
951 f :: F a -> a
952 where F is a non-injective type function.
953 -}
954
955 --------------
956 -- If typechecking the binds fails, then return with each
957 -- signature-less binder given type (forall a.a), to minimise
958 -- subsequent error messages
959 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
960 recoveryCode binder_names sig_fn
961 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
962 ; let poly_ids = map mk_dummy binder_names
963 ; return (emptyBag, poly_ids) }
964 where
965 mk_dummy name
966 | Just sig <- sig_fn name
967 , Just poly_id <- completeSigPolyId_maybe sig
968 = poly_id
969 | otherwise
970 = mkLocalId name forall_a_a
971
972 forall_a_a :: TcType
973 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
974
975
976 {- *********************************************************************
977 * *
978 Pragmas, including SPECIALISE
979 * *
980 ************************************************************************
981
982 Note [Handling SPECIALISE pragmas]
983 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
984 The basic idea is this:
985
986 f:: Num a => a -> b -> a
987 {-# SPECIALISE foo :: Int -> b -> Int #-}
988
989 We check that
990 (forall a. Num a => a -> a)
991 is more polymorphic than
992 Int -> Int
993 (for which we could use tcSubType, but see below), generating a HsWrapper
994 to connect the two, something like
995 wrap = /\b. <hole> Int b dNumInt
996 This wrapper is put in the TcSpecPrag, in the ABExport record of
997 the AbsBinds.
998
999
1000 f :: (Eq a, Ix b) => a -> b -> Bool
1001 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
1002 f = <poly_rhs>
1003
1004 From this the typechecker generates
1005
1006 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
1007
1008 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
1009 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
1010
1011 From these we generate:
1012
1013 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
1014 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
1015
1016 Spec bind: f_spec = wrap_fn <poly_rhs>
1017
1018 Note that
1019
1020 * The LHS of the rule may mention dictionary *expressions* (eg
1021 $dfIxPair dp dq), and that is essential because the dp, dq are
1022 needed on the RHS.
1023
1024 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
1025 can fully specialise it.
1026
1027
1028
1029 From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
1030
1031 f_spec :: Int -> b -> Int
1032 f_spec = wrap<f rhs>
1033
1034 RULE: forall b (d:Num b). f b d = f_spec b
1035
1036 The RULE is generated by taking apart the HsWrapper, which is a little
1037 delicate, but works.
1038
1039 Some wrinkles
1040
1041 1. We don't use full-on tcSubType, because that does co and contra
1042 variance and that in turn will generate too complex a LHS for the
1043 RULE. So we use a single invocation of deeplySkolemise /
1044 deeplyInstantiate in tcSpecWrapper. (Actually I think that even
1045 the "deeply" stuff may be too much, because it introduces lambdas,
1046 though I think it can be made to work without too much trouble.)
1047
1048 2. We need to take care with type families (Trac #5821). Consider
1049 type instance F Int = Bool
1050 f :: Num a => a -> F a
1051 {-# SPECIALISE foo :: Int -> Bool #-}
1052
1053 We *could* try to generate an f_spec with precisely the declared type:
1054 f_spec :: Int -> Bool
1055 f_spec = <f rhs> Int dNumInt |> co
1056
1057 RULE: forall d. f Int d = f_spec |> sym co
1058
1059 but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
1060 hard to generate. At all costs we must avoid this:
1061 RULE: forall d. f Int d |> co = f_spec
1062 because the LHS will never match (indeed it's rejected in
1063 decomposeRuleLhs).
1064
1065 So we simply do this:
1066 - Generate a constraint to check that the specialised type (after
1067 skolemiseation) is equal to the instantiated function type.
1068 - But *discard* the evidence (coercion) for that constraint,
1069 so that we ultimately generate the simpler code
1070 f_spec :: Int -> F Int
1071 f_spec = <f rhs> Int dNumInt
1072
1073 RULE: forall d. f Int d = f_spec
1074 You can see this discarding happening in
1075
1076 3. Note that the HsWrapper can transform *any* function with the right
1077 type prefix
1078 forall ab. (Eq a, Ix b) => XXX
1079 regardless of XXX. It's sort of polymorphic in XXX. This is
1080 useful: we use the same wrapper to transform each of the class ops, as
1081 well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags
1082 -}
1083
1084 mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv
1085 mkPragEnv sigs binds
1086 = foldl extendPragEnv emptyNameEnv prs
1087 where
1088 prs = mapMaybe get_sig sigs
1089
1090 get_sig :: LSig Name -> Maybe (Name, LSig Name)
1091 get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
1092 get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
1093 get_sig _ = Nothing
1094
1095 add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
1096 | Inline <- inl_inline inl_prag
1097 -- add arity only for real INLINE pragmas, not INLINABLE
1098 = case lookupNameEnv ar_env n of
1099 Just ar -> inl_prag { inl_sat = Just ar }
1100 Nothing -> WARN( True, ptext (sLit "mkPragEnv no arity") <+> ppr n )
1101 -- There really should be a binding for every INLINE pragma
1102 inl_prag
1103 | otherwise
1104 = inl_prag
1105
1106 -- ar_env maps a local to the arity of its definition
1107 ar_env :: NameEnv Arity
1108 ar_env = foldrBag lhsBindArity emptyNameEnv binds
1109
1110 extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv
1111 extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
1112
1113 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
1114 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
1115 = extendNameEnv env (unLoc id) (matchGroupArity ms)
1116 lhsBindArity _ env = env -- PatBind/VarBind
1117
1118 ------------------
1119 tcSpecPrags :: Id -> [LSig Name]
1120 -> TcM [LTcSpecPrag]
1121 -- Add INLINE and SPECIALSE pragmas
1122 -- INLINE prags are added to the (polymorphic) Id directly
1123 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
1124 -- Pre-condition: the poly_id is zonked
1125 -- Reason: required by tcSubExp
1126 tcSpecPrags poly_id prag_sigs
1127 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
1128 ; unless (null bad_sigs) warn_discarded_sigs
1129 ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
1130 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
1131 where
1132 spec_sigs = filter isSpecLSig prag_sigs
1133 bad_sigs = filter is_bad_sig prag_sigs
1134 is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
1135
1136 warn_discarded_sigs
1137 = addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id)
1138 2 (vcat (map (ppr . getLoc) bad_sigs)))
1139
1140 --------------
1141 tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]
1142 tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
1143 -- See Note [Handling SPECIALISE pragmas]
1144 --
1145 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
1146 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
1147 -- for the selector Id, but the poly_id is something like $cop
1148 -- However we want to use fun_name in the error message, since that is
1149 -- what the user wrote (Trac #8537)
1150 = addErrCtxt (spec_ctxt prag) $
1151 do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
1152 (ptext (sLit "SPECIALISE pragma for non-overloaded function")
1153 <+> quotes (ppr fun_name))
1154 -- Note [SPECIALISE pragmas]
1155 ; spec_prags <- mapM tc_one hs_tys
1156 ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
1157 ; return spec_prags }
1158 where
1159 name = idName poly_id
1160 poly_ty = idType poly_id
1161 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1162
1163 tc_one hs_ty
1164 = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty
1165 ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty
1166 ; return (SpecPrag poly_id wrap inl) }
1167
1168 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
1169
1170 --------------
1171 tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
1172 -- A simpler variant of tcSubType, used for SPECIALISE pragmas
1173 -- See Note [Handling SPECIALISE pragmas], wrinkle 1
1174 tcSpecWrapper ctxt poly_ty spec_ty
1175 = do { (sk_wrap, inst_wrap)
1176 <- tcGen ctxt spec_ty $ \ _ spec_tau ->
1177 do { (inst_wrap, tau) <- deeplyInstantiate orig poly_ty
1178 ; _ <- unifyType spec_tau tau
1179 -- Deliberately ignore the evidence
1180 -- See Note [Handling SPECIALISE pragmas],
1181 -- wrinkle (2)
1182 ; return inst_wrap }
1183 ; return (sk_wrap <.> inst_wrap) }
1184 where
1185 orig = SpecPragOrigin ctxt
1186
1187 --------------
1188 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
1189 -- SPECIALISE pragmas for imported things
1190 tcImpPrags prags
1191 = do { this_mod <- getModule
1192 ; dflags <- getDynFlags
1193 ; if (not_specialising dflags) then
1194 return []
1195 else do
1196 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
1197 [L loc (name,prag)
1198 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
1199 , not (nameIsLocalOrFrom this_mod name) ]
1200 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
1201 where
1202 -- Ignore SPECIALISE pragmas for imported things
1203 -- when we aren't specialising, or when we aren't generating
1204 -- code. The latter happens when Haddocking the base library;
1205 -- we don't wnat complaints about lack of INLINABLE pragmas
1206 not_specialising dflags
1207 | not (gopt Opt_Specialise dflags) = True
1208 | otherwise = case hscTarget dflags of
1209 HscNothing -> True
1210 HscInterpreted -> True
1211 _other -> False
1212
1213 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
1214 tcImpSpec (name, prag)
1215 = do { id <- tcLookupId name
1216 ; unless (isAnyInlinePragma (idInlinePragma id))
1217 (addWarnTc (impSpecErr name))
1218 ; tcSpecPrag id prag }
1219
1220 impSpecErr :: Name -> SDoc
1221 impSpecErr name
1222 = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
1223 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
1224 , parens $ sep
1225 [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
1226 , ptext (sLit "was compiled without -O")]])
1227 where
1228 mod = nameModule name
1229
1230
1231 {- *********************************************************************
1232 * *
1233 Vectorisation
1234 * *
1235 ********************************************************************* -}
1236
1237 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1238 tcVectDecls decls
1239 = do { decls' <- mapM (wrapLocM tcVect) decls
1240 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1241 dups = findDupsEq (==) ids
1242 ; mapM_ reportVectDups dups
1243 ; traceTcConstraints "End of tcVectDecls"
1244 ; return decls'
1245 }
1246 where
1247 reportVectDups (first:_second:_more)
1248 = addErrAt (getSrcSpan first) $
1249 ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
1250 reportVectDups _ = return ()
1251
1252 --------------
1253 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1254 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1255 -- type of the original definition as this requires internals of the vectoriser not available
1256 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1257 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1258 -- from the vectoriser here.
1259 tcVect (HsVect s name rhs)
1260 = addErrCtxt (vectCtxt name) $
1261 do { var <- wrapLocM tcLookupId name
1262 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1263 ; rhs_id <- tcLookupId rhs_var_name
1264 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1265 }
1266
1267 {- OLD CODE:
1268 -- turn the vectorisation declaration into a single non-recursive binding
1269 ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
1270 sigFun = const Nothing
1271 pragFun = emptyPragEnv
1272
1273 -- perform type inference (including generalisation)
1274 ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
1275
1276 ; traceTc "tcVect inferred type" $ ppr (varType id')
1277 ; traceTc "tcVect bindings" $ ppr binds
1278
1279 -- add all bindings, including the type variable and dictionary bindings produced by type
1280 -- generalisation to the right-hand side of the vectorisation declaration
1281 ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
1282 ; let [bind'] = bagToList actualBinds
1283 MatchGroup
1284 [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
1285 _ = (fun_matches . unLoc) bind'
1286 rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
1287
1288 -- We return the type-checked 'Id', to propagate the inferred signature
1289 -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
1290 ; return $ HsVect (L loc id') (Just rhsWrapped)
1291 }
1292 -}
1293 tcVect (HsNoVect s name)
1294 = addErrCtxt (vectCtxt name) $
1295 do { var <- wrapLocM tcLookupId name
1296 ; return $ HsNoVect s var
1297 }
1298 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1299 = addErrCtxt (vectCtxt lname) $
1300 do { tycon <- tcLookupLocatedTyCon lname
1301 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1302 || isJust rhs_name -- or we explicitly provide a vectorised type
1303 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1304 )
1305 scalarTyConMustBeNullary
1306
1307 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1308 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1309 }
1310 tcVect (HsVectTypeOut _ _ _)
1311 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1312 tcVect (HsVectClassIn _ lname)
1313 = addErrCtxt (vectCtxt lname) $
1314 do { cls <- tcLookupLocatedClass lname
1315 ; return $ HsVectClassOut cls
1316 }
1317 tcVect (HsVectClassOut _)
1318 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1319 tcVect (HsVectInstIn linstTy)
1320 = addErrCtxt (vectCtxt linstTy) $
1321 do { (cls, tys) <- tcHsVectInst linstTy
1322 ; inst <- tcLookupInstance cls tys
1323 ; return $ HsVectInstOut inst
1324 }
1325 tcVect (HsVectInstOut _)
1326 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1327
1328 vectCtxt :: Outputable thing => thing -> SDoc
1329 vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
1330
1331 scalarTyConMustBeNullary :: MsgDoc
1332 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
1333
1334 {-
1335 Note [SPECIALISE pragmas]
1336 ~~~~~~~~~~~~~~~~~~~~~~~~~
1337 There is no point in a SPECIALISE pragma for a non-overloaded function:
1338 reverse :: [a] -> [a]
1339 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1340
1341 But SPECIALISE INLINE *can* make sense for GADTS:
1342 data Arr e where
1343 ArrInt :: !Int -> ByteArray# -> Arr Int
1344 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1345
1346 (!:) :: Arr e -> Int -> e
1347 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1348 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1349 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1350 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1351
1352 When (!:) is specialised it becomes non-recursive, and can usefully
1353 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1354 for a non-overloaded function.
1355
1356 ************************************************************************
1357 * *
1358 tcMonoBinds
1359 * *
1360 ************************************************************************
1361
1362 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1363 The signatures have been dealt with already.
1364
1365 Note [Pattern bindings]
1366 ~~~~~~~~~~~~~~~~~~~~~~~
1367 The rule for typing pattern bindings is this:
1368
1369 ..sigs..
1370 p = e
1371
1372 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1373 typechecks exactly like
1374
1375 ..sigs..
1376 x = e -- Inferred type
1377 v1 = case x of p -> v1
1378 ..
1379 vn = case x of p -> vn
1380
1381 Note that
1382 (f :: forall a. a -> a) = id
1383 should not typecheck because
1384 case id of { (f :: forall a. a->a) -> f }
1385 will not typecheck.
1386 -}
1387
1388 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1389 -- i.e. the binders are mentioned in their RHSs, and
1390 -- we are not rescued by a type signature
1391 -> TcSigFun -> LetBndrSpec
1392 -> [LHsBind Name]
1393 -> TcM (LHsBinds TcId, [MonoBindInfo])
1394
1395 tcMonoBinds is_rec sig_fn no_gen
1396 [ L b_loc (FunBind { fun_id = L nm_loc name,
1397 fun_matches = matches, bind_fvs = fvs })]
1398 -- Single function binding,
1399 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1400 , Nothing <- sig_fn name -- ...with no type signature
1401 = -- In this very special case we infer the type of the
1402 -- right hand side first (it may have a higher-rank type)
1403 -- and *then* make the monomorphic Id for the LHS
1404 -- e.g. f = \(x::forall a. a->a) -> <body>
1405 -- We want to infer a higher-rank type for f
1406 setSrcSpan b_loc $
1407 do { rhs_ty <- newFlexiTyVarTy openTypeKind
1408 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1409 ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1410 -- We extend the error context even for a non-recursive
1411 -- function so that in type error messages we show the
1412 -- type of the thing whose rhs we are type checking
1413 tcMatchesFun name matches rhs_ty
1414
1415 ; return (unitBag $ L b_loc $
1416 FunBind { fun_id = L nm_loc mono_id,
1417 fun_matches = matches', bind_fvs = fvs,
1418 fun_co_fn = co_fn, fun_tick = [] },
1419 [(name, Nothing, mono_id)]) }
1420
1421 tcMonoBinds _ sig_fn no_gen binds
1422 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1423
1424 -- Bring the monomorphic Ids, into scope for the RHSs
1425 ; let mono_info = getMonoBindInfo tc_binds
1426 rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
1427 , case mb_sig of
1428 Just sig -> isPartialSig sig
1429 Nothing -> True ]
1430 -- A monomorphic binding for each term variable that lacks
1431 -- a type sig. (Ones with a sig are already in scope.)
1432
1433 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1434 | (n,id) <- rhs_id_env]
1435 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1436 mapM (wrapLocM tcRhs) tc_binds
1437 ; return (listToBag binds', mono_info) }
1438
1439 ------------------------
1440 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1441 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1442 -- if there's a signature for it, use the instantiated signature type
1443 -- otherwise invent a type variable
1444 -- You see that quite directly in the FunBind case.
1445 --
1446 -- But there's a complication for pattern bindings:
1447 -- data T = MkT (forall a. a->a)
1448 -- MkT f = e
1449 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1450 -- but we want to get (f::forall a. a->a) as the RHS environment.
1451 -- The simplest way to do this is to typecheck the pattern, and then look up the
1452 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1453 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1454
1455 data TcMonoBind -- Half completed; LHS done, RHS not done
1456 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1457 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1458
1459 type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId)
1460 -- Type signature (if any), and
1461 -- the monomorphic bound things
1462
1463 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1464 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1465 | Just (TcIdSig sig) <- sig_fn name
1466 , TISI { sig_tau = tau } <- sig
1467 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1468 , ppr name )
1469 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1470 -- or InferGen (partial signature)
1471 -- see Note [Partial type signatures and generalisation]
1472 -- Both InferGen and CheckGen gives rise to LetLclBndr
1473 do { mono_name <- newLocalName name
1474 ; let mono_id = mkLocalId mono_name tau
1475 ; return (TcFunBind (name, Just sig, mono_id) nm_loc matches) }
1476
1477 | otherwise
1478 = do { mono_ty <- newFlexiTyVarTy openTypeKind
1479 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1480 ; return (TcFunBind (name, Nothing, mono_id) nm_loc matches) }
1481
1482 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1483 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1484 mapM lookup_info (collectPatBinders pat)
1485
1486 -- After typechecking the pattern, look up the binder
1487 -- names, which the pattern has brought into scope.
1488 lookup_info :: Name -> TcM MonoBindInfo
1489 lookup_info name
1490 = do { mono_id <- tcLookupId name
1491 ; let mb_sig = case sig_fn name of
1492 Just (TcIdSig sig) -> Just sig
1493 _ -> Nothing
1494 ; return (name, mb_sig, mono_id) }
1495
1496 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1497 tcInfer tc_pat
1498
1499 ; return (TcPatBind infos pat' grhss pat_ty) }
1500
1501 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1502 -- AbsBind, VarBind impossible
1503
1504 -------------------
1505 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1506 tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc matches)
1507 = tcExtendIdBinderStackForRhs [info] $
1508 tcExtendTyVarEnvForRhs mb_sig $
1509 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1510 ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
1511 matches (idType mono_id)
1512 ; return (FunBind { fun_id = L loc mono_id
1513 , fun_matches = matches'
1514 , fun_co_fn = co_fn
1515 , bind_fvs = placeHolderNamesTc
1516 , fun_tick = [] }) }
1517
1518 -- TODO: emit Hole Constraints for wildcards
1519 tcRhs (TcPatBind infos pat' grhss pat_ty)
1520 = -- When we are doing pattern bindings we *don't* bring any scoped
1521 -- type variables into scope unlike function bindings
1522 -- Wny not? They are not completely rigid.
1523 -- That's why we have the special case for a single FunBind in tcMonoBinds
1524 tcExtendIdBinderStackForRhs infos $
1525 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1526 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1527 tcGRHSsPat grhss pat_ty
1528 ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
1529 , bind_fvs = placeHolderNamesTc
1530 , pat_ticks = ([],[]) }) }
1531
1532 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInfo -> TcM a -> TcM a
1533 tcExtendTyVarEnvForRhs Nothing thing_inside
1534 = thing_inside
1535 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1536 = tcExtendTyVarEnvFromSig sig thing_inside
1537
1538 tcExtendTyVarEnvFromSig :: TcIdSigInfo -> TcM a -> TcM a
1539 tcExtendTyVarEnvFromSig sig thing_inside
1540 | TISI { sig_bndr = s_bndr, sig_skols = skol_prs, sig_ctxt = ctxt } <- sig
1541 = tcExtendTyVarEnv2 skol_prs $
1542 case s_bndr of
1543 CompleteSig {} -> thing_inside
1544 PartialSig { sig_wcs = wc_prs } -- Extend the env ad emit the holes
1545 -> tcExtendTyVarEnv2 wc_prs $
1546 do { addErrCtxt (typeSigCtxt ctxt s_bndr) $
1547 emitWildCardHoleConstraints wc_prs
1548 ; thing_inside }
1549
1550 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1551 -- Extend the TcIdBinderStack for the RHS of the binding, with
1552 -- the monomorphic Id. That way, if we have, say
1553 -- f = \x -> blah
1554 -- and something goes wrong in 'blah', we get a "relevant binding"
1555 -- looking like f :: alpha -> beta
1556 -- This applies if 'f' has a type signature too:
1557 -- f :: forall a. [a] -> [a]
1558 -- f x = True
1559 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1560 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1561 -- would not be reported as relevant, because its type is closed
1562 tcExtendIdBinderStackForRhs infos thing_inside
1563 = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside
1564 -- NotTopLevel: it's a monomorphic binding
1565
1566 ---------------------
1567 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1568 getMonoBindInfo tc_binds
1569 = foldr (get_info . unLoc) [] tc_binds
1570 where
1571 get_info (TcFunBind info _ _) rest = info : rest
1572 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1573
1574 {-
1575 ************************************************************************
1576 * *
1577 Signatures
1578 * *
1579 ************************************************************************
1580
1581 Type signatures are tricky. See Note [Signature skolems] in TcType
1582
1583 @tcSigs@ checks the signatures for validity, and returns a list of
1584 {\em freshly-instantiated} signatures. That is, the types are already
1585 split up, and have fresh type variables installed. All non-type-signature
1586 "RenamedSigs" are ignored.
1587
1588 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1589 the variable's type, and after that checked to see whether they've
1590 been instantiated.
1591
1592 Note [Scoped tyvars]
1593 ~~~~~~~~~~~~~~~~~~~~
1594 The -XScopedTypeVariables flag brings lexically-scoped type variables
1595 into scope for any explicitly forall-quantified type variables:
1596 f :: forall a. a -> a
1597 f x = e
1598 Then 'a' is in scope inside 'e'.
1599
1600 However, we do *not* support this
1601 - For pattern bindings e.g
1602 f :: forall a. a->a
1603 (f,g) = e
1604
1605 Note [Signature skolems]
1606 ~~~~~~~~~~~~~~~~~~~~~~~~
1607 When instantiating a type signature, we do so with either skolems or
1608 SigTv meta-type variables depending on the use_skols boolean. This
1609 variable is set True when we are typechecking a single function
1610 binding; and False for pattern bindings and a group of several
1611 function bindings.
1612
1613 Reason: in the latter cases, the "skolems" can be unified together,
1614 so they aren't properly rigid in the type-refinement sense.
1615 NB: unless we are doing H98, each function with a sig will be done
1616 separately, even if it's mutually recursive, so use_skols will be True
1617
1618
1619 Note [Only scoped tyvars are in the TyVarEnv]
1620 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1621 We are careful to keep only the *lexically scoped* type variables in
1622 the type environment. Why? After all, the renamer has ensured
1623 that only legal occurrences occur, so we could put all type variables
1624 into the type env.
1625
1626 But we want to check that two distinct lexically scoped type variables
1627 do not map to the same internal type variable. So we need to know which
1628 the lexically-scoped ones are... and at the moment we do that by putting
1629 only the lexically scoped ones into the environment.
1630
1631 Note [Instantiate sig with fresh variables]
1632 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1633 It's vital to instantiate a type signature with fresh variables.
1634 For example:
1635 type T = forall a. [a] -> [a]
1636 f :: T;
1637 f = g where { g :: T; g = <rhs> }
1638
1639 We must not use the same 'a' from the defn of T at both places!!
1640 (Instantiation is only necessary because of type synonyms. Otherwise,
1641 it's all cool; each signature has distinct type variables from the renamer.)
1642
1643 Note [Fail eagerly on bad signatures]
1644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1645 If a type signaure is wrong, fail immediately:
1646
1647 * the type sigs may bind type variables, so proceeding without them
1648 can lead to a cascade of errors
1649
1650 * the type signature might be ambiguous, in which case checking
1651 the code against the signature will give a very similar error
1652 to the ambiguity error.
1653
1654 ToDo: this means we fall over if any type sig
1655 is wrong (eg at the top level of the module),
1656 which is over-conservative
1657 -}
1658
1659 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
1660 tcTySigs hs_sigs
1661 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1662 do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
1663 ; let ty_sigs = concat ty_sigs_s
1664 poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
1665 -- The returned [TcId] are the ones for which we have
1666 -- a complete type signature.
1667 -- See Note [Complete and partial type signatures]
1668 env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
1669 ; return (poly_ids, lookupNameEnv env) }
1670
1671 tcTySig :: LSig Name -> TcM [TcSigInfo]
1672 tcTySig (L _ (IdSig id))
1673 = do { sig <- instTcTySigFromId id
1674 ; return [TcIdSig sig] }
1675
1676 tcTySig (L loc (TypeSig names sig_ty))
1677 = setSrcSpan loc $
1678 do { sigs <- sequence [ tcUserTypeSig sig_ty (Just name)
1679 | L _ name <- names ]
1680 ; return (map TcIdSig sigs) }
1681
1682 tcTySig (L loc (PatSynSig (L _ name) sig_ty))
1683 | HsIB { hsib_kvs = sig_kvs
1684 , hsib_tvs = sig_tvs
1685 , hsib_body = hs_ty } <- sig_ty
1686 , (tv_bndrs, req, prov, body_ty) <- splitLHsPatSynTy hs_ty
1687 = setSrcSpan loc $
1688 tcImplicitTKBndrs sig_kvs sig_tvs $ \ _ tvs1 ->
1689 tcHsTyVarBndrs tv_bndrs $ \ tvs2 ->
1690 do { req' <- tcHsContext req
1691 ; prov' <- tcHsContext prov
1692 ; ty' <- tcHsLiftedType body_ty
1693
1694 -- These are /signatures/ so we zonk to squeeze out any kind
1695 -- unification variables. ToDo: checkValidType?
1696 ; qtvs' <- mapM zonkQuantifiedTyVar (tvs1 ++ tvs2)
1697 ; req' <- zonkTcThetaType req'
1698 ; prov' <- zonkTcThetaType prov'
1699 ; ty' <- zonkTcType ty'
1700
1701 ; let (_, pat_ty) = tcSplitFunTys ty'
1702 univ_set = tyVarsOfType pat_ty
1703 (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
1704 bad_tvs = varSetElems (tyVarsOfTypes req' `minusVarSet` univ_set)
1705
1706 ; unless (null bad_tvs) $ addErr $
1707 hang (ptext (sLit "The 'required' context") <+> quotes (pprTheta req'))
1708 2 (ptext (sLit "mentions existential type variable") <> plural bad_tvs
1709 <+> pprQuotedList bad_tvs)
1710
1711 ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
1712 ; let tpsi = TPSI{ patsig_name = name,
1713 patsig_tau = ty',
1714 patsig_ex = ex_tvs,
1715 patsig_univ = univ_tvs,
1716 patsig_prov = prov',
1717 patsig_req = req' }
1718 ; return [TcPatSynSig tpsi] }
1719
1720 tcTySig _ = return []
1721
1722 isCompleteHsSig :: LHsSigWcType Name -> Bool
1723 -- ^ If there are no wildcards, return a LHsSigType
1724 isCompleteHsSig sig_ty
1725 | HsWC { hswc_wcs = wcs, hswc_ctx = extra } <- hsib_body sig_ty
1726 , null wcs
1727 , Nothing <- extra
1728 = True
1729 | otherwise
1730 = False
1731
1732 tcUserTypeSig :: LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo
1733 -- Just n => Function type signatre name :: type
1734 -- Nothing => Expression type signature <expr> :: type
1735 tcUserTypeSig hs_sig_ty mb_name
1736 | isCompleteHsSig hs_sig_ty
1737 = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1738 -- so that they can be unified under the forall
1739 do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
1740 ; (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1741 ; loc <- getSrcSpanM
1742 ; return $
1743 TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty)
1744 , sig_skols = findScopedTyVars sigma_ty inst_tvs
1745 , sig_theta = theta
1746 , sig_tau = tau
1747 , sig_ctxt = ctxt_T
1748 , sig_loc = loc } }
1749
1750 -- Partial sig with wildcards
1751 | HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = wc_ty } <- hs_sig_ty
1752 , HsWC { hswc_wcs = wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty
1753 , (hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
1754 = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1755 -- so that they can be unified under the forall
1756 tcImplicitTKBndrs kvs tvs $ \ kvs1 tvs1 ->
1757 tcWildCardBinders wcs $ \ wcs ->
1758 tcHsTyVarBndrs hs_tvs $ \ tvs2 ->
1759 do { -- Instantiate the type-class context; but if there
1760 -- is an extra-constraints wildcard, just discard it here
1761 traceTc "tcPartial" (ppr name $$ ppr tvs $$ ppr tvs1 $$ ppr wcs)
1762 ; theta <- mapM tcLHsPredType $
1763 case extra of
1764 Nothing -> hs_ctxt
1765 Just _ -> dropTail 1 hs_ctxt
1766
1767 ; tau <- tcHsOpenType hs_tau
1768
1769 -- Check for validity (eg rankN etc)
1770 -- The ambiguity check will happen (from checkValidType),
1771 -- but unnecessarily; it will always succeed because there
1772 -- is no quantification
1773 ; _ <- zonkAndCheckValidity ctxt_F (mkPhiTy theta tau)
1774
1775 ; loc <- getSrcSpanM
1776 ; return $
1777 TISI { sig_bndr = PartialSig { sig_name = name, sig_hs_ty = hs_ty
1778 , sig_cts = extra, sig_wcs = wcs }
1779 , sig_skols = [ (tyVarName tv, tv) | tv <- kvs1 ++ tvs1 ++ tvs2 ]
1780 , sig_theta = theta
1781 , sig_tau = tau
1782 , sig_ctxt = ctxt_F
1783 , sig_loc = loc } }
1784 where
1785 name = case mb_name of
1786 Just n -> n
1787 Nothing -> mkUnboundName (mkVarOcc "<expression>")
1788 ctxt_F = case mb_name of
1789 Just n -> FunSigCtxt n False
1790 Nothing -> ExprSigCtxt
1791 ctxt_T = case mb_name of
1792 Just n -> FunSigCtxt n True
1793 Nothing -> ExprSigCtxt
1794
1795 instTcTySigFromId :: Id -> TcM TcIdSigInfo
1796 -- Used for instance methods and record selectors
1797 instTcTySigFromId id
1798 = do { let name = idName id
1799 loc = getSrcSpan name
1800 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1801 (idType id)
1802 ; return $ TISI { sig_bndr = CompleteSig id
1803 -- False: do not report redundant constraints
1804 -- The user has no control over the signature!
1805 , sig_skols = [(tyVarName tv, tv) | tv <- tvs]
1806 , sig_theta = theta
1807 , sig_tau = tau
1808 , sig_ctxt = FunSigCtxt name False
1809 , sig_loc = loc } }
1810
1811 instTcTySig :: UserTypeCtxt
1812 -> LHsSigType Name -- Used to get the scoped type variables
1813 -> TcType
1814 -> Name -- Name of the function
1815 -> TcM TcIdSigInfo
1816 instTcTySig ctxt hs_ty sigma_ty name
1817 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1818 ; return (TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty)
1819 , sig_skols = findScopedTyVars sigma_ty inst_tvs
1820 , sig_theta = theta
1821 , sig_tau = tau
1822 , sig_ctxt = ctxt
1823 , sig_loc = getLoc (hsSigType hs_ty)
1824 -- SrcSpan from the signature
1825 }) }
1826
1827 -------------------------------
1828 data GeneralisationPlan
1829 = NoGen -- No generalisation, no AbsBinds
1830
1831 | InferGen -- Implicit generalisation; there is an AbsBinds
1832 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1833
1834 | CheckGen (LHsBind Name) TcIdSigInfo
1835 -- One binding with a signature
1836 -- Explicit generalisation; there is an AbsBinds
1837
1838 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1839 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1840
1841 instance Outputable GeneralisationPlan where
1842 ppr NoGen = ptext (sLit "NoGen")
1843 ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b
1844 ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
1845
1846 decideGeneralisationPlan
1847 :: DynFlags -> TcTypeEnv -> [Name]
1848 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1849 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1850 | unlifted_pat_binds = NoGen
1851 | Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig
1852 | mono_local_binds = NoGen
1853 | otherwise = InferGen mono_restriction
1854 where
1855 bndr_set = mkNameSet bndr_names
1856 binds = map unLoc lbinds
1857
1858 sig_plan :: (LHsBind Name, TcIdSigInfo) -> GeneralisationPlan
1859 -- See Note [Partial type signatures and generalisation]
1860 -- We use InferGen False to say "do inference, but do not apply
1861 -- the MR". It's stupid to apply the MR when we are given a
1862 -- signature! C.f Trac #11016, function f2
1863 sig_plan (lbind, sig@(TISI { sig_bndr = s_bndr, sig_theta = theta }))
1864 = case s_bndr of
1865 CompleteSig {} -> CheckGen lbind sig
1866 PartialSig { sig_cts = extra_constraints }
1867 | Nothing <- extra_constraints
1868 , [] <- theta
1869 -> InferGen True -- No signature constraints: apply the MR
1870 | otherwise
1871 -> InferGen False -- Don't apply the MR
1872
1873 unlifted_pat_binds = any isUnliftedHsBind binds
1874 -- Unlifted patterns (unboxed tuple) must not
1875 -- be polymorphic, because we are going to force them
1876 -- See Trac #4498, #8762
1877
1878 mono_restriction = xopt Opt_MonomorphismRestriction dflags
1879 && any restricted binds
1880
1881 is_closed_ns :: NameSet -> Bool -> Bool
1882 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1883 -- ns are the Names referred to from the RHS of this bind
1884
1885 is_closed_id :: Name -> Bool
1886 -- See Note [Bindings with closed types] in TcRnTypes
1887 is_closed_id name
1888 | name `elemNameSet` bndr_set
1889 = True -- Ignore binders in this groups, of course
1890 | Just thing <- lookupNameEnv type_env name
1891 = case thing of
1892 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1893 ATyVar {} -> False -- In-scope type variables
1894 AGlobal {} -> True -- are not closed!
1895 _ -> pprPanic "is_closed_id" (ppr name)
1896 | otherwise
1897 = WARN( isInternalName name, ppr name ) True
1898 -- The free-var set for a top level binding mentions
1899 -- imported things too, so that we can report unused imports
1900 -- These won't be in the local type env.
1901 -- Ditto class method etc from the current module
1902
1903 mono_local_binds = xopt Opt_MonoLocalBinds dflags
1904 && not closed_flag
1905
1906 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1907
1908 no_sig n = noCompleteSig (sig_fn n)
1909
1910 -- With OutsideIn, all nested bindings are monomorphic
1911 -- except a single function binding with a signature
1912 one_funbind_with_sig
1913 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1914 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1915 = Just (lbind, sig)
1916 | otherwise
1917 = Nothing
1918
1919 -- The Haskell 98 monomorphism resetriction
1920 restricted (PatBind {}) = True
1921 restricted (VarBind { var_id = v }) = no_sig v
1922 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1923 && no_sig (unLoc v)
1924 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1925 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1926
1927 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
1928 restricted_match _ = False
1929 -- No args => like a pattern binding
1930 -- Some args => a function binding
1931
1932 -------------------
1933 checkStrictBinds :: TopLevelFlag -> RecFlag
1934 -> [LHsBind Name]
1935 -> LHsBinds TcId -> [Id]
1936 -> TcM ()
1937 -- Check that non-overloaded unlifted bindings are
1938 -- a) non-recursive,
1939 -- b) not top level,
1940 -- c) not a multiple-binding group (more or less implied by (a))
1941
1942 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1943 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1944 = do { check (isNotTopLevel top_lvl)
1945 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1946 ; check (isNonRec rec_group)
1947 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1948
1949 ; check (all is_monomorphic (bagToList tc_binds))
1950 (polyBindErr orig_binds)
1951 -- data Ptr a = Ptr Addr#
1952 -- f x = let p@(Ptr y) = ... in ...
1953 -- Here the binding for 'p' is polymorphic, but does
1954 -- not mix with an unlifted binding for 'y'. You should
1955 -- use a bang pattern. Trac #6078.
1956
1957 ; check (isSingleton orig_binds)
1958 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1959
1960 -- Complain about a binding that looks lazy
1961 -- e.g. let I# y = x in ...
1962 -- Remember, in checkStrictBinds we are going to do strict
1963 -- matching, so (for software engineering reasons) we insist
1964 -- that the strictness is manifest on each binding
1965 -- However, lone (unboxed) variables are ok
1966 ; check (not any_pat_looks_lazy)
1967 (unliftedMustBeBang orig_binds) }
1968 | otherwise
1969 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1970 return ()
1971 where
1972 any_unlifted_bndr = any is_unlifted poly_ids
1973 any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds
1974 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1975
1976 is_unlifted id = case tcSplitSigmaTy (idType id) of
1977 (_, _, rho) -> isUnLiftedType rho
1978 -- For the is_unlifted check, we need to look inside polymorphism
1979 -- and overloading. E.g. x = (# 1, True #)
1980 -- would get type forall a. Num a => (# a, Bool #)
1981 -- and we want to reject that. See Trac #9140
1982
1983 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1984 = null tvs && null evs
1985 is_monomorphic _ = True
1986
1987 check :: Bool -> MsgDoc -> TcM ()
1988 -- Just like checkTc, but with a special case for module GHC.Prim:
1989 -- see Note [Compiling GHC.Prim]
1990 check True _ = return ()
1991 check False err = do { mod <- getModule
1992 ; checkTc (mod == gHC_PRIM) err }
1993
1994 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1995 unliftedMustBeBang binds
1996 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1997 2 (vcat (map ppr binds))
1998
1999 polyBindErr :: [LHsBind Name] -> SDoc
2000 polyBindErr binds
2001 = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
2002 2 (vcat [vcat (map ppr binds),
2003 ptext (sLit "Probable fix: add a type signature")])
2004
2005 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
2006 strictBindErr flavour any_unlifted_bndr binds
2007 = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
2008 2 (vcat (map ppr binds))
2009 where
2010 msg | any_unlifted_bndr = ptext (sLit "bindings for unlifted types")
2011 | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
2012
2013
2014 {- Note [Compiling GHC.Prim]
2015 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2016 Module GHC.Prim has no source code: it is the host module for
2017 primitive, built-in functions and types. However, for Haddock-ing
2018 purposes we generate (via utils/genprimopcode) a fake source file
2019 GHC/Prim.hs, and give it to Haddock, so that it can generate
2020 documentation. It contains definitions like
2021 nullAddr# :: NullAddr#
2022 which would normally be rejected as a top-level unlifted binding. But
2023 we don't want to complain, because we are only "compiling" this fake
2024 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
2025 in checkStrictBinds.
2026
2027 (We only make the test if things look wrong, so there is no cost in
2028 the common case.) -}
2029
2030
2031 {- *********************************************************************
2032 * *
2033 Error contexts and messages
2034 * *
2035 ********************************************************************* -}
2036
2037 -- This one is called on LHS, when pat and grhss are both Name
2038 -- and on RHS, when pat is TcId and grhss is still Name
2039 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
2040 patMonoBindsCtxt pat grhss
2041 = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
2042
2043 typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc
2044 typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty })
2045 = pprSigCtxt ctxt empty (ppr hs_ty)
2046 typeSigCtxt ctxt (CompleteSig id)
2047 = pprSigCtxt ctxt empty (ppr (idType id))