Update levity polymorphism
[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 {-# LANGUAGE FlexibleContexts #-}
10
11 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
12 tcHsBootSigs, tcPolyCheck,
13 tcVectDecls, addTypecheckedBinds,
14 chooseInferredQuantifiers,
15 badBootDeclErr ) where
16
17 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
18 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
19 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
20 , tcPatSynBuilderBind )
21 import CoreSyn (Tickish (..))
22 import CostCentre (mkUserCC)
23 import DynFlags
24 import FastString
25 import HsSyn
26 import HscTypes( isHsBootOrSig )
27 import TcSigs
28 import TcRnMonad
29 import TcEnv
30 import TcUnify
31 import TcSimplify
32 import TcEvidence
33 import TcHsType
34 import TcPat
35 import TcMType
36 import FamInstEnv( normaliseType )
37 import FamInst( tcGetFamInstEnvs )
38 import TyCon
39 import TcType
40 import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder )
41 import TysPrim
42 import TysWiredIn( cTupleTyConName )
43 import Id
44 import Var
45 import VarSet
46 import VarEnv( TidyEnv )
47 import Module
48 import Name
49 import NameSet
50 import NameEnv
51 import SrcLoc
52 import Bag
53 import ListSetOps
54 import ErrUtils
55 import Digraph
56 import Maybes
57 import Util
58 import BasicTypes
59 import Outputable
60 import PrelNames( ipClassName )
61 import TcValidity (checkValidType)
62 import Unique (getUnique)
63 import UniqFM
64 import qualified GHC.LanguageExtensions as LangExt
65
66 import Control.Monad
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 :: [(RecFlag, LHsBinds Name)] -> [LSig 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 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 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
196 tcRecSelBinds (ValBindsOut binds sigs)
197 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
198 do { (rec_sel_binds, tcg_env) <- discardWarnings $
199 tcValBinds TopLevel binds sigs getGblEnv
200 ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
201 ; return tcg_env' }
202 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
203
204 tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]
205 -- A hs-boot file has only one BindGroup, and it only has type
206 -- signatures in it. The renamer checked all this
207 tcHsBootSigs binds sigs
208 = do { checkTc (null binds) badBootDeclErr
209 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
210 where
211 tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
212 where
213 f (L _ name)
214 = do { sigma_ty <- solveEqualities $
215 tcHsSigWcType (FunSigCtxt name False) hs_ty
216 ; return (mkVanillaGlobal name sigma_ty) }
217 -- Notice that we make GlobalIds, not LocalIds
218 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
219
220 badBootDeclErr :: MsgDoc
221 badBootDeclErr = text "Illegal declarations in an hs-boot file"
222
223 ------------------------
224 tcLocalBinds :: HsLocalBinds Name -> TcM thing
225 -> TcM (HsLocalBinds TcId, thing)
226
227 tcLocalBinds EmptyLocalBinds thing_inside
228 = do { thing <- thing_inside
229 ; return (EmptyLocalBinds, thing) }
230
231 tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
232 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
233 ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
234 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
235
236 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
237 = do { ipClass <- tcLookupClass ipClassName
238 ; (given_ips, ip_binds') <-
239 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
240
241 -- If the binding binds ?x = E, we must now
242 -- discharge any ?x constraints in expr_lie
243 -- See Note [Implicit parameter untouchables]
244 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
245 [] given_ips thing_inside
246
247 ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
248 where
249 ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
250
251 -- I wonder if we should do these one at at time
252 -- Consider ?x = 4
253 -- ?y = ?x + 1
254 tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
255 = do { ty <- newOpenFlexiTyVarTy
256 ; let p = mkStrLitTy $ hsIPNameFS ip
257 ; ip_id <- newDict ipClass [ p, ty ]
258 ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
259 ; let d = toDict ipClass p ty `fmap` expr'
260 ; return (ip_id, (IPBind (Right ip_id) d)) }
261 tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
262
263 -- Coerces a `t` into a dictionry for `IP "x" t`.
264 -- co : t -> IP "x" t
265 toDict ipClass x ty = HsWrap $ mkWpCastR $
266 wrapIP $ mkClassPred ipClass [x,ty]
267
268 {- Note [Implicit parameter untouchables]
269 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
270 We add the type variables in the types of the implicit parameters
271 as untouchables, not so much because we really must not unify them,
272 but rather because we otherwise end up with constraints like this
273 Num alpha, Implic { wanted = alpha ~ Int }
274 The constraint solver solves alpha~Int by unification, but then
275 doesn't float that solved constraint out (it's not an unsolved
276 wanted). Result disaster: the (Num alpha) is again solved, this
277 time by defaulting. No no no.
278
279 However [Oct 10] this is all handled automatically by the
280 untouchable-range idea.
281 -}
282
283 tcValBinds :: TopLevelFlag
284 -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
285 -> TcM thing
286 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
287
288 tcValBinds top_lvl binds sigs thing_inside
289 = do { let patsyns = getPatSynBinds binds
290
291 -- Typecheck the signature
292 ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
293 tcTySigs sigs
294
295 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
296
297 -- Extend the envt right away with all the Ids
298 -- declared with complete type signatures
299 -- Do not extend the TcIdBinderStack; instead
300 -- we extend it on a per-rhs basis in tcExtendForRhs
301 ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
302 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
303 { thing <- thing_inside
304 -- See Note [Pattern synonym builders don't yield dependencies]
305 -- in RnBinds
306 ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
307 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
308 ; return (extra_binds, thing) }
309 ; return (binds' ++ extra_binds', thing) }}
310
311 ------------------------
312 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
313 -> [(RecFlag, LHsBinds Name)] -> TcM thing
314 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
315 -- Typecheck a whole lot of value bindings,
316 -- one strongly-connected component at a time
317 -- Here a "strongly connected component" has the strightforward
318 -- meaning of a group of bindings that mention each other,
319 -- ignoring type signatures (that part comes later)
320
321 tcBindGroups _ _ _ [] thing_inside
322 = do { thing <- thing_inside
323 ; return ([], thing) }
324
325 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
326 = do { -- See Note [Closed binder groups]
327 closed <- isClosedBndrGroup $ snd group
328 ; (group', (groups', thing))
329 <- tc_group top_lvl sig_fn prag_fn group closed $
330 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
331 ; return (group' ++ groups', thing) }
332
333 -- Note [Closed binder groups]
334 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
335 --
336 -- A mutually recursive group is "closed" if all of the free variables of
337 -- the bindings are closed. For example
338 --
339 -- > h = \x -> let f = ...g...
340 -- > g = ....f...x...
341 -- > in ...
342 --
343 -- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
344 -- closed.
345 --
346 -- So we need to compute closed-ness on each strongly connected components,
347 -- before we sub-divide it based on what type signatures it has.
348 --
349
350 ------------------------
351 tc_group :: forall thing.
352 TopLevelFlag -> TcSigFun -> TcPragEnv
353 -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing
354 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
355
356 -- Typecheck one strongly-connected component of the original program.
357 -- We get a list of groups back, because there may
358 -- be specialisations etc as well
359
360 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
361 -- A single non-recursive binding
362 -- We want to keep non-recursive things non-recursive
363 -- so that we desugar unlifted bindings correctly
364 = do { let bind = case bagToList binds of
365 [bind] -> bind
366 [] -> panic "tc_group: empty list of binds"
367 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
368 ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
369 thing_inside
370 ; return ( [(NonRecursive, bind')], thing) }
371
372 tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
373 = -- To maximise polymorphism, we do a new
374 -- strongly-connected-component analysis, this time omitting
375 -- any references to variables with type signatures.
376 -- (This used to be optional, but isn't now.)
377 -- See Note [Polymorphic recursion] in HsBinds.
378 do { traceTc "tc_group rec" (pprLHsBinds binds)
379 ; when hasPatSyn $ recursivePatSynErr binds
380 ; (binds1, thing) <- go sccs
381 ; return ([(Recursive, binds1)], thing) }
382 -- Rec them all together
383 where
384 hasPatSyn = anyBag (isPatSyn . unLoc) binds
385 isPatSyn PatSynBind{} = True
386 isPatSyn _ = False
387
388 sccs :: [SCC (LHsBind Name)]
389 sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
390
391 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
392 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
393 ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1
394 (go sccs)
395 ; return (binds1 `unionBags` binds2, thing) }
396 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
397
398 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
399 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
400
401 tc_sub_group rec_tc binds =
402 tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
403
404 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
405 recursivePatSynErr binds
406 = failWithTc $
407 hang (text "Recursive pattern synonym definition with following bindings:")
408 2 (vcat $ map pprLBind . bagToList $ binds)
409 where
410 pprLoc loc = parens (text "defined at" <+> ppr loc)
411 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
412 pprLoc loc
413
414 tc_single :: forall thing.
415 TopLevelFlag -> TcSigFun -> TcPragEnv
416 -> LHsBind Name -> IsGroupClosed -> TcM thing
417 -> TcM (LHsBinds TcId, thing)
418 tc_single _top_lvl sig_fn _prag_fn
419 (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
420 _ thing_inside
421 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
422 ; thing <- setGblEnv tcg_env thing_inside
423 ; return (aux_binds, thing)
424 }
425 where
426 tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
427 tc_pat_syn_decl = case sig_fn name of
428 Nothing -> tcInferPatSynDecl psb
429 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
430 Just _ -> panic "tc_single"
431
432 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
433 = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
434 NonRecursive NonRecursive
435 closed
436 [lbind]
437 ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
438 ; return (binds1, thing) }
439
440 ------------------------
441 type BKey = Int -- Just number off the bindings
442
443 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
444 -- See Note [Polymorphic recursion] in HsBinds.
445 mkEdges sig_fn binds
446 = [ (bind, key, [key | n <- nonDetEltsUFM (bind_fvs (unLoc bind)),
447 Just key <- [lookupNameEnv key_map n], no_sig n ])
448 | (bind, key) <- keyd_binds
449 ]
450 -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
451 -- is still deterministic even if the edges are in nondeterministic order
452 -- as explained in Note [Deterministic SCC] in Digraph.
453 where
454 no_sig :: Name -> Bool
455 no_sig n = noCompleteSig (sig_fn n)
456
457 keyd_binds = bagToList binds `zip` [0::BKey ..]
458
459 key_map :: NameEnv BKey -- Which binding it comes from
460 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
461 , bndr <- collectHsBindBinders bind ]
462
463 ------------------------
464 tcPolyBinds :: TcSigFun -> TcPragEnv
465 -> RecFlag -- Whether the group is really recursive
466 -> RecFlag -- Whether it's recursive after breaking
467 -- dependencies based on type signatures
468 -> IsGroupClosed -- Whether the group is closed
469 -> [LHsBind Name] -- None are PatSynBind
470 -> TcM (LHsBinds TcId, [TcId])
471
472 -- Typechecks a single bunch of values bindings all together,
473 -- and generalises them. The bunch may be only part of a recursive
474 -- group, because we use type signatures to maximise polymorphism
475 --
476 -- Returns a list because the input may be a single non-recursive binding,
477 -- in which case the dependency order of the resulting bindings is
478 -- important.
479 --
480 -- Knows nothing about the scope of the bindings
481 -- None of the bindings are pattern synonyms
482
483 tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
484 = setSrcSpan loc $
485 recoverM (recoveryCode binder_names sig_fn) $ do
486 -- Set up main recover; take advantage of any type sigs
487
488 { traceTc "------------------------------------------------" Outputable.empty
489 ; traceTc "Bindings for {" (ppr binder_names)
490 ; dflags <- getDynFlags
491 ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
492 ; traceTc "Generalisation plan" (ppr plan)
493 ; result@(_, poly_ids) <- case plan of
494 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
495 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
496 CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
497
498 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
499 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
500 ])
501
502 ; return result }
503 where
504 binder_names = collectHsBindListBinders bind_list
505 loc = foldr1 combineSrcSpans (map getLoc bind_list)
506 -- The mbinds have been dependency analysed and
507 -- may no longer be adjacent; so find the narrowest
508 -- span that includes them all
509
510 --------------
511 -- If typechecking the binds fails, then return with each
512 -- signature-less binder given type (forall a.a), to minimise
513 -- subsequent error messages
514 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
515 recoveryCode binder_names sig_fn
516 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
517 ; let poly_ids = map mk_dummy binder_names
518 ; return (emptyBag, poly_ids) }
519 where
520 mk_dummy name
521 | Just sig <- sig_fn name
522 , Just poly_id <- completeSigPolyId_maybe sig
523 = poly_id
524 | otherwise
525 = mkLocalId name forall_a_a
526
527 forall_a_a :: TcType
528 forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
529
530 {- *********************************************************************
531 * *
532 tcPolyNoGen
533 * *
534 ********************************************************************* -}
535
536 tcPolyNoGen -- No generalisation whatsoever
537 :: RecFlag -- Whether it's recursive after breaking
538 -- dependencies based on type signatures
539 -> TcPragEnv -> TcSigFun
540 -> [LHsBind Name]
541 -> TcM (LHsBinds TcId, [TcId])
542
543 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
544 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
545 (LetGblBndr prag_fn)
546 bind_list
547 ; mono_ids' <- mapM tc_mono_info mono_infos
548 ; return (binds', mono_ids') }
549 where
550 tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
551 = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
552 ; return mono_id }
553 -- NB: tcPrags generates error messages for
554 -- specialisation pragmas for non-overloaded sigs
555 -- Indeed that is why we call it here!
556 -- So we can safely ignore _specs
557
558
559 {- *********************************************************************
560 * *
561 tcPolyCheck
562 * *
563 ********************************************************************* -}
564
565 tcPolyCheck :: TcPragEnv
566 -> TcIdSigInfo -- Must be a complete signature
567 -> LHsBind Name -- Must be a FunBind
568 -> TcM (LHsBinds TcId, [TcId])
569 -- There is just one binding,
570 -- it is a Funbind
571 -- it has a complete type signature,
572 tcPolyCheck prag_fn
573 (CompleteSig { sig_bndr = poly_id
574 , sig_ctxt = ctxt
575 , sig_loc = sig_loc })
576 (L loc (FunBind { fun_id = L nm_loc name
577 , fun_matches = matches }))
578 = setSrcSpan sig_loc $
579 do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
580 ; (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars sig_loc) poly_id
581 -- See Note [Instantiate sig with fresh variables]
582
583 ; mono_name <- newNameAt (nameOccName name) nm_loc
584 ; ev_vars <- newEvVars theta
585 ; let mono_id = mkLocalId mono_name tau
586 skol_info = SigSkol ctxt (mkPhiTy theta tau)
587 skol_tvs = map snd tv_prs
588
589 ; (ev_binds, (co_fn, matches'))
590 <- checkConstraints skol_info skol_tvs ev_vars $
591 tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
592 tcExtendTyVarEnv2 tv_prs $
593 setSrcSpan loc $
594 tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
595
596 ; let prag_sigs = lookupPragEnv prag_fn name
597 ; spec_prags <- tcSpecPrags poly_id prag_sigs
598 ; poly_id <- addInlinePrags poly_id prag_sigs
599
600 ; mod <- getModule
601 ; let bind' = FunBind { fun_id = L nm_loc mono_id
602 , fun_matches = matches'
603 , fun_co_fn = co_fn
604 , bind_fvs = placeHolderNamesTc
605 , fun_tick = funBindTicks nm_loc mono_id mod prag_sigs }
606
607 abs_bind = L loc $ AbsBindsSig
608 { abs_sig_export = poly_id
609 , abs_tvs = skol_tvs
610 , abs_ev_vars = ev_vars
611 , abs_sig_prags = SpecPrags spec_prags
612 , abs_sig_ev_bind = ev_binds
613 , abs_sig_bind = L loc bind' }
614
615 ; return (unitBag abs_bind, [poly_id]) }
616
617 tcPolyCheck _prag_fn sig bind
618 = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
619
620 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig Name] -> [Tickish TcId]
621 funBindTicks loc fun_id mod sigs
622 | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
623 -- this can only be a singleton list, as duplicate pragmas are rejected
624 -- by the renamer
625 , let cc_str
626 | Just cc_str <- mb_cc_str
627 = sl_fs cc_str
628 | otherwise
629 = getOccFS (Var.varName fun_id)
630 cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
631 cc = mkUserCC cc_name mod loc (getUnique fun_id)
632 = [ProfNote cc True True]
633 | otherwise
634 = []
635
636 {- Note [Instantiate sig with fresh variables]
637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
638 It's vital to instantiate a type signature with fresh variables.
639 For example:
640 type T = forall a. [a] -> [a]
641 f :: T;
642 f = g where { g :: T; g = <rhs> }
643
644 We must not use the same 'a' from the defn of T at both places!!
645 (Instantiation is only necessary because of type synonyms. Otherwise,
646 it's all cool; each signature has distinct type variables from the renamer.)
647 -}
648
649
650 {- *********************************************************************
651 * *
652 tcPolyInfer
653 * *
654 ********************************************************************* -}
655
656 tcPolyInfer
657 :: RecFlag -- Whether it's recursive after breaking
658 -- dependencies based on type signatures
659 -> TcPragEnv -> TcSigFun
660 -> Bool -- True <=> apply the monomorphism restriction
661 -> [LHsBind Name]
662 -> TcM (LHsBinds TcId, [TcId])
663 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
664 = do { (tclvl, wanted, (binds', mono_infos))
665 <- pushLevelAndCaptureConstraints $
666 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
667
668 ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
669 | info <- mono_infos ]
670 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
671 infer_mode = if mono then ApplyMR else NoRestrictions
672
673 ; mapM_ (checkOverloadedSig mono) sigs
674
675 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
676 ; (qtvs, givens, ev_binds)
677 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
678
679 ; let inferred_theta = map evVarPred givens
680 ; exports <- checkNoErrs $
681 mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
682
683 ; loc <- getSrcSpanM
684 ; let poly_ids = map abe_poly exports
685 abs_bind = L loc $
686 AbsBinds { abs_tvs = qtvs
687 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
688 , abs_exports = exports, abs_binds = binds' }
689
690 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
691 ; return (unitBag abs_bind, poly_ids) }
692 -- poly_ids are guaranteed zonked by mkExport
693
694 --------------
695 mkExport :: TcPragEnv
696 -> [TyVar] -> TcThetaType -- Both already zonked
697 -> MonoBindInfo
698 -> TcM (ABExport Id)
699 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
700 --
701 -- mkExport generates exports with
702 -- zonked type variables,
703 -- zonked poly_ids
704 -- The former is just because no further unifications will change
705 -- the quantified type variables, so we can fix their final form
706 -- right now.
707 -- The latter is needed because the poly_ids are used to extend the
708 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
709
710 -- Pre-condition: the qtvs and theta are already zonked
711
712 mkExport prag_fn qtvs theta
713 mono_info@(MBI { mbi_poly_name = poly_name
714 , mbi_sig = mb_sig
715 , mbi_mono_id = mono_id })
716 = do { mono_ty <- zonkTcType (idType mono_id)
717 ; poly_id <- mkInferredPolyId qtvs theta poly_name mb_sig mono_ty
718
719 -- NB: poly_id has a zonked type
720 ; poly_id <- addInlinePrags poly_id prag_sigs
721 ; spec_prags <- tcSpecPrags poly_id prag_sigs
722 -- tcPrags requires a zonked poly_id
723
724 -- See Note [Impedence matching]
725 -- NB: we have already done checkValidType, including an ambiguity check,
726 -- on the type; either when we checked the sig or in mkInferredPolyId
727 ; let poly_ty = idType poly_id
728 sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
729 -- This type is just going into tcSubType,
730 -- so Inferred vs. Specified doesn't matter
731
732 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
733 then return idHsWrapper -- Fast path; also avoids complaint when we infer
734 -- an ambiguouse type and have AllowAmbiguousType
735 -- e..g infer x :: forall a. F a -> Int
736 else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
737 tcSubType_NC sig_ctxt sel_poly_ty poly_ty
738
739 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
740 ; when warn_missing_sigs $
741 localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
742
743 ; return (ABE { abe_wrap = wrap
744 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
745 , abe_poly = poly_id
746 , abe_mono = mono_id
747 , abe_prags = SpecPrags spec_prags}) }
748 where
749 prag_sigs = lookupPragEnv prag_fn poly_name
750 sig_ctxt = InfSigCtxt poly_name
751
752 mkInferredPolyId :: [TyVar] -> TcThetaType
753 -> Name -> Maybe TcIdSigInst -> TcType
754 -> TcM TcId
755 mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty
756 | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
757 , CompleteSig { sig_bndr = poly_id } <- sig
758 = return poly_id
759
760 | otherwise -- Either no type sig or partial type sig
761 = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous
762 -- we don't carry on to the impedence matching, and generate
763 -- a duplicate ambiguity error. There is a similar
764 -- checkNoErrs for complete type signatures too.
765 do { fam_envs <- tcGetFamInstEnvs
766 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
767 -- Unification may not have normalised the type,
768 -- (see Note [Lazy flattening] in TcFlatten) so do it
769 -- here to make it as uncomplicated as possible.
770 -- Example: f :: [F Int] -> Bool
771 -- should be rewritten to f :: [Char] -> Bool, if possible
772 --
773 -- We can discard the coercion _co, because we'll reconstruct
774 -- it in the call to tcSubType below
775
776 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
777 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
778
779 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
780
781 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
782 , ppr inferred_poly_ty])
783 ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
784 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
785 -- See Note [Validity of inferred types]
786
787 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
788
789
790 chooseInferredQuantifiers :: TcThetaType -- inferred
791 -> TcTyVarSet -- tvs free in tau type
792 -> [TcTyVar] -- inferred quantified tvs
793 -> Maybe TcIdSigInst
794 -> TcM ([TyVarBinder], TcThetaType)
795 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
796 = -- No type signature (partial or complete) for this binder,
797 do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
798 -- Include kind variables! Trac #7916
799 my_theta = pickCapturedPreds free_tvs inferred_theta
800 binders = [ mkTyVarBinder Inferred tv
801 | tv <- qtvs
802 , tv `elemVarSet` free_tvs ]
803 ; return (binders, my_theta) }
804
805 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
806 (Just (TISI { sig_inst_sig = sig -- Always PartialSig
807 , sig_inst_wcx = wcx
808 , sig_inst_theta = annotated_theta
809 , sig_inst_skols = annotated_tvs }))
810 | Nothing <- wcx
811 = do { annotated_theta <- zonkTcTypes annotated_theta
812 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
813 `unionVarSet` tau_tvs)
814 ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs])
815 ; return (mk_binders free_tvs, annotated_theta) }
816
817 | Just wc_var <- wcx
818 = do { annotated_theta <- zonkTcTypes annotated_theta
819 ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
820 -- growThetaVars just like the no-type-sig case
821 -- Omitting this caused #12844
822 seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there
823 `unionVarSet` tau_tvs -- by the user
824 my_theta = pickCapturedPreds free_tvs inferred_theta
825
826 -- Report the inferred constraints for an extra-constraints wildcard/hole as
827 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
828 -- case, the extra inferred constraints are accepted without complaining.
829 -- NB: inferred_theta already includes all the annotated constraints
830 inferred_diff = [ pred
831 | pred <- my_theta
832 , all (not . (`eqType` pred)) annotated_theta ]
833 ; ctuple <- mk_ctuple inferred_diff
834 ; writeMetaTyVar wc_var ctuple
835 ; traceTc "completeTheta" $
836 vcat [ ppr sig
837 , ppr annotated_theta, ppr inferred_theta
838 , ppr inferred_diff ]
839
840 ; return (mk_binders free_tvs, my_theta) }
841
842 | otherwise -- A complete type signature is dealt with in mkInferredPolyId
843 = pprPanic "chooseInferredQuantifiers" (ppr sig)
844
845 where
846 spec_tv_set = mkVarSet $ map snd annotated_tvs
847 mk_binders free_tvs
848 = [ mkTyVarBinder vis tv
849 | tv <- qtvs
850 , tv `elemVarSet` free_tvs
851 , let vis | tv `elemVarSet` spec_tv_set = Specified
852 | otherwise = Inferred ]
853 -- Pulling from qtvs maintains original order
854
855 mk_ctuple [pred] = return pred
856 mk_ctuple preds = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))
857 ; return (mkTyConApp tc preds) }
858
859 mk_impedence_match_msg :: MonoBindInfo
860 -> TcType -> TcType
861 -> TidyEnv -> TcM (TidyEnv, SDoc)
862 -- This is a rare but rather awkward error messages
863 mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
864 inf_ty sig_ty tidy_env
865 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
866 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
867 ; let msg = vcat [ text "When checking that the inferred type"
868 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
869 , text "is as general as its" <+> what <+> text "signature"
870 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
871 ; return (tidy_env2, msg) }
872 where
873 what = case mb_sig of
874 Nothing -> text "inferred"
875 Just sig | isPartialSig sig -> text "(partial)"
876 | otherwise -> empty
877
878
879 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
880 mk_inf_msg poly_name poly_ty tidy_env
881 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
882 ; let msg = vcat [ text "When checking the inferred type"
883 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
884 ; return (tidy_env1, msg) }
885
886
887 -- | Warn the user about polymorphic local binders that lack type signatures.
888 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
889 localSigWarn flag id mb_sig
890 | Just _ <- mb_sig = return ()
891 | not (isSigmaTy (idType id)) = return ()
892 | otherwise = warnMissingSignatures flag msg id
893 where
894 msg = text "Polymorphic local binding with no type signature:"
895
896 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
897 warnMissingSignatures flag msg id
898 = do { env0 <- tcInitTidyEnv
899 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
900 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
901 where
902 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
903
904 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
905 -- Example:
906 -- f :: Eq a => a -> a
907 -- K f = e
908 -- The MR applies, but the signature is overloaded, and it's
909 -- best to complain about this directly
910 -- c.f Trac #11339
911 checkOverloadedSig monomorphism_restriction_applies sig
912 | not (null (sig_inst_theta sig))
913 , monomorphism_restriction_applies
914 , let orig_sig = sig_inst_sig sig
915 = setSrcSpan (sig_loc orig_sig) $
916 failWith $
917 hang (text "Overloaded signature conflicts with monomorphism restriction")
918 2 (ppr orig_sig)
919 | otherwise
920 = return ()
921
922 {- Note [Partial type signatures and generalisation]
923 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
924 If /any/ of the signatures in the gropu is a partial type signature
925 f :: _ -> Int
926 then we *always* use the InferGen plan, and hence tcPolyInfer.
927 We do this even for a local binding with -XMonoLocalBinds, when
928 we normally use NoGen.
929
930 Reasons:
931 * The TcSigInfo for 'f' has a unification variable for the '_',
932 whose TcLevel is one level deeper than the current level.
933 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
934 the TcLevel like InferGen, so we lose the level invariant.
935
936 * The signature might be f :: forall a. _ -> a
937 so it really is polymorphic. It's not clear what it would
938 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
939 in the (Just sig) case, checks that if there is a signature
940 then we are using LetLclBndr, and hence a nested AbsBinds with
941 increased TcLevel
942
943 It might be possible to fix these difficulties somehow, but there
944 doesn't seem much point. Indeed, adding a partial type signature is a
945 way to get per-binding inferred generalisation.
946
947 We apply the MR if /all/ of the partial signatures lack a context.
948 In particular (Trac #11016):
949 f2 :: (?loc :: Int) => _
950 f2 = ?loc
951 It's stupid to apply the MR here. This test includes an extra-constraints
952 wildcard; that is, we don't apply the MR if you write
953 f3 :: _ => blah
954
955 Note [Validity of inferred types]
956 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
957 We need to check inferred type for validity, in case it uses language
958 extensions that are not turned on. The principle is that if the user
959 simply adds the inferred type to the program source, it'll compile fine.
960 See #8883.
961
962 Examples that might fail:
963 - the type might be ambiguous
964
965 - an inferred theta that requires type equalities e.g. (F a ~ G b)
966 or multi-parameter type classes
967 - an inferred type that includes unboxed tuples
968
969
970 Note [Impedence matching]
971 ~~~~~~~~~~~~~~~~~~~~~~~~~
972 Consider
973 f 0 x = x
974 f n x = g [] (not x)
975
976 g [] y = f 10 y
977 g _ y = f 9 y
978
979 After typechecking we'll get
980 f_mono_ty :: a -> Bool -> Bool
981 g_mono_ty :: [b] -> Bool -> Bool
982 with constraints
983 (Eq a, Num a)
984
985 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
986 The types we really want for f and g are
987 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
988 g :: forall b. [b] -> Bool -> Bool
989
990 We can get these by "impedance matching":
991 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
992 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
993
994 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
995 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
996
997 Suppose the shared quantified tyvars are qtvs and constraints theta.
998 Then we want to check that
999 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1000 and the proof is the impedance matcher.
1001
1002 Notice that the impedance matcher may do defaulting. See Trac #7173.
1003
1004 It also cleverly does an ambiguity check; for example, rejecting
1005 f :: F a -> F a
1006 where F is a non-injective type function.
1007 -}
1008
1009 {- *********************************************************************
1010 * *
1011 Vectorisation
1012 * *
1013 ********************************************************************* -}
1014
1015 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1016 tcVectDecls decls
1017 = do { decls' <- mapM (wrapLocM tcVect) decls
1018 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1019 dups = findDupsEq (==) ids
1020 ; mapM_ reportVectDups dups
1021 ; traceTcConstraints "End of tcVectDecls"
1022 ; return decls'
1023 }
1024 where
1025 reportVectDups (first:_second:_more)
1026 = addErrAt (getSrcSpan first) $
1027 text "Duplicate vectorisation declarations for" <+> ppr first
1028 reportVectDups _ = return ()
1029
1030 --------------
1031 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1032 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1033 -- type of the original definition as this requires internals of the vectoriser not available
1034 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1035 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1036 -- from the vectoriser here.
1037 tcVect (HsVect s name rhs)
1038 = addErrCtxt (vectCtxt name) $
1039 do { var <- wrapLocM tcLookupId name
1040 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1041 ; rhs_id <- tcLookupId rhs_var_name
1042 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1043 }
1044
1045 tcVect (HsNoVect s name)
1046 = addErrCtxt (vectCtxt name) $
1047 do { var <- wrapLocM tcLookupId name
1048 ; return $ HsNoVect s var
1049 }
1050 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1051 = addErrCtxt (vectCtxt lname) $
1052 do { tycon <- tcLookupLocatedTyCon lname
1053 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1054 || isJust rhs_name -- or we explicitly provide a vectorised type
1055 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1056 )
1057 scalarTyConMustBeNullary
1058
1059 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1060 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1061 }
1062 tcVect (HsVectTypeOut _ _ _)
1063 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1064 tcVect (HsVectClassIn _ lname)
1065 = addErrCtxt (vectCtxt lname) $
1066 do { cls <- tcLookupLocatedClass lname
1067 ; return $ HsVectClassOut cls
1068 }
1069 tcVect (HsVectClassOut _)
1070 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1071 tcVect (HsVectInstIn linstTy)
1072 = addErrCtxt (vectCtxt linstTy) $
1073 do { (cls, tys) <- tcHsVectInst linstTy
1074 ; inst <- tcLookupInstance cls tys
1075 ; return $ HsVectInstOut inst
1076 }
1077 tcVect (HsVectInstOut _)
1078 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1079
1080 vectCtxt :: Outputable thing => thing -> SDoc
1081 vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
1082
1083 scalarTyConMustBeNullary :: MsgDoc
1084 scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
1085
1086 {-
1087 Note [SPECIALISE pragmas]
1088 ~~~~~~~~~~~~~~~~~~~~~~~~~
1089 There is no point in a SPECIALISE pragma for a non-overloaded function:
1090 reverse :: [a] -> [a]
1091 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1092
1093 But SPECIALISE INLINE *can* make sense for GADTS:
1094 data Arr e where
1095 ArrInt :: !Int -> ByteArray# -> Arr Int
1096 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1097
1098 (!:) :: Arr e -> Int -> e
1099 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1100 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1101 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1102 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1103
1104 When (!:) is specialised it becomes non-recursive, and can usefully
1105 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1106 for a non-overloaded function.
1107
1108 ************************************************************************
1109 * *
1110 tcMonoBinds
1111 * *
1112 ************************************************************************
1113
1114 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1115 The signatures have been dealt with already.
1116 -}
1117
1118 data MonoBindInfo = MBI { mbi_poly_name :: Name
1119 , mbi_sig :: Maybe TcIdSigInst
1120 , mbi_mono_id :: TcId }
1121
1122 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1123 -- i.e. the binders are mentioned in their RHSs, and
1124 -- we are not rescued by a type signature
1125 -> TcSigFun -> LetBndrSpec
1126 -> [LHsBind Name]
1127 -> TcM (LHsBinds TcId, [MonoBindInfo])
1128 tcMonoBinds is_rec sig_fn no_gen
1129 [ L b_loc (FunBind { fun_id = L nm_loc name,
1130 fun_matches = matches, bind_fvs = fvs })]
1131 -- Single function binding,
1132 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1133 , Nothing <- sig_fn name -- ...with no type signature
1134 = -- Note [Single function non-recursive binding special-case]
1135 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1136 -- In this very special case we infer the type of the
1137 -- right hand side first (it may have a higher-rank type)
1138 -- and *then* make the monomorphic Id for the LHS
1139 -- e.g. f = \(x::forall a. a->a) -> <body>
1140 -- We want to infer a higher-rank type for f
1141 setSrcSpan b_loc $
1142 do { ((co_fn, matches'), rhs_ty)
1143 <- tcInferInst $ \ exp_ty ->
1144 -- tcInferInst: see TcUnify,
1145 -- Note [Deep instantiation of InferResult]
1146 tcExtendIdBndrs [TcIdBndr_ExpType name exp_ty NotTopLevel] $
1147 -- We extend the error context even for a non-recursive
1148 -- function so that in type error messages we show the
1149 -- type of the thing whose rhs we are type checking
1150 tcMatchesFun (L nm_loc name) matches exp_ty
1151
1152 ; mono_id <- newLetBndr no_gen name rhs_ty
1153 ; return (unitBag $ L b_loc $
1154 FunBind { fun_id = L nm_loc mono_id,
1155 fun_matches = matches', bind_fvs = fvs,
1156 fun_co_fn = co_fn, fun_tick = [] },
1157 [MBI { mbi_poly_name = name
1158 , mbi_sig = Nothing
1159 , mbi_mono_id = mono_id }]) }
1160
1161 tcMonoBinds _ sig_fn no_gen binds
1162 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1163
1164 -- Bring the monomorphic Ids, into scope for the RHSs
1165 ; let mono_infos = getMonoBindInfo tc_binds
1166 rhs_id_env = [ (name, mono_id)
1167 | MBI { mbi_poly_name = name
1168 , mbi_sig = mb_sig
1169 , mbi_mono_id = mono_id } <- mono_infos
1170 , case mb_sig of
1171 Just sig -> isPartialSig sig
1172 Nothing -> True ]
1173 -- A monomorphic binding for each term variable that lacks
1174 -- a complete type sig. (Ones with a sig are already in scope.)
1175
1176 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1177 | (n,id) <- rhs_id_env]
1178 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1179 mapM (wrapLocM tcRhs) tc_binds
1180
1181 ; return (listToBag binds', mono_infos) }
1182
1183
1184 ------------------------
1185 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1186 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1187 -- if there's a signature for it, use the instantiated signature type
1188 -- otherwise invent a type variable
1189 -- You see that quite directly in the FunBind case.
1190 --
1191 -- But there's a complication for pattern bindings:
1192 -- data T = MkT (forall a. a->a)
1193 -- MkT f = e
1194 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1195 -- but we want to get (f::forall a. a->a) as the RHS environment.
1196 -- The simplest way to do this is to typecheck the pattern, and then look up the
1197 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1198 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1199
1200 data TcMonoBind -- Half completed; LHS done, RHS not done
1201 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1202 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1203
1204 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1205 -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
1206 -- or NoGen (LetBndrSpec = LetGblBndr)
1207 -- CheckGen is used only for functions with a complete type signature,
1208 -- and tcPolyCheck doesn't use tcMonoBinds at all
1209
1210 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1211 | Just (TcIdSig sig) <- sig_fn name
1212 = -- There is a type signature.
1213 -- It must be partial; if complete we'd be in tcPolyCheck!
1214 -- e.g. f :: _ -> _
1215 -- f x = ...g...
1216 -- Just g = ...f...
1217 -- Hence always typechecked with InferGen
1218 do { mono_info <- tcLhsSigId no_gen (name, sig)
1219 ; return (TcFunBind mono_info nm_loc matches) }
1220
1221 | otherwise -- No type signature
1222 = do { mono_ty <- newOpenFlexiTyVarTy
1223 ; mono_id <- newLetBndr no_gen name mono_ty
1224 ; let mono_info = MBI { mbi_poly_name = name
1225 , mbi_sig = Nothing
1226 , mbi_mono_id = mono_id }
1227 ; return (TcFunBind mono_info nm_loc matches) }
1228
1229 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1230 = -- See Note [Typechecking pattern bindings]
1231 do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
1232
1233 ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
1234 [ (mbi_poly_name mbi, mbi_mono_id mbi)
1235 | mbi <- sig_mbis ]
1236
1237 -- See Note [Existentials in pattern bindings]
1238 ; ((pat', nosig_mbis), pat_ty)
1239 <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1240 tcInferNoInst $ \ exp_ty ->
1241 tcLetPat inst_sig_fun no_gen pat exp_ty $
1242 mapM lookup_info nosig_names
1243
1244 ; let mbis = sig_mbis ++ nosig_mbis
1245
1246 ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
1247 | mbi <- mbis, let id = mbi_mono_id mbi ]
1248 $$ ppr no_gen)
1249
1250 ; return (TcPatBind mbis pat' grhss pat_ty) }
1251 where
1252 bndr_names = collectPatBinders pat
1253 (nosig_names, sig_names) = partitionWith find_sig bndr_names
1254
1255 find_sig :: Name -> Either Name (Name, TcIdSigInfo)
1256 find_sig name = case sig_fn name of
1257 Just (TcIdSig sig) -> Right (name, sig)
1258 _ -> Left name
1259
1260 -- After typechecking the pattern, look up the binder
1261 -- names that lack a signature, which the pattern has brought
1262 -- into scope.
1263 lookup_info :: Name -> TcM MonoBindInfo
1264 lookup_info name
1265 = do { mono_id <- tcLookupId name
1266 ; return (MBI { mbi_poly_name = name
1267 , mbi_sig = Nothing
1268 , mbi_mono_id = mono_id }) }
1269
1270 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1271 -- AbsBind, VarBind impossible
1272
1273 -------------------
1274 tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
1275 tcLhsSigId no_gen (name, sig)
1276 = do { inst_sig <- tcInstSig sig
1277 ; mono_id <- newSigLetBndr no_gen name inst_sig
1278 ; return (MBI { mbi_poly_name = name
1279 , mbi_sig = Just inst_sig
1280 , mbi_mono_id = mono_id }) }
1281
1282 ------------
1283 newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
1284 newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
1285 | CompleteSig { sig_bndr = poly_id } <- id_sig
1286 = addInlinePrags poly_id (lookupPragEnv prags name)
1287 newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
1288 = newLetBndr no_gen name tau
1289
1290 -------------------
1291 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1292 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1293 loc matches)
1294 = tcExtendIdBinderStackForRhs [info] $
1295 tcExtendTyVarEnvForRhs mb_sig $
1296 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1297 ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
1298 matches (mkCheckExpType $ idType mono_id)
1299 ; return ( FunBind { fun_id = L loc mono_id
1300 , fun_matches = matches'
1301 , fun_co_fn = co_fn
1302 , bind_fvs = placeHolderNamesTc
1303 , fun_tick = [] } ) }
1304
1305 tcRhs (TcPatBind infos pat' grhss pat_ty)
1306 = -- When we are doing pattern bindings we *don't* bring any scoped
1307 -- type variables into scope unlike function bindings
1308 -- Wny not? They are not completely rigid.
1309 -- That's why we have the special case for a single FunBind in tcMonoBinds
1310 tcExtendIdBinderStackForRhs infos $
1311 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1312 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1313 tcGRHSsPat grhss pat_ty
1314 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1315 , pat_rhs_ty = pat_ty
1316 , bind_fvs = placeHolderNamesTc
1317 , pat_ticks = ([],[]) } )}
1318
1319 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
1320 tcExtendTyVarEnvForRhs Nothing thing_inside
1321 = thing_inside
1322 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1323 = tcExtendTyVarEnvFromSig sig thing_inside
1324
1325 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
1326 tcExtendTyVarEnvFromSig sig_inst thing_inside
1327 | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
1328 = tcExtendTyVarEnv2 wcs $
1329 tcExtendTyVarEnv2 skol_prs $
1330 thing_inside
1331
1332 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1333 -- Extend the TcIdBinderStack for the RHS of the binding, with
1334 -- the monomorphic Id. That way, if we have, say
1335 -- f = \x -> blah
1336 -- and something goes wrong in 'blah', we get a "relevant binding"
1337 -- looking like f :: alpha -> beta
1338 -- This applies if 'f' has a type signature too:
1339 -- f :: forall a. [a] -> [a]
1340 -- f x = True
1341 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1342 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1343 -- would not be reported as relevant, because its type is closed
1344 tcExtendIdBinderStackForRhs infos thing_inside
1345 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
1346 | MBI { mbi_mono_id = mono_id } <- infos ]
1347 thing_inside
1348 -- NotTopLevel: it's a monomorphic binding
1349
1350 ---------------------
1351 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1352 getMonoBindInfo tc_binds
1353 = foldr (get_info . unLoc) [] tc_binds
1354 where
1355 get_info (TcFunBind info _ _) rest = info : rest
1356 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1357
1358
1359 {- Note [Typechecking pattern bindings]
1360 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1361 Look at:
1362 - typecheck/should_compile/ExPat
1363 - Trac #12427, typecheck/should_compile/T12427{a,b}
1364
1365 data T where
1366 MkT :: Integral a => a -> Int -> T
1367
1368 and suppose t :: T. Which of these pattern bindings are ok?
1369
1370 E1. let { MkT p _ = t } in <body>
1371
1372 E2. let { MkT _ q = t } in <body>
1373
1374 E3. let { MkT (toInteger -> r) _ = t } in <body>
1375
1376 * (E1) is clearly wrong because the existential 'a' escapes.
1377 What type could 'p' possibly have?
1378
1379 * (E2) is fine, despite the existential pattern, because
1380 q::Int, and nothing escapes.
1381
1382 * Even (E3) is fine. The existential pattern binds a dictionary
1383 for (Integral a) which the view pattern can use to convert the
1384 a-valued field to an Integer, so r :: Integer.
1385
1386 An easy way to see all three is to imagine the desugaring.
1387 For (E2) it would look like
1388 let q = case t of MkT _ q' -> q'
1389 in <body>
1390
1391
1392 We typecheck pattern bindings as follows. First tcLhs does this:
1393
1394 1. Take each type signature q :: ty, partial or complete, and
1395 instantiate it (with tcLhsSigId) to get a MonoBindInfo. This
1396 gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
1397 a fresh name.
1398
1399 Any fresh unification variables in instantiate(ty) born here, not
1400 deep under implications as would happen if we allocated them when
1401 we encountered q during tcPat.
1402
1403 2. Build a little environment mapping "q" -> "qm" for those Ids
1404 with signatures (inst_sig_fun)
1405
1406 3. Invoke tcLetPat to typecheck the pattern.
1407
1408 - We pass in the current TcLevel. This is captured by
1409 TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
1410 PatEnv.
1411
1412 - When tcPat finds an existential constructor, it binds fresh
1413 type variables and dictionaries as usual, increments the TcLevel,
1414 and emits an implication constraint.
1415
1416 - When we come to a binder (TcPat.tcPatBndr), it looks it up
1417 in the little environment (the pc_sig_fn field of PatCtxt).
1418
1419 Success => There was a type signature, so just use it,
1420 checking compatibility with the expected type.
1421
1422 Failure => No type sigature.
1423 Infer case: (happens only outside any constructor pattern)
1424 use a unification variable
1425 at the outer level pc_lvl
1426
1427 Check case: use promoteTcType to promote the type
1428 to the outer level pc_lvl. This is the
1429 place where we emit a constraint that'll blow
1430 up if existential capture takes place
1431
1432 Result: the type of the binder is always at pc_lvl. This is
1433 crucial.
1434
1435 4. Throughout, when we are making up an Id for the pattern-bound variables
1436 (newLetBndr), we have two cases:
1437
1438 - If we are generalising (generalisation plan is InferGen or
1439 CheckGen), then the let_bndr_spec will be LetLclBndr. In that case
1440 we want to bind a cloned, local version of the variable, with the
1441 type given by the pattern context, *not* by the signature (even if
1442 there is one; see Trac #7268). The mkExport part of the
1443 generalisation step will do the checking and impedance matching
1444 against the signature.
1445
1446 - If for some some reason we are not generalising (plan = NoGen), the
1447 LetBndrSpec will be LetGblBndr. In that case we must bind the
1448 global version of the Id, and do so with precisely the type given
1449 in the signature. (Then we unify with the type from the pattern
1450 context type.)
1451
1452
1453 And that's it! The implication constraints check for the skolem
1454 escape. It's quite simple and neat, and more expressive than before
1455 e.g. GHC 8.0 rejects (E2) and (E3).
1456
1457 Example for (E1), starting at level 1. We generate
1458 p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
1459 The (a~beta) can't float (because of the 'a'), nor be solved (because
1460 beta is untouchable.)
1461
1462 Example for (E2), we generate
1463 q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
1464 The beta is untoucable, but floats out of the constraint and can
1465 be solved absolutely fine.
1466
1467 ************************************************************************
1468 * *
1469 Generalisation
1470 * *
1471 ********************************************************************* -}
1472
1473 data GeneralisationPlan
1474 = NoGen -- No generalisation, no AbsBinds
1475
1476 | InferGen -- Implicit generalisation; there is an AbsBinds
1477 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1478
1479 | CheckGen (LHsBind Name) TcIdSigInfo
1480 -- One FunBind with a signature
1481 -- Explicit generalisation; there is an AbsBindsSig
1482
1483 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1484 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1485
1486 instance Outputable GeneralisationPlan where
1487 ppr NoGen = text "NoGen"
1488 ppr (InferGen b) = text "InferGen" <+> ppr b
1489 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1490
1491 decideGeneralisationPlan
1492 :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun
1493 -> GeneralisationPlan
1494 decideGeneralisationPlan dflags lbinds closed sig_fn
1495 | has_partial_sigs = InferGen (and partial_sig_mrs)
1496 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1497 | mono_local_binds closed = NoGen
1498 | otherwise = InferGen mono_restriction
1499 where
1500 binds = map unLoc lbinds
1501
1502 partial_sig_mrs :: [Bool]
1503 -- One for each parital signature (so empty => no partial sigs)
1504 -- The Bool is True if the signature has no constraint context
1505 -- so we should apply the MR
1506 -- See Note [Partial type signatures and generalisation]
1507 partial_sig_mrs
1508 = [ null theta
1509 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1510 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1511 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1512
1513 has_partial_sigs = not (null partial_sig_mrs)
1514
1515 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1516 && any restricted binds
1517
1518 mono_local_binds ClosedGroup = False
1519 mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags
1520
1521 -- With OutsideIn, all nested bindings are monomorphic
1522 -- except a single function binding with a signature
1523 one_funbind_with_sig
1524 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1525 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1526 = Just (lbind, sig)
1527 | otherwise
1528 = Nothing
1529
1530 -- The Haskell 98 monomorphism restriction
1531 restricted (PatBind {}) = True
1532 restricted (VarBind { var_id = v }) = no_sig v
1533 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1534 && no_sig (unLoc v)
1535 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1536 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1537 restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
1538
1539 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
1540 restricted_match _ = False
1541 -- No args => like a pattern binding
1542 -- Some args => a function binding
1543
1544 no_sig n = noCompleteSig (sig_fn n)
1545
1546 isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed
1547 isClosedBndrGroup binds = do
1548 type_env <- getLclTypeEnv
1549 if foldUFM (is_closed_ns type_env) True fv_env
1550 then return ClosedGroup
1551 else return $ NonClosedGroup fv_env
1552 where
1553 fv_env :: NameEnv NameSet
1554 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1555
1556 bindFvs :: HsBindLR Name idR -> [(Name, NameSet)]
1557 bindFvs (FunBind { fun_id = f, bind_fvs = fvs })
1558 = [(unLoc f, fvs)]
1559 bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
1560 = [(b, fvs) | b <- collectPatBinders pat]
1561 bindFvs _
1562 = []
1563
1564 is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
1565 is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
1566 -- ns are the Names referred to from the RHS of this bind
1567
1568 is_closed_id :: TcTypeEnv -> Name -> Bool
1569 -- See Note [Bindings with closed types] in TcRnTypes
1570 is_closed_id type_env name
1571 | Just thing <- lookupNameEnv type_env name
1572 = case thing of
1573 ATcId { tct_info = ClosedLet } -> True -- This is the key line
1574 ATcId {} -> False
1575 ATyVar {} -> False -- In-scope type variables
1576 AGlobal {} -> True -- are not closed!
1577 _ -> pprPanic "is_closed_id" (ppr name)
1578 | otherwise
1579 = True
1580 -- The free-var set for a top level binding mentions
1581 -- imported things too, so that we can report unused imports
1582 -- These won't be in the local type env.
1583 -- Ditto class method etc from the current module
1584
1585 {- *********************************************************************
1586 * *
1587 Error contexts and messages
1588 * *
1589 ********************************************************************* -}
1590
1591 -- This one is called on LHS, when pat and grhss are both Name
1592 -- and on RHS, when pat is TcId and grhss is still Name
1593 patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
1594 => LPat id -> GRHSs Name body -> SDoc
1595 patMonoBindsCtxt pat grhss
1596 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)