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