8c577d85a774cfc2dc4613af46ad87905fb70299
[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 <- solveEqualities $
216 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 <- newOpenFlexiTyVarTy
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 $
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 reasonable 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 -- See Note [Polymorphic recursion] in HsBinds.
446 do { traceTc "tc_group rec" (pprLHsBinds binds)
447 ; when hasPatSyn $ recursivePatSynErr binds
448 ; (binds1, thing) <- go sccs
449 ; return ([(Recursive, binds1)], thing) }
450 -- Rec them all together
451 where
452 hasPatSyn = anyBag (isPatSyn . unLoc) binds
453 isPatSyn PatSynBind{} = True
454 isPatSyn _ = False
455
456 sccs :: [SCC (LHsBind Name)]
457 sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
458
459 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
460 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
461 ; (binds2, thing) <- tcExtendLetEnv top_lvl ids1 $
462 go sccs
463 ; return (binds1 `unionBags` binds2, thing) }
464 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
465
466 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
467 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
468
469 tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
470
471 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
472 recursivePatSynErr binds
473 = failWithTc $
474 hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
475 2 (vcat $ map pprLBind . bagToList $ binds)
476 where
477 pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
478 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
479 pprLoc loc
480
481 tc_single :: forall thing.
482 TopLevelFlag -> TcSigFun -> TcPragEnv
483 -> LHsBind Name -> TcM thing
484 -> TcM (LHsBinds TcId, thing)
485 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
486 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
487 ; thing <- setGblEnv tcg_env thing_inside
488 ; return (aux_binds, thing)
489 }
490 where
491 tc_pat_syn_decl :: TcM (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 type BKey = Int -- Just number off the bindings
506
507 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
508 -- See Note [Polymorphic recursion] in HsBinds.
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 = mkInvSigmaTy 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, because we'll reconstruct
757 -- it in the call to tcSubType below
758
759 ; (my_tvs, theta') <- chooseInferredQuantifiers
760 inferred_theta (tyCoVarsOfType mono_ty') mb_sig
761
762 ; let qtvs' = filter (`elemVarSet` my_tvs) qtvs -- Maintain original order
763 inferred_poly_ty = mkInvSigmaTy 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 (mkLocalIdOrCoVar 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 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 <- zonkTcTypes annotated_theta
789 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes 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 <- zonkTcTypes annotated_theta
797 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes 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 inferred_diff = [ pred
806 | pred <- my_theta
807 , all (not . (`eqType` pred)) annotated_theta ]
808 final_theta = annotated_theta ++ inferred_diff
809 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
810 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
811 ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
812 ; traceTc "completeTheta" $
813 vcat [ ppr bndr_info
814 , ppr annotated_theta, ppr inferred_theta
815 , ppr inferred_diff ]
816 ; case partial_sigs of
817 True | warn_partial_sigs -> reportWarning msg
818 | otherwise -> return ()
819 False -> reportError msg
820
821 ; return (free_tvs, final_theta) }
822
823 | otherwise = pprPanic "chooseInferredQuantifiers" (ppr bndr_info)
824
825 where
826 pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
827 mk_msg inferred_diff suppress_hint
828 = vcat [ hang ((text "Found constraint wildcard") <+> quotes (char '_'))
829 2 (text "standing for") <+> quotes (pprTheta inferred_diff)
830 , if suppress_hint then empty else pts_hint
831 , typeSigCtxt ctxt bndr_info ]
832
833
834 mk_impedence_match_msg :: MonoBindInfo
835 -> TcType -> TcType
836 -> TidyEnv -> TcM (TidyEnv, SDoc)
837 -- This is a rare but rather awkward error messages
838 mk_impedence_match_msg (name, mb_sig, _) inf_ty sig_ty tidy_env
839 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
840 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
841 ; let msg = vcat [ ptext (sLit "When checking that the inferred type")
842 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
843 , ptext (sLit "is as general as its") <+> what <+> ptext (sLit "signature")
844 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
845 ; return (tidy_env2, msg) }
846 where
847 what = case mb_sig of
848 Nothing -> ptext (sLit "inferred")
849 Just sig | isPartialSig sig -> ptext (sLit "(partial)")
850 | otherwise -> empty
851
852
853 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
854 mk_inf_msg poly_name poly_ty tidy_env
855 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
856 ; let msg = vcat [ ptext (sLit "When checking the inferred type")
857 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
858 ; return (tidy_env1, msg) }
859
860
861 -- | Warn the user about polymorphic local binders that lack type signatures.
862 localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM ()
863 localSigWarn id mb_sig
864 | Just _ <- mb_sig = return ()
865 | not (isSigmaTy (idType id)) = return ()
866 | otherwise = warnMissingSig msg id
867 where
868 msg = ptext (sLit "Polymorphic local binding with no type signature:")
869
870 warnMissingSig :: SDoc -> Id -> TcM ()
871 warnMissingSig msg id
872 = do { env0 <- tcInitTidyEnv
873 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
874 ; addWarnTcM (env1, mk_msg tidy_ty) }
875 where
876 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
877
878 {-
879 Note [Partial type signatures and generalisation]
880 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
881 When we have a partial type signature, like
882 f :: _ -> Int
883 then we *always* use the InferGen plan, and hence tcPolyInfer.
884 We do this even for a local binding with -XMonoLocalBinds.
885 Reasons:
886 * The TcSigInfo for 'f' has a unification variable for the '_',
887 whose TcLevel is one level deeper than the current level.
888 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
889 the TcLevel like InferGen, so we lose the level invariant.
890
891 * The signature might be f :: forall a. _ -> a
892 so it really is polymorphic. It's not clear what it would
893 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
894 in the (Just sig) case, checks that if there is a signature
895 then we are using LetLclBndr, and hence a nested AbsBinds with
896 increased TcLevel
897
898 It might be possible to fix these difficulties somehow, but there
899 doesn't seem much point. Indeed, adding a partial type signature is a
900 way to get per-binding inferred generalisation.
901
902 Note [Validity of inferred types]
903 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
904 We need to check inferred type for validity, in case it uses language
905 extensions that are not turned on. The principle is that if the user
906 simply adds the inferred type to the program source, it'll compile fine.
907 See #8883.
908
909 Examples that might fail:
910 - the type might be ambiguous
911
912 - an inferred theta that requires type equalities e.g. (F a ~ G b)
913 or multi-parameter type classes
914 - an inferred type that includes unboxed tuples
915
916
917 Note [Impedence matching]
918 ~~~~~~~~~~~~~~~~~~~~~~~~~
919 Consider
920 f 0 x = x
921 f n x = g [] (not x)
922
923 g [] y = f 10 y
924 g _ y = f 9 y
925
926 After typechecking we'll get
927 f_mono_ty :: a -> Bool -> Bool
928 g_mono_ty :: [b] -> Bool -> Bool
929 with constraints
930 (Eq a, Num a)
931
932 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
933 The types we really want for f and g are
934 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
935 g :: forall b. [b] -> Bool -> Bool
936
937 We can get these by "impedance matching":
938 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
939 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
940
941 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
942 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
943
944 Suppose the shared quantified tyvars are qtvs and constraints theta.
945 Then we want to check that
946 f's final inferred polytype is more polymorphic than
947 forall qtvs. theta => f_mono_ty
948 and the proof is the impedance matcher.
949
950 Notice that the impedance matcher may do defaulting. See Trac #7173.
951
952 It also cleverly does an ambiguity check; for example, rejecting
953 f :: F a -> a
954 where F is a non-injective type function.
955 -}
956
957 --------------
958 -- If typechecking the binds fails, then return with each
959 -- signature-less binder given type (forall a.a), to minimise
960 -- subsequent error messages
961 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
962 recoveryCode binder_names sig_fn
963 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
964 ; let poly_ids = map mk_dummy binder_names
965 ; return (emptyBag, poly_ids) }
966 where
967 mk_dummy name
968 | Just sig <- sig_fn name
969 , Just poly_id <- completeSigPolyId_maybe sig
970 = poly_id
971 | otherwise
972 = mkLocalId name forall_a_a
973
974 forall_a_a :: TcType
975 forall_a_a = mkInvForAllTys [levity1TyVar, openAlphaTyVar] openAlphaTy
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 noThing 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_tv, _) <- newOpenReturnTyVar
1409 -- use ReturnTv to allow impredicativity
1410 ; let rhs_ty = mkTyVarTy rhs_tv
1411 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1412 ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1413 -- We extend the error context even for a non-recursive
1414 -- function so that in type error messages we show the
1415 -- type of the thing whose rhs we are type checking
1416 tcMatchesFun name matches rhs_ty
1417
1418 ; return (unitBag $ L b_loc $
1419 FunBind { fun_id = L nm_loc mono_id,
1420 fun_matches = matches', bind_fvs = fvs,
1421 fun_co_fn = co_fn, fun_tick = [] },
1422 [(name, Nothing, mono_id)]) }
1423
1424 tcMonoBinds _ sig_fn no_gen binds
1425 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1426
1427 -- Bring the monomorphic Ids, into scope for the RHSs
1428 ; let mono_info = getMonoBindInfo tc_binds
1429 rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
1430 , case mb_sig of
1431 Just sig -> isPartialSig sig
1432 Nothing -> True ]
1433 -- A monomorphic binding for each term variable that lacks
1434 -- a type sig. (Ones with a sig are already in scope.)
1435
1436 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1437 | (n,id) <- rhs_id_env]
1438 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1439 mapM (wrapLocM tcRhs) tc_binds
1440 ; return (listToBag binds', mono_info) }
1441
1442 ------------------------
1443 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1444 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1445 -- if there's a signature for it, use the instantiated signature type
1446 -- otherwise invent a type variable
1447 -- You see that quite directly in the FunBind case.
1448 --
1449 -- But there's a complication for pattern bindings:
1450 -- data T = MkT (forall a. a->a)
1451 -- MkT f = e
1452 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1453 -- but we want to get (f::forall a. a->a) as the RHS environment.
1454 -- The simplest way to do this is to typecheck the pattern, and then look up the
1455 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1456 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1457
1458 data TcMonoBind -- Half completed; LHS done, RHS not done
1459 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1460 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1461
1462 type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId)
1463 -- Type signature (if any), and
1464 -- the monomorphic bound things
1465
1466 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1467 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1468 | Just (TcIdSig sig) <- sig_fn name
1469 , TISI { sig_tau = tau } <- sig
1470 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1471 , ppr name )
1472 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1473 -- or InferGen (partial signature)
1474 -- see Note [Partial type signatures and generalisation]
1475 -- Both InferGen and CheckGen gives rise to LetLclBndr
1476 do { mono_name <- newLocalName name
1477 ; let mono_id = mkLocalIdOrCoVar mono_name tau
1478 ; return (TcFunBind (name, Just sig, mono_id) nm_loc matches) }
1479
1480 | otherwise
1481 = do { mono_ty <- newOpenFlexiTyVarTy
1482 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1483 ; return (TcFunBind (name, Nothing, mono_id) nm_loc matches) }
1484
1485 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1486 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1487 mapM lookup_info (collectPatBinders pat)
1488
1489 -- After typechecking the pattern, look up the binder
1490 -- names, which the pattern has brought into scope.
1491 lookup_info :: Name -> TcM MonoBindInfo
1492 lookup_info name
1493 = do { mono_id <- tcLookupId name
1494 ; let mb_sig = case sig_fn name of
1495 Just (TcIdSig sig) -> Just sig
1496 _ -> Nothing
1497 ; return (name, mb_sig, mono_id) }
1498
1499 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1500 tcInfer tc_pat
1501
1502 ; return (TcPatBind infos pat' grhss pat_ty) }
1503
1504 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1505 -- AbsBind, VarBind impossible
1506
1507 -------------------
1508 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1509 tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc matches)
1510 = tcExtendIdBinderStackForRhs [info] $
1511 tcExtendTyVarEnvForRhs mb_sig $
1512 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1513 ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
1514 matches (idType mono_id)
1515 ; return (FunBind { fun_id = L loc mono_id
1516 , fun_matches = matches'
1517 , fun_co_fn = co_fn
1518 , bind_fvs = placeHolderNamesTc
1519 , fun_tick = [] }) }
1520
1521 -- TODO: emit Hole Constraints for wildcards
1522 tcRhs (TcPatBind infos pat' grhss pat_ty)
1523 = -- When we are doing pattern bindings we *don't* bring any scoped
1524 -- type variables into scope unlike function bindings
1525 -- Wny not? They are not completely rigid.
1526 -- That's why we have the special case for a single FunBind in tcMonoBinds
1527 tcExtendIdBinderStackForRhs infos $
1528 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1529 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1530 tcGRHSsPat grhss pat_ty
1531 ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
1532 , bind_fvs = placeHolderNamesTc
1533 , pat_ticks = ([],[]) }) }
1534
1535 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInfo -> TcM a -> TcM a
1536 tcExtendTyVarEnvForRhs Nothing thing_inside
1537 = thing_inside
1538 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1539 = tcExtendTyVarEnvFromSig sig thing_inside
1540
1541 tcExtendTyVarEnvFromSig :: TcIdSigInfo -> TcM a -> TcM a
1542 tcExtendTyVarEnvFromSig sig thing_inside
1543 | TISI { sig_bndr = s_bndr, sig_skols = skol_prs, sig_ctxt = ctxt } <- sig
1544 = tcExtendTyVarEnv2 skol_prs $
1545 case s_bndr of
1546 CompleteSig {} -> thing_inside
1547 PartialSig { sig_wcs = wc_prs } -- Extend the env ad emit the holes
1548 -> tcExtendTyVarEnv2 wc_prs $
1549 do { addErrCtxt (typeSigCtxt ctxt s_bndr) $
1550 emitWildCardHoleConstraints wc_prs
1551 ; thing_inside }
1552
1553 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1554 -- Extend the TcIdBinderStack for the RHS of the binding, with
1555 -- the monomorphic Id. That way, if we have, say
1556 -- f = \x -> blah
1557 -- and something goes wrong in 'blah', we get a "relevant binding"
1558 -- looking like f :: alpha -> beta
1559 -- This applies if 'f' has a type signature too:
1560 -- f :: forall a. [a] -> [a]
1561 -- f x = True
1562 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1563 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1564 -- would not be reported as relevant, because its type is closed
1565 tcExtendIdBinderStackForRhs infos thing_inside
1566 = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside
1567 -- NotTopLevel: it's a monomorphic binding
1568
1569 ---------------------
1570 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1571 getMonoBindInfo tc_binds
1572 = foldr (get_info . unLoc) [] tc_binds
1573 where
1574 get_info (TcFunBind info _ _) rest = info : rest
1575 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1576
1577 {-
1578 ************************************************************************
1579 * *
1580 Signatures
1581 * *
1582 ************************************************************************
1583
1584 Type signatures are tricky. See Note [Signature skolems] in TcType
1585
1586 @tcSigs@ checks the signatures for validity, and returns a list of
1587 {\em freshly-instantiated} signatures. That is, the types are already
1588 split up, and have fresh type variables installed. All non-type-signature
1589 "RenamedSigs" are ignored.
1590
1591 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1592 the variable's type, and after that checked to see whether they've
1593 been instantiated.
1594
1595 Note [Scoped tyvars]
1596 ~~~~~~~~~~~~~~~~~~~~
1597 The -XScopedTypeVariables flag brings lexically-scoped type variables
1598 into scope for any explicitly forall-quantified type variables:
1599 f :: forall a. a -> a
1600 f x = e
1601 Then 'a' is in scope inside 'e'.
1602
1603 However, we do *not* support this
1604 - For pattern bindings e.g
1605 f :: forall a. a->a
1606 (f,g) = e
1607
1608 Note [Signature skolems]
1609 ~~~~~~~~~~~~~~~~~~~~~~~~
1610 When instantiating a type signature, we do so with either skolems or
1611 SigTv meta-type variables depending on the use_skols boolean. This
1612 variable is set True when we are typechecking a single function
1613 binding; and False for pattern bindings and a group of several
1614 function bindings.
1615
1616 Reason: in the latter cases, the "skolems" can be unified together,
1617 so they aren't properly rigid in the type-refinement sense.
1618 NB: unless we are doing H98, each function with a sig will be done
1619 separately, even if it's mutually recursive, so use_skols will be True
1620
1621
1622 Note [Only scoped tyvars are in the TyVarEnv]
1623 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1624 We are careful to keep only the *lexically scoped* type variables in
1625 the type environment. Why? After all, the renamer has ensured
1626 that only legal occurrences occur, so we could put all type variables
1627 into the type env.
1628
1629 But we want to check that two distinct lexically scoped type variables
1630 do not map to the same internal type variable. So we need to know which
1631 the lexically-scoped ones are... and at the moment we do that by putting
1632 only the lexically scoped ones into the environment.
1633
1634 Note [Instantiate sig with fresh variables]
1635 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1636 It's vital to instantiate a type signature with fresh variables.
1637 For example:
1638 type T = forall a. [a] -> [a]
1639 f :: T;
1640 f = g where { g :: T; g = <rhs> }
1641
1642 We must not use the same 'a' from the defn of T at both places!!
1643 (Instantiation is only necessary because of type synonyms. Otherwise,
1644 it's all cool; each signature has distinct type variables from the renamer.)
1645
1646 Note [Fail eagerly on bad signatures]
1647 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1648 If a type signaure is wrong, fail immediately:
1649
1650 * the type sigs may bind type variables, so proceeding without them
1651 can lead to a cascade of errors
1652
1653 * the type signature might be ambiguous, in which case checking
1654 the code against the signature will give a very similar error
1655 to the ambiguity error.
1656
1657 ToDo: this means we fall over if any type sig
1658 is wrong (eg at the top level of the module),
1659 which is over-conservative
1660 -}
1661
1662 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
1663 tcTySigs hs_sigs
1664 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1665 do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
1666 ; let ty_sigs = concat ty_sigs_s
1667 poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
1668 -- The returned [TcId] are the ones for which we have
1669 -- a complete type signature.
1670 -- See Note [Complete and partial type signatures]
1671 env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
1672 ; return (poly_ids, lookupNameEnv env) }
1673
1674 tcTySig :: LSig Name -> TcM [TcSigInfo]
1675 tcTySig (L _ (IdSig id))
1676 = do { sig <- instTcTySigFromId id
1677 ; return [TcIdSig sig] }
1678
1679 tcTySig (L loc (TypeSig names sig_ty))
1680 = setSrcSpan loc $
1681 do { sigs <- sequence [ tcUserTypeSig sig_ty (Just name)
1682 | L _ name <- names ]
1683 ; return (map TcIdSig sigs) }
1684
1685 tcTySig (L loc (PatSynSig (L _ name) sig_ty))
1686 | HsIB { hsib_vars = sig_vars
1687 , hsib_body = hs_ty } <- sig_ty
1688 , (tv_bndrs, req, prov, body_ty) <- splitLHsPatSynTy hs_ty
1689 = setSrcSpan loc $
1690 do { (tvs1, (req', prov', ty', tvs2))
1691 <- tcImplicitTKBndrs sig_vars $
1692 tcHsTyVarBndrs tv_bndrs $ \ tvs2 ->
1693 do { req' <- tcHsContext req
1694 ; prov' <- tcHsContext prov
1695 ; ty' <- tcHsLiftedType body_ty
1696 ; let bound_tvs
1697 = unionVarSets [ allBoundVariabless req'
1698 , allBoundVariabless prov'
1699 , allBoundVariables ty' ]
1700 ; return ((req', prov', ty', tvs2), bound_tvs) }
1701
1702 -- These are /signatures/ so we zonk to squeeze out any kind
1703 -- unification variables. ToDo: checkValidType?
1704 ; qtvs' <- mapMaybeM zonkQuantifiedTyVar (tvs1 ++ tvs2)
1705 ; req' <- zonkTcTypes req'
1706 ; prov' <- zonkTcTypes prov'
1707 ; ty' <- zonkTcType ty'
1708
1709 ; let (_, pat_ty) = tcSplitFunTys ty'
1710 univ_set = tyCoVarsOfType pat_ty
1711 (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
1712 bad_tvs = varSetElems (tyCoVarsOfTypes req' `minusVarSet` univ_set)
1713
1714 ; unless (null bad_tvs) $ addErr $
1715 hang (ptext (sLit "The 'required' context") <+> quotes (pprTheta req'))
1716 2 (ptext (sLit "mentions existential type variable") <> plural bad_tvs
1717 <+> pprQuotedList bad_tvs)
1718
1719 ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
1720 ; let tpsi = TPSI{ patsig_name = name,
1721 patsig_tau = ty',
1722 patsig_ex = ex_tvs,
1723 patsig_univ = univ_tvs,
1724 patsig_prov = prov',
1725 patsig_req = req' }
1726 ; return [TcPatSynSig tpsi] }
1727
1728 tcTySig _ = return []
1729
1730 isCompleteHsSig :: LHsSigWcType Name -> Bool
1731 -- ^ If there are no wildcards, return a LHsSigType
1732 isCompleteHsSig sig_ty
1733 | HsWC { hswc_wcs = wcs, hswc_ctx = extra } <- hsib_body sig_ty
1734 , null wcs
1735 , Nothing <- extra
1736 = True
1737 | otherwise
1738 = False
1739
1740 tcUserTypeSig :: LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo
1741 -- Just n => Function type signatre name :: type
1742 -- Nothing => Expression type signature <expr> :: type
1743 tcUserTypeSig hs_sig_ty mb_name
1744 | isCompleteHsSig hs_sig_ty
1745 = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1746 -- so that they can be unified under the forall
1747 do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
1748 ; (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1749 ; loc <- getSrcSpanM
1750 ; return $
1751 TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty)
1752 , sig_skols = findScopedTyVars sigma_ty inst_tvs
1753 , sig_theta = theta
1754 , sig_tau = tau
1755 , sig_ctxt = ctxt_T
1756 , sig_loc = loc } }
1757
1758 -- Partial sig with wildcards
1759 | HsIB { hsib_vars = vars, hsib_body = wc_ty } <- hs_sig_ty
1760 , HsWC { hswc_wcs = wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty
1761 , (hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
1762 = do { (vars1, (wcs, tvs2, theta, tau))
1763 <- pushTcLevelM_ $
1764 -- When instantiating the signature, do so "one level in"
1765 -- so that they can be unified under the forall
1766 tcImplicitTKBndrs vars $
1767 tcWildCardBinders wcs $ \ wcs ->
1768 tcHsTyVarBndrs hs_tvs $ \ tvs2 ->
1769 do { -- Instantiate the type-class context; but if there
1770 -- is an extra-constraints wildcard, just discard it here
1771 traceTc "tcPartial" (ppr name $$ ppr vars $$ ppr wcs)
1772 ; theta <- mapM tcLHsPredType $
1773 case extra of
1774 Nothing -> hs_ctxt
1775 Just _ -> dropTail 1 hs_ctxt
1776
1777 ; tau <- tcHsOpenType hs_tau
1778
1779 -- zonking is necessary to establish type representation
1780 -- invariants
1781 ; theta <- zonkTcTypes theta
1782 ; tau <- zonkTcType tau
1783
1784 -- Check for validity (eg rankN etc)
1785 -- The ambiguity check will happen (from checkValidType),
1786 -- but unnecessarily; it will always succeed because there
1787 -- is no quantification
1788 ; checkValidType ctxt_F (mkPhiTy theta tau)
1789 -- NB: Do this in the context of the pushTcLevel so that
1790 -- the TcLevel invariant is respected
1791
1792 ; let bound_tvs
1793 = unionVarSets [ allBoundVariabless theta
1794 , allBoundVariables tau
1795 , mkVarSet (map snd wcs) ]
1796 ; return ((wcs, tvs2, theta, tau), bound_tvs) }
1797
1798 ; loc <- getSrcSpanM
1799 ; return $
1800 TISI { sig_bndr = PartialSig { sig_name = name, sig_hs_ty = hs_ty
1801 , sig_cts = extra, sig_wcs = wcs }
1802 , sig_skols = [ (tyVarName tv, tv) | tv <- vars1 ++ tvs2 ]
1803 , sig_theta = theta
1804 , sig_tau = tau
1805 , sig_ctxt = ctxt_F
1806 , sig_loc = loc } }
1807 where
1808 name = case mb_name of
1809 Just n -> n
1810 Nothing -> mkUnboundName (mkVarOcc "<expression>")
1811 ctxt_F = case mb_name of
1812 Just n -> FunSigCtxt n False
1813 Nothing -> ExprSigCtxt
1814 ctxt_T = case mb_name of
1815 Just n -> FunSigCtxt n True
1816 Nothing -> ExprSigCtxt
1817
1818 instTcTySigFromId :: Id -> TcM TcIdSigInfo
1819 -- Used for instance methods and record selectors
1820 instTcTySigFromId id
1821 = do { let name = idName id
1822 loc = getSrcSpan name
1823 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1824 (idType id)
1825 ; return $ TISI { sig_bndr = CompleteSig id
1826 -- False: do not report redundant constraints
1827 -- The user has no control over the signature!
1828 , sig_skols = [(tyVarName tv, tv) | tv <- tvs]
1829 , sig_theta = theta
1830 , sig_tau = tau
1831 , sig_ctxt = FunSigCtxt name False
1832 , sig_loc = loc } }
1833
1834 instTcTySig :: UserTypeCtxt
1835 -> LHsSigType Name -- Used to get the scoped type variables
1836 -> TcType
1837 -> Name -- Name of the function
1838 -> TcM TcIdSigInfo
1839 instTcTySig ctxt hs_ty sigma_ty name
1840 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1841 ; return (TISI { sig_bndr = CompleteSig (mkLocalIdOrCoVar name sigma_ty)
1842 , sig_skols = findScopedTyVars sigma_ty inst_tvs
1843 , sig_theta = theta
1844 , sig_tau = tau
1845 , sig_ctxt = ctxt
1846 , sig_loc = getLoc (hsSigType hs_ty)
1847 -- SrcSpan from the signature
1848 }) }
1849
1850 -------------------------------
1851 data GeneralisationPlan
1852 = NoGen -- No generalisation, no AbsBinds
1853
1854 | InferGen -- Implicit generalisation; there is an AbsBinds
1855 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1856
1857 | CheckGen (LHsBind Name) TcIdSigInfo
1858 -- One binding with a signature
1859 -- Explicit generalisation; there is an AbsBinds
1860
1861 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1862 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1863
1864 instance Outputable GeneralisationPlan where
1865 ppr NoGen = ptext (sLit "NoGen")
1866 ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b
1867 ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
1868
1869 decideGeneralisationPlan
1870 :: DynFlags -> TcTypeEnv -> [Name]
1871 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1872 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1873 | unlifted_pat_binds = NoGen
1874 | Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig
1875 | mono_local_binds = NoGen
1876 | otherwise = InferGen mono_restriction
1877 where
1878 bndr_set = mkNameSet bndr_names
1879 binds = map unLoc lbinds
1880
1881 sig_plan :: (LHsBind Name, TcIdSigInfo) -> GeneralisationPlan
1882 -- See Note [Partial type signatures and generalisation]
1883 -- We use InferGen False to say "do inference, but do not apply
1884 -- the MR". It's stupid to apply the MR when we are given a
1885 -- signature! C.f Trac #11016, function f2
1886 sig_plan (lbind, sig@(TISI { sig_bndr = s_bndr, sig_theta = theta }))
1887 = case s_bndr of
1888 CompleteSig {} -> CheckGen lbind sig
1889 PartialSig { sig_cts = extra_constraints }
1890 | Nothing <- extra_constraints
1891 , [] <- theta
1892 -> InferGen True -- No signature constraints: apply the MR
1893 | otherwise
1894 -> InferGen False -- Don't apply the MR
1895
1896 unlifted_pat_binds = any isUnliftedHsBind binds
1897 -- Unlifted patterns (unboxed tuple) must not
1898 -- be polymorphic, because we are going to force them
1899 -- See Trac #4498, #8762
1900
1901 mono_restriction = xopt Opt_MonomorphismRestriction dflags
1902 && any restricted binds
1903
1904 is_closed_ns :: NameSet -> Bool -> Bool
1905 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1906 -- ns are the Names referred to from the RHS of this bind
1907
1908 is_closed_id :: Name -> Bool
1909 -- See Note [Bindings with closed types] in TcRnTypes
1910 is_closed_id name
1911 | name `elemNameSet` bndr_set
1912 = True -- Ignore binders in this groups, of course
1913 | Just thing <- lookupNameEnv type_env name
1914 = case thing of
1915 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1916 ATyVar {} -> False -- In-scope type variables
1917 AGlobal {} -> True -- are not closed!
1918 _ -> pprPanic "is_closed_id" (ppr name)
1919 | otherwise
1920 = WARN( isInternalName name, ppr name ) True
1921 -- The free-var set for a top level binding mentions
1922 -- imported things too, so that we can report unused imports
1923 -- These won't be in the local type env.
1924 -- Ditto class method etc from the current module
1925
1926 mono_local_binds = xopt Opt_MonoLocalBinds dflags
1927 && not closed_flag
1928
1929 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1930
1931 no_sig n = noCompleteSig (sig_fn n)
1932
1933 -- With OutsideIn, all nested bindings are monomorphic
1934 -- except a single function binding with a signature
1935 one_funbind_with_sig
1936 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1937 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1938 = Just (lbind, sig)
1939 | otherwise
1940 = Nothing
1941
1942 -- The Haskell 98 monomorphism resetriction
1943 restricted (PatBind {}) = True
1944 restricted (VarBind { var_id = v }) = no_sig v
1945 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1946 && no_sig (unLoc v)
1947 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1948 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1949
1950 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
1951 restricted_match _ = False
1952 -- No args => like a pattern binding
1953 -- Some args => a function binding
1954
1955 -------------------
1956 checkStrictBinds :: TopLevelFlag -> RecFlag
1957 -> [LHsBind Name]
1958 -> LHsBinds TcId -> [Id]
1959 -> TcM ()
1960 -- Check that non-overloaded unlifted bindings are
1961 -- a) non-recursive,
1962 -- b) not top level,
1963 -- c) not a multiple-binding group (more or less implied by (a))
1964
1965 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1966 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1967 = do { check (isNotTopLevel top_lvl)
1968 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1969 ; check (isNonRec rec_group)
1970 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1971
1972 ; check (all is_monomorphic (bagToList tc_binds))
1973 (polyBindErr orig_binds)
1974 -- data Ptr a = Ptr Addr#
1975 -- f x = let p@(Ptr y) = ... in ...
1976 -- Here the binding for 'p' is polymorphic, but does
1977 -- not mix with an unlifted binding for 'y'. You should
1978 -- use a bang pattern. Trac #6078.
1979
1980 ; check (isSingleton orig_binds)
1981 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1982
1983 -- Complain about a binding that looks lazy
1984 -- e.g. let I# y = x in ...
1985 -- Remember, in checkStrictBinds we are going to do strict
1986 -- matching, so (for software engineering reasons) we insist
1987 -- that the strictness is manifest on each binding
1988 -- However, lone (unboxed) variables are ok
1989 ; check (not any_pat_looks_lazy)
1990 (unliftedMustBeBang orig_binds) }
1991 | otherwise
1992 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1993 return ()
1994 where
1995 any_unlifted_bndr = any is_unlifted poly_ids
1996 any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds
1997 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1998
1999 is_unlifted id = case tcSplitSigmaTy (idType id) of
2000 (_, _, rho) -> isUnLiftedType rho
2001 -- For the is_unlifted check, we need to look inside polymorphism
2002 -- and overloading. E.g. x = (# 1, True #)
2003 -- would get type forall a. Num a => (# a, Bool #)
2004 -- and we want to reject that. See Trac #9140
2005
2006 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
2007 = null tvs && null evs
2008 is_monomorphic _ = True
2009
2010 check :: Bool -> MsgDoc -> TcM ()
2011 -- Just like checkTc, but with a special case for module GHC.Prim:
2012 -- see Note [Compiling GHC.Prim]
2013 check True _ = return ()
2014 check False err = do { mod <- getModule
2015 ; checkTc (mod == gHC_PRIM) err }
2016
2017 unliftedMustBeBang :: [LHsBind Name] -> SDoc
2018 unliftedMustBeBang binds
2019 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
2020 2 (vcat (map ppr binds))
2021
2022 polyBindErr :: [LHsBind Name] -> SDoc
2023 polyBindErr binds
2024 = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
2025 2 (vcat [vcat (map ppr binds),
2026 ptext (sLit "Probable fix: add a type signature")])
2027
2028 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
2029 strictBindErr flavour any_unlifted_bndr binds
2030 = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
2031 2 (vcat (map ppr binds))
2032 where
2033 msg | any_unlifted_bndr = ptext (sLit "bindings for unlifted types")
2034 | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
2035
2036
2037 {- Note [Compiling GHC.Prim]
2038 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2039 Module GHC.Prim has no source code: it is the host module for
2040 primitive, built-in functions and types. However, for Haddock-ing
2041 purposes we generate (via utils/genprimopcode) a fake source file
2042 GHC/Prim.hs, and give it to Haddock, so that it can generate
2043 documentation. It contains definitions like
2044 nullAddr# :: NullAddr#
2045 which would normally be rejected as a top-level unlifted binding. But
2046 we don't want to complain, because we are only "compiling" this fake
2047 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
2048 in checkStrictBinds.
2049
2050 (We only make the test if things look wrong, so there is no cost in
2051 the common case.) -}
2052
2053
2054 {- *********************************************************************
2055 * *
2056 Error contexts and messages
2057 * *
2058 ********************************************************************* -}
2059
2060 -- This one is called on LHS, when pat and grhss are both Name
2061 -- and on RHS, when pat is TcId and grhss is still Name
2062 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
2063 patMonoBindsCtxt pat grhss
2064 = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
2065
2066 typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc
2067 typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty })
2068 = pprSigCtxt ctxt empty (ppr hs_ty)
2069 typeSigCtxt ctxt (CompleteSig id)
2070 = pprSigCtxt ctxt empty (ppr (idType id))