Pattern synonym names need to be in scope before renaming bindings (#9889)
[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 tcHsBootSigs, tcPolyCheck,
12 PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
13 TcSigInfo(..), TcSigFun,
14 instTcTySig, instTcTySigFromId, findScopedTyVars,
15 badBootDeclErr, mkExport ) where
16
17 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
18 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
19 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
20 import DynFlags
21 import HsSyn
22 import HscTypes( isHsBootOrSig )
23 import TcRnMonad
24 import TcEnv
25 import TcUnify
26 import TcSimplify
27 import TcEvidence
28 import TcHsType
29 import TcPat
30 import TcMType
31 import ConLike
32 import FamInstEnv( normaliseType )
33 import FamInst( tcGetFamInstEnvs )
34 import Type( pprSigmaTypeExtraCts )
35 import TyCon
36 import TcType
37 import TysPrim
38 import Id
39 import Var
40 import VarSet
41 import VarEnv( TidyEnv )
42 import Module
43 import Name
44 import NameSet
45 import NameEnv
46 import SrcLoc
47 import Bag
48 import ListSetOps
49 import ErrUtils
50 import Digraph
51 import Maybes
52 import Util
53 import BasicTypes
54 import Outputable
55 import FastString
56 import Type(mkStrLitTy)
57 import Class(classTyCon)
58 import PrelNames(ipClassName)
59 import TcValidity (checkValidType)
60
61 import Control.Monad
62 import Data.List (partition)
63
64 #include "HsVersions.h"
65
66 {-
67 ************************************************************************
68 * *
69 \subsection{Type-checking bindings}
70 * *
71 ************************************************************************
72
73 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
74 it needs to know something about the {\em usage} of the things bound,
75 so that it can create specialisations of them. So @tcBindsAndThen@
76 takes a function which, given an extended environment, E, typechecks
77 the scope of the bindings returning a typechecked thing and (most
78 important) an LIE. It is this LIE which is then used as the basis for
79 specialising the things bound.
80
81 @tcBindsAndThen@ also takes a "combiner" which glues together the
82 bindings and the "thing" to make a new "thing".
83
84 The real work is done by @tcBindWithSigsAndThen@.
85
86 Recursive and non-recursive binds are handled in essentially the same
87 way: because of uniques there are no scoping issues left. The only
88 difference is that non-recursive bindings can bind primitive values.
89
90 Even for non-recursive binding groups we add typings for each binder
91 to the LVE for the following reason. When each individual binding is
92 checked the type of its LHS is unified with that of its RHS; and
93 type-checking the LHS of course requires that the binder is in scope.
94
95 At the top-level the LIE is sure to contain nothing but constant
96 dictionaries, which we resolve at the module level.
97
98 Note [Polymorphic recursion]
99 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
100 The game plan for polymorphic recursion in the code above is
101
102 * Bind any variable for which we have a type signature
103 to an Id with a polymorphic type. Then when type-checking
104 the RHSs we'll make a full polymorphic call.
105
106 This fine, but if you aren't a bit careful you end up with a horrendous
107 amount of partial application and (worse) a huge space leak. For example:
108
109 f :: Eq a => [a] -> [a]
110 f xs = ...f...
111
112 If we don't take care, after typechecking we get
113
114 f = /\a -> \d::Eq a -> let f' = f a d
115 in
116 \ys:[a] -> ...f'...
117
118 Notice the the stupid construction of (f a d), which is of course
119 identical to the function we're executing. In this case, the
120 polymorphic recursion isn't being used (but that's a very common case).
121 This can lead to a massive space leak, from the following top-level defn
122 (post-typechecking)
123
124 ff :: [Int] -> [Int]
125 ff = f Int dEqInt
126
127 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
128 f' is another thunk which evaluates to the same thing... and you end
129 up with a chain of identical values all hung onto by the CAF ff.
130
131 ff = f Int dEqInt
132
133 = let f' = f Int dEqInt in \ys. ...f'...
134
135 = let f' = let f' = f Int dEqInt in \ys. ...f'...
136 in \ys. ...f'...
137
138 Etc.
139
140 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
141 which would make the space leak go away in this case
142
143 Solution: when typechecking the RHSs we always have in hand the
144 *monomorphic* Ids for each binding. So we just need to make sure that
145 if (Method f a d) shows up in the constraints emerging from (...f...)
146 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
147 to the "givens" when simplifying constraints. That's what the "lies_avail"
148 is doing.
149
150 Then we get
151
152 f = /\a -> \d::Eq a -> letrec
153 fm = \ys:[a] -> ...fm...
154 in
155 fm
156 -}
157
158 tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
159 -- The TcGblEnv contains the new tcg_binds and tcg_spects
160 -- The TcLclEnv has an extended type envt for the new bindings
161 tcTopBinds (ValBindsOut binds sigs)
162 = do { -- Pattern synonym bindings populate the global environment
163 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
164 do { gbl <- getGblEnv
165 ; lcl <- getLclEnv
166 ; return (gbl, lcl) }
167 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
168
169 ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
170 (tcg_binds tcg_env)
171 binds'
172 , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }
173
174 ; return (tcg_env', tcl_env) }
175 -- The top level bindings are flattened into a giant
176 -- implicitly-mutually-recursive LHsBinds
177
178 tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
179
180 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
181 tcRecSelBinds (ValBindsOut binds sigs)
182 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
183 do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
184 ; let tcg_env'
185 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
186 | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
187 (tcg_binds tcg_env)
188 rec_sel_binds }
189 -- Do not add the code for record-selector bindings when
190 -- compiling hs-boot files
191 ; return tcg_env' }
192 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
193
194 tcHsBootSigs :: HsValBinds Name -> TcM [Id]
195 -- A hs-boot file has only one BindGroup, and it only has type
196 -- signatures in it. The renamer checked all this
197 tcHsBootSigs (ValBindsOut binds sigs)
198 = do { checkTc (null binds) badBootDeclErr
199 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
200 where
201 tc_boot_sig (TypeSig lnames ty _) = mapM f lnames
202 where
203 f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name True) ty
204 ; return (mkVanillaGlobal name sigma_ty) }
205 -- Notice that we make GlobalIds, not LocalIds
206 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
207 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
208
209 badBootDeclErr :: MsgDoc
210 badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
211
212 ------------------------
213 tcLocalBinds :: HsLocalBinds Name -> TcM thing
214 -> TcM (HsLocalBinds TcId, thing)
215
216 tcLocalBinds EmptyLocalBinds thing_inside
217 = do { thing <- thing_inside
218 ; return (EmptyLocalBinds, thing) }
219
220 tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
221 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
222 ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
223 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
224
225 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
226 = do { ipClass <- tcLookupClass ipClassName
227 ; (given_ips, ip_binds') <-
228 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
229
230 -- If the binding binds ?x = E, we must now
231 -- discharge any ?x constraints in expr_lie
232 -- See Note [Implicit parameter untouchables]
233 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
234 [] given_ips thing_inside
235
236 ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
237 where
238 ips = [ip | L _ (IPBind (Left ip) _) <- ip_binds]
239
240 -- I wonder if we should do these one at at time
241 -- Consider ?x = 4
242 -- ?y = ?x + 1
243 tc_ip_bind ipClass (IPBind (Left ip) expr)
244 = do { ty <- newFlexiTyVarTy openTypeKind
245 ; let p = mkStrLitTy $ hsIPNameFS ip
246 ; ip_id <- newDict ipClass [ p, ty ]
247 ; expr' <- tcMonoExpr expr ty
248 ; let d = toDict ipClass p ty `fmap` expr'
249 ; return (ip_id, (IPBind (Right ip_id) d)) }
250 tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
251
252 -- Coerces a `t` into a dictionry for `IP "x" t`.
253 -- co : t -> IP "x" t
254 toDict ipClass x ty =
255 case unwrapNewTyCon_maybe (classTyCon ipClass) of
256 Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty]
257 Nothing -> panic "The dictionary for `IP` is not a newtype?"
258
259 {-
260 Note [Implicit parameter untouchables]
261 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
262 We add the type variables in the types of the implicit parameters
263 as untouchables, not so much because we really must not unify them,
264 but rather because we otherwise end up with constraints like this
265 Num alpha, Implic { wanted = alpha ~ Int }
266 The constraint solver solves alpha~Int by unification, but then
267 doesn't float that solved constraint out (it's not an unsolved
268 wanted). Result disaster: the (Num alpha) is again solved, this
269 time by defaulting. No no no.
270
271 However [Oct 10] this is all handled automatically by the
272 untouchable-range idea.
273
274 Note [Placeholder PatSyn kinds]
275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
276 Consider this (Trac #9161)
277
278 {-# LANGUAGE PatternSynonyms, DataKinds #-}
279 pattern A = ()
280 b :: A
281 b = undefined
282
283 Here, the type signature for b mentions A. But A is a pattern
284 synonym, which is typechecked (for very good reasons; a view pattern
285 in the RHS may mention a value binding) as part of a group of
286 bindings. It is entirely resonable to reject this, but to do so
287 we need A to be in the kind environment when kind-checking the signature for B.
288
289 Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding
290 A -> AGlobal (AConLike (PatSynCon _|_))
291 to the environment. Then TcHsType.tcTyVar will find A in the kind environment,
292 and will give a 'wrongThingErr' as a result. But the lookup of A won't fail.
293
294 The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in
295 tcTyVar, doesn't look inside the TcTyThing.
296 -}
297
298 tcValBinds :: TopLevelFlag
299 -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
300 -> TcM thing
301 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
302
303 tcValBinds top_lvl binds sigs thing_inside
304 = do { -- Typecheck the signature
305 ; (poly_ids, sig_fn, nwc_tvs) <- tcExtendKindEnv2 patsyn_placeholder_kinds $
306 -- See Note [Placeholder PatSyn kinds]
307 tcTySigs sigs
308
309 ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
310
311 -- Extend the envt right away with all
312 -- the Ids declared with type signatures
313 -- Use tcExtendIdEnv3 to avoid extending the TcIdBinder stack
314 ; tcExtendIdEnv3 [(idName id, id) | id <- poly_ids] (mkVarSet nwc_tvs) $ do
315 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
316 { thing <- thing_inside
317 -- See Note [Pattern synonym wrappers don't yield dependencies]
318 ; patsyn_workers <- mapM tcPatSynBuilderBind patsyns
319 ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ]
320 ; return (extra_binds, thing) }
321 ; return (binds' ++ extra_binds', thing) }}
322 where
323 patsyns
324 = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
325 patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
326 = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
327 placeholder_patsyn_tything
328 = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
329
330 ------------------------
331 tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
332 -> [(RecFlag, LHsBinds Name)] -> TcM thing
333 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
334 -- Typecheck a whole lot of value bindings,
335 -- one strongly-connected component at a time
336 -- Here a "strongly connected component" has the strightforward
337 -- meaning of a group of bindings that mention each other,
338 -- ignoring type signatures (that part comes later)
339
340 tcBindGroups _ _ _ [] thing_inside
341 = do { thing <- thing_inside
342 ; return ([], thing) }
343
344 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
345 = do { (group', (groups', thing))
346 <- tc_group top_lvl sig_fn prag_fn group $
347 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
348 ; return (group' ++ groups', thing) }
349
350 ------------------------
351 tc_group :: forall thing.
352 TopLevelFlag -> TcSigFun -> PragFun
353 -> (RecFlag, LHsBinds Name) -> 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) 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 thing_inside
369 ; return ( [(NonRecursive, bind')], thing) }
370
371 tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
372 = -- To maximise polymorphism, we do a new
373 -- strongly-connected-component analysis, this time omitting
374 -- any references to variables with type signatures.
375 -- (This used to be optional, but isn't now.)
376 do { traceTc "tc_group rec" (pprLHsBinds binds)
377 ; when hasPatSyn $ recursivePatSynErr binds
378 ; (binds1, thing) <- go sccs
379 ; return ([(Recursive, binds1)], thing) }
380 -- Rec them all together
381 where
382 hasPatSyn = anyBag (isPatSyn . unLoc) binds
383 isPatSyn PatSynBind{} = True
384 isPatSyn _ = False
385
386 sccs :: [SCC (LHsBind Name)]
387 sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
388
389 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
390 go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc
391 ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
392 go sccs
393 ; return (binds1 `unionBags` binds2, thing) }
394 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
395
396 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
397 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
398
399 tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
400
401 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
402 recursivePatSynErr binds
403 = failWithTc $
404 hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
405 2 (vcat $ map pprLBind . bagToList $ binds)
406 where
407 pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
408 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
409 pprLoc loc
410
411 tc_single :: forall thing.
412 TopLevelFlag -> TcSigFun -> PragFun
413 -> LHsBind Name -> TcM thing
414 -> TcM (LHsBinds TcId, thing)
415 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
416 = do { (pat_syn, aux_binds) <- tc_pat_syn_decl
417 ; let tything = AConLike (PatSynCon pat_syn)
418 ; thing <- tcExtendGlobalEnv [tything] thing_inside
419 ; return (aux_binds, thing)
420 }
421 where
422 tc_pat_syn_decl = case sig_fn name of
423 Nothing -> tcInferPatSynDecl psb
424 Just (TcPatSynInfo tpsi) -> tcCheckPatSynDecl psb tpsi
425 Just _ -> panic "tc_single"
426
427 tc_single top_lvl sig_fn prag_fn lbind thing_inside
428 = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
429 NonRecursive NonRecursive
430 [lbind]
431 ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
432 ; return (binds1, thing) }
433
434 -- | No signature or a partial signature
435 noCompleteSig :: Maybe TcSigInfo -> Bool
436 noCompleteSig Nothing = True
437 noCompleteSig (Just sig) = isPartialSig sig
438
439 ------------------------
440 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
441
442 type BKey = Int -- Just number off the bindings
443
444 mkEdges sig_fn binds
445 = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
446 Just key <- [lookupNameEnv key_map n], no_sig n ])
447 | (bind, key) <- keyd_binds
448 ]
449 where
450 no_sig :: Name -> Bool
451 no_sig n = noCompleteSig (sig_fn n)
452
453 keyd_binds = bagToList binds `zip` [0::BKey ..]
454
455 key_map :: NameEnv BKey -- Which binding it comes from
456 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
457 , bndr <- collectHsBindBinders bind ]
458
459 ------------------------
460 tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
461 -> RecFlag -- Whether the group is really recursive
462 -> RecFlag -- Whether it's recursive after breaking
463 -- dependencies based on type signatures
464 -> [LHsBind Name] -- None are PatSynBind
465 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
466
467 -- Typechecks a single bunch of values bindings all together,
468 -- and generalises them. The bunch may be only part of a recursive
469 -- group, because we use type signatures to maximise polymorphism
470 --
471 -- Returns a list because the input may be a single non-recursive binding,
472 -- in which case the dependency order of the resulting bindings is
473 -- important.
474 --
475 -- Knows nothing about the scope of the bindings
476 -- None of the bindings are pattern synonyms
477
478 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
479 = setSrcSpan loc $
480 recoverM (recoveryCode binder_names sig_fn) $ do
481 -- Set up main recover; take advantage of any type sigs
482
483 { traceTc "------------------------------------------------" Outputable.empty
484 ; traceTc "Bindings for {" (ppr binder_names)
485 ; dflags <- getDynFlags
486 ; type_env <- getLclTypeEnv
487 ; let plan = decideGeneralisationPlan dflags type_env
488 binder_names bind_list sig_fn
489 ; traceTc "Generalisation plan" (ppr plan)
490 ; result@(tc_binds, poly_ids, _) <- case plan of
491 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
492 InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list
493 CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
494
495 -- Check whether strict bindings are ok
496 -- These must be non-recursive etc, and are not generalised
497 -- They desugar to a case expression in the end
498 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
499 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
500 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
501 ])
502
503 ; return result }
504 where
505 binder_names = collectHsBindListBinders bind_list
506 loc = foldr1 combineSrcSpans (map getLoc bind_list)
507 -- The mbinds have been dependency analysed and
508 -- may no longer be adjacent; so find the narrowest
509 -- span that includes them all
510
511 ------------------
512 tcPolyNoGen -- No generalisation whatsoever
513 :: RecFlag -- Whether it's recursive after breaking
514 -- dependencies based on type signatures
515 -> PragFun -> TcSigFun
516 -> [LHsBind Name]
517 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
518
519 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
520 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
521 (LetGblBndr prag_fn)
522 bind_list
523 ; mono_ids' <- mapM tc_mono_info mono_infos
524 ; return (binds', mono_ids', NotTopLevel) }
525 where
526 tc_mono_info (name, _, mono_id)
527 = do { mono_ty' <- zonkTcType (idType mono_id)
528 -- Zonk, mainly to expose unboxed types to checkStrictBinds
529 ; let mono_id' = setIdType mono_id mono_ty'
530 ; _specs <- tcSpecPrags mono_id' (prag_fn name)
531 ; return mono_id' }
532 -- NB: tcPrags generates error messages for
533 -- specialisation pragmas for non-overloaded sigs
534 -- Indeed that is why we call it here!
535 -- So we can safely ignore _specs
536
537 ------------------
538 tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
539 -- dependencies based on type signatures
540 -> PragFun
541 -> TcSigInfo
542 -> LHsBind Name
543 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
544 -- There is just one binding,
545 -- it binds a single variable,
546 -- it has a signature,
547 tcPolyCheck rec_tc prag_fn
548 sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
549 , sig_nwcs = sig_nwcs, sig_theta = theta
550 , sig_tau = tau, sig_loc = loc
551 , sig_warn_redundant = warn_redundant })
552 bind
553 = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards
554 do { ev_vars <- newEvVars theta
555 ; let ctxt = FunSigCtxt (idName poly_id) warn_redundant
556 skol_info = SigSkol ctxt (mkPhiTy theta tau)
557 prag_sigs = prag_fn (idName poly_id)
558 tvs = map snd tvs_w_scoped
559 ; (ev_binds, (binds', [mono_info]))
560 <- setSrcSpan loc $
561 checkConstraints skol_info tvs ev_vars $
562 tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind]
563
564 ; spec_prags <- tcSpecPrags poly_id prag_sigs
565 ; poly_id <- addInlinePrags poly_id prag_sigs
566
567 ; let (_, _, mono_id) = mono_info
568 export = ABE { abe_wrap = idHsWrapper
569 , abe_poly = poly_id
570 , abe_mono = mono_id
571 , abe_prags = SpecPrags spec_prags }
572 abs_bind = L loc $ AbsBinds
573 { abs_tvs = tvs
574 , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
575 , abs_exports = [export], abs_binds = binds' }
576 closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
577 | otherwise = NotTopLevel
578 ; return (unitBag abs_bind, [poly_id], closed) }
579
580 tcPolyCheck _rec_tc _prag_fn sig _bind
581 = pprPanic "tcPolyCheck" (ppr sig)
582
583 ------------------
584 tcPolyInfer
585 :: RecFlag -- Whether it's recursive after breaking
586 -- dependencies based on type signatures
587 -> PragFun -> TcSigFun
588 -> Bool -- True <=> apply the monomorphism restriction
589 -> Bool -- True <=> free vars have closed types
590 -> [LHsBind Name]
591 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
592 tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
593 = do { ((binds', mono_infos), tclvl, wanted)
594 <- pushLevelAndCaptureConstraints $
595 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
596
597 ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
598 ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
599 ; (qtvs, givens, mr_bites, ev_binds)
600 <- simplifyInfer tclvl mono name_taus wanted
601
602 ; inferred_theta <- zonkTcThetaType (map evVarPred givens)
603 ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs inferred_theta)
604 mono_infos
605
606 ; loc <- getSrcSpanM
607 ; let poly_ids = map abe_poly exports
608 final_closed | closed && not mr_bites = TopLevel
609 | otherwise = NotTopLevel
610 abs_bind = L loc $
611 AbsBinds { abs_tvs = qtvs
612 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
613 , abs_exports = exports, abs_binds = binds' }
614
615 ; traceTc "Binding:" (ppr final_closed $$
616 ppr (poly_ids `zip` map idType poly_ids))
617 ; return (unitBag abs_bind, poly_ids, final_closed) }
618 -- poly_ids are guaranteed zonked by mkExport
619
620 --------------
621 mkExport :: PragFun
622 -> [TyVar] -> TcThetaType -- Both already zonked
623 -> MonoBindInfo
624 -> TcM (ABExport Id)
625 -- Only called for generalisation plan IferGen, not by CheckGen or NoGen
626 --
627 -- mkExport generates exports with
628 -- zonked type variables,
629 -- zonked poly_ids
630 -- The former is just because no further unifications will change
631 -- the quantified type variables, so we can fix their final form
632 -- right now.
633 -- The latter is needed because the poly_ids are used to extend the
634 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
635
636 -- Pre-condition: the qtvs and theta are already zonked
637
638 mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
639 = do { mono_ty <- zonkTcType (idType mono_id)
640
641 ; poly_id <- case mb_sig of
642 Nothing -> mkInferredPolyId poly_name qtvs inferred_theta mono_ty
643 Just (TcPatSynInfo _) -> panic "mkExport"
644 Just sig | isPartialSig sig
645 -> do { final_theta <- completeTheta inferred_theta sig
646 ; mkInferredPolyId poly_name qtvs final_theta mono_ty }
647 | otherwise
648 -> return (sig_id sig)
649
650 -- NB: poly_id has a zonked type
651 ; poly_id <- addInlinePrags poly_id prag_sigs
652 ; spec_prags <- tcSpecPrags poly_id prag_sigs
653 -- tcPrags requires a zonked poly_id
654
655 ; let sel_poly_ty = mkSigmaTy qtvs inferred_theta mono_ty
656 ; traceTc "mkExport: check sig"
657 (vcat [ ppr poly_name, ppr sel_poly_ty, ppr (idType poly_id) ])
658
659 -- Perform the impedence-matching and ambiguity check
660 -- right away. If it fails, we want to fail now (and recover
661 -- in tcPolyBinds). If we delay checking, we get an error cascade.
662 -- Remember we are in the tcPolyInfer case, so the type envt is
663 -- closed (unless we are doing NoMonoLocalBinds in which case all bets
664 -- are off)
665 -- See Note [Impedence matching]
666 ; (wrap, wanted) <- addErrCtxtM (mk_bind_msg inferred True poly_name (idType poly_id)) $
667 captureConstraints $
668 tcSubType_NC sig_ctxt sel_poly_ty (idType poly_id)
669 ; ev_binds <- simplifyTop wanted
670
671 ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
672 , abe_poly = poly_id
673 , abe_mono = mono_id
674 , abe_prags = SpecPrags spec_prags }) }
675 where
676 inferred = isNothing mb_sig
677 prag_sigs = prag_fn poly_name
678 sig_ctxt = InfSigCtxt poly_name
679
680 mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id
681 -- In the inference case (no signature) this stuff figures out
682 -- the right type variables and theta to quantify over
683 -- See Note [Validity of inferred types]
684 mkInferredPolyId poly_name qtvs theta mono_ty
685 = do { fam_envs <- tcGetFamInstEnvs
686
687 ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty
688 -- Unification may not have normalised the type,
689 -- (see Note [Lazy flattening] in TcFlatten) so do it
690 -- here to make it as uncomplicated as possible.
691 -- Example: f :: [F Int] -> Bool
692 -- should be rewritten to f :: [Char] -> Bool, if possible
693
694 my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty))
695 -- Include kind variables! Trac #7916
696
697 my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order
698 my_theta = filter (quantifyPred my_tvs2) theta
699 inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty
700
701 ; addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $
702 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
703
704 ; return (mkLocalId poly_name inferred_poly_ty) }
705
706 mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
707 mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env
708 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env poly_ty
709 ; return (tidy_env', mk_msg tidy_ty) }
710 where
711 mk_msg ty = vcat [ ptext (sLit "When checking that") <+> quotes (ppr poly_name)
712 <+> ptext (sLit "has the") <+> what <+> ptext (sLit "type")
713 , nest 2 (ppr poly_name <+> dcolon <+> ppr ty)
714 , ppWhen want_ambig $
715 ptext (sLit "Probable cause: the inferred type is ambiguous") ]
716 what | inferred = ptext (sLit "inferred")
717 | otherwise = ptext (sLit "specified")
718
719
720 -- | Report the inferred constraints for an extra-constraints wildcard/hole as
721 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
722 -- case, the extra inferred constraints are accepted without complaining.
723 -- Returns the annotated constraints combined with the inferred constraints.
724 completeTheta :: TcThetaType -> TcSigInfo -> TcM TcThetaType
725 completeTheta _ (TcPatSynInfo _)
726 = panic "Extra-constraints wildcard not supported in a pattern signature"
727 completeTheta inferred_theta
728 sig@(TcSigInfo { sig_id = poly_id
729 , sig_extra_cts = mb_extra_cts
730 , sig_theta = annotated_theta })
731 | Just loc <- mb_extra_cts
732 = do { annotated_theta <- zonkTcThetaType annotated_theta
733 ; let inferred_diff = minusList inferred_theta annotated_theta
734 final_theta = annotated_theta ++ inferred_diff
735 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
736 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
737 ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
738 ; case partial_sigs of
739 True | warn_partial_sigs -> reportWarning msg
740 | otherwise -> return ()
741 False -> reportError msg
742 ; return final_theta }
743
744 | otherwise
745 = zonkTcThetaType annotated_theta
746 -- No extra-constraints wildcard means no extra constraints will be added
747 -- to the context, so just return the possibly empty (zonked)
748 -- annotated_theta.
749 where
750 pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
751 mk_msg inferred_diff suppress_hint
752 = vcat [ hang ((text "Found hole") <+> quotes (char '_'))
753 2 (text "with inferred constraints:")
754 <+> pprTheta inferred_diff
755 , if suppress_hint then empty else pts_hint
756 , typeSigCtxt (idName poly_id) sig ]
757
758 {-
759 Note [Partial type signatures and generalisation]
760 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
761 When we have a partial type signature, like
762 f :: _ -> Int
763 then we *always* use the InferGen plan, and hence tcPolyInfer.
764 We do this even for a local binding with -XMonoLocalBinds.
765 Reasons:
766 * The TcSigInfo for 'f' has a unification variable for the '_',
767 whose TcLevel is one level deeper than the current level.
768 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
769 the TcLevel like InferGen, so we lose the level invariant.
770
771 * The signature might be f :: forall a. _ -> a
772 so it really is polymorphic. It's not clear what it would
773 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
774 in the (Just sig) case, checks that if there is a signature
775 then we are using LetLclBndr, and hence a nested AbsBinds with
776 increased TcLevel
777
778 It might be possible to fix these difficulties somehow, but there
779 doesn't seem much point. Indeed, adding a partial type signature is a
780 way to get per-binding inferred generalisation.
781
782 Note [Validity of inferred types]
783 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
784 We need to check inferred type for validity, in case it uses language
785 extensions that are not turned on. The principle is that if the user
786 simply adds the inferred type to the program source, it'll compile fine.
787 See #8883.
788
789 Examples that might fail:
790 - an inferred theta that requires type equalities e.g. (F a ~ G b)
791 or multi-parameter type classes
792 - an inferred type that includes unboxed tuples
793
794 However we don't do the ambiguity check (checkValidType omits it for
795 InfSigCtxt) because the impedence-matching stage, which follows
796 immediately, will do it and we don't want two error messages.
797 Moreover, because of the impedence matching stage, the ambiguity-check
798 suggestion of -XAllowAmbiguiousTypes will not work.
799
800
801 Note [Impedence matching]
802 ~~~~~~~~~~~~~~~~~~~~~~~~~
803 Consider
804 f 0 x = x
805 f n x = g [] (not x)
806
807 g [] y = f 10 y
808 g _ y = f 9 y
809
810 After typechecking we'll get
811 f_mono_ty :: a -> Bool -> Bool
812 g_mono_ty :: [b] -> Bool -> Bool
813 with constraints
814 (Eq a, Num a)
815
816 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
817 The types we really want for f and g are
818 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
819 g :: forall b. [b] -> Bool -> Bool
820
821 We can get these by "impedence matching":
822 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
823 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
824
825 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
826 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
827
828 Suppose the shared quantified tyvars are qtvs and constraints theta.
829 Then we want to check that
830 f's polytype is more polymorphic than forall qtvs. theta => f_mono_ty
831 and the proof is the impedence matcher.
832
833 Notice that the impedence matcher may do defaulting. See Trac #7173.
834
835 It also cleverly does an ambiguity check; for example, rejecting
836 f :: F a -> a
837 where F is a non-injective type function.
838 -}
839
840 type PragFun = Name -> [LSig Name]
841
842 mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
843 mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
844 where
845 prs = mapMaybe get_sig sigs
846
847 get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
848 get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl))
849 get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl))
850 get_sig _ = Nothing
851
852 add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function
853 | Just ar <- lookupNameEnv ar_env n,
854 Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar }
855 -- add arity only for real INLINE pragmas, not INLINABLE
856 | otherwise = inl_prag
857
858 prag_env :: NameEnv [LSig Name]
859 prag_env = foldl add emptyNameEnv prs
860 add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
861
862 -- ar_env maps a local to the arity of its definition
863 ar_env :: NameEnv Arity
864 ar_env = foldrBag lhsBindArity emptyNameEnv binds
865
866 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
867 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
868 = extendNameEnv env (unLoc id) (matchGroupArity ms)
869 lhsBindArity _ env = env -- PatBind/VarBind
870
871 ------------------
872 tcSpecPrags :: Id -> [LSig Name]
873 -> TcM [LTcSpecPrag]
874 -- Add INLINE and SPECIALSE pragmas
875 -- INLINE prags are added to the (polymorphic) Id directly
876 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
877 -- Pre-condition: the poly_id is zonked
878 -- Reason: required by tcSubExp
879 tcSpecPrags poly_id prag_sigs
880 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
881 ; unless (null bad_sigs) warn_discarded_sigs
882 ; pss <- mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs
883 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
884 where
885 spec_sigs = filter isSpecLSig prag_sigs
886 bad_sigs = filter is_bad_sig prag_sigs
887 is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
888
889 warn_discarded_sigs = warnPrags poly_id bad_sigs $
890 ptext (sLit "Discarding unexpected pragmas for")
891
892
893 --------------
894 tcSpec :: TcId -> Sig Name -> TcM [TcSpecPrag]
895 tcSpec poly_id prag@(SpecSig fun_name hs_tys inl)
896 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
897 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
898 -- for the selector Id, but the poly_id is something like $cop
899 -- However we want to use fun_name in the error message, since that is
900 -- what the user wrote (Trac #8537)
901 = addErrCtxt (spec_ctxt prag) $
902 do { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys
903 ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
904 (ptext (sLit "SPECIALISE pragma for non-overloaded function")
905 <+> quotes (ppr fun_name))
906 -- Note [SPECIALISE pragmas]
907 ; wraps <- mapM (tcSubType sig_ctxt (idType poly_id)) spec_tys
908 ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] }
909 where
910 name = idName poly_id
911 poly_ty = idType poly_id
912 sig_ctxt = FunSigCtxt name True
913 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
914
915 tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
916
917 --------------
918 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
919 -- SPECIALISE pragmas for imported things
920 tcImpPrags prags
921 = do { this_mod <- getModule
922 ; dflags <- getDynFlags
923 ; if (not_specialising dflags) then
924 return []
925 else do
926 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
927 [L loc (name,prag)
928 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
929 , not (nameIsLocalOrFrom this_mod name) ]
930 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
931 where
932 -- Ignore SPECIALISE pragmas for imported things
933 -- when we aren't specialising, or when we aren't generating
934 -- code. The latter happens when Haddocking the base library;
935 -- we don't wnat complaints about lack of INLINABLE pragmas
936 not_specialising dflags
937 | not (gopt Opt_Specialise dflags) = True
938 | otherwise = case hscTarget dflags of
939 HscNothing -> True
940 HscInterpreted -> True
941 _other -> False
942
943 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
944 tcImpSpec (name, prag)
945 = do { id <- tcLookupId name
946 ; unless (isAnyInlinePragma (idInlinePragma id))
947 (addWarnTc (impSpecErr name))
948 ; tcSpec id prag }
949
950 impSpecErr :: Name -> SDoc
951 impSpecErr name
952 = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
953 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
954 , parens $ sep
955 [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
956 , ptext (sLit "was compiled without -O")]])
957 where
958 mod = nameModule name
959
960 --------------
961 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
962 tcVectDecls decls
963 = do { decls' <- mapM (wrapLocM tcVect) decls
964 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
965 dups = findDupsEq (==) ids
966 ; mapM_ reportVectDups dups
967 ; traceTcConstraints "End of tcVectDecls"
968 ; return decls'
969 }
970 where
971 reportVectDups (first:_second:_more)
972 = addErrAt (getSrcSpan first) $
973 ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
974 reportVectDups _ = return ()
975
976 --------------
977 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
978 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
979 -- type of the original definition as this requires internals of the vectoriser not available
980 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
981 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
982 -- from the vectoriser here.
983 tcVect (HsVect name rhs)
984 = addErrCtxt (vectCtxt name) $
985 do { var <- wrapLocM tcLookupId name
986 ; let L rhs_loc (HsVar rhs_var_name) = rhs
987 ; rhs_id <- tcLookupId rhs_var_name
988 ; return $ HsVect var (L rhs_loc (HsVar rhs_id))
989 }
990
991 {- OLD CODE:
992 -- turn the vectorisation declaration into a single non-recursive binding
993 ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
994 sigFun = const Nothing
995 pragFun = mkPragFun [] (unitBag bind)
996
997 -- perform type inference (including generalisation)
998 ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
999
1000 ; traceTc "tcVect inferred type" $ ppr (varType id')
1001 ; traceTc "tcVect bindings" $ ppr binds
1002
1003 -- add all bindings, including the type variable and dictionary bindings produced by type
1004 -- generalisation to the right-hand side of the vectorisation declaration
1005 ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
1006 ; let [bind'] = bagToList actualBinds
1007 MatchGroup
1008 [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
1009 _ = (fun_matches . unLoc) bind'
1010 rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
1011
1012 -- We return the type-checked 'Id', to propagate the inferred signature
1013 -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
1014 ; return $ HsVect (L loc id') (Just rhsWrapped)
1015 }
1016 -}
1017 tcVect (HsNoVect name)
1018 = addErrCtxt (vectCtxt name) $
1019 do { var <- wrapLocM tcLookupId name
1020 ; return $ HsNoVect var
1021 }
1022 tcVect (HsVectTypeIn isScalar lname rhs_name)
1023 = addErrCtxt (vectCtxt lname) $
1024 do { tycon <- tcLookupLocatedTyCon lname
1025 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1026 || isJust rhs_name -- or we explicitly provide a vectorised type
1027 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1028 )
1029 scalarTyConMustBeNullary
1030
1031 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1032 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1033 }
1034 tcVect (HsVectTypeOut _ _ _)
1035 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1036 tcVect (HsVectClassIn lname)
1037 = addErrCtxt (vectCtxt lname) $
1038 do { cls <- tcLookupLocatedClass lname
1039 ; return $ HsVectClassOut cls
1040 }
1041 tcVect (HsVectClassOut _)
1042 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1043 tcVect (HsVectInstIn linstTy)
1044 = addErrCtxt (vectCtxt linstTy) $
1045 do { (cls, tys) <- tcHsVectInst linstTy
1046 ; inst <- tcLookupInstance cls tys
1047 ; return $ HsVectInstOut inst
1048 }
1049 tcVect (HsVectInstOut _)
1050 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1051
1052 vectCtxt :: Outputable thing => thing -> SDoc
1053 vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
1054
1055 scalarTyConMustBeNullary :: MsgDoc
1056 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
1057
1058 --------------
1059 -- If typechecking the binds fails, then return with each
1060 -- signature-less binder given type (forall a.a), to minimise
1061 -- subsequent error messages
1062 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
1063 recoveryCode binder_names sig_fn
1064 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
1065 ; poly_ids <- mapM mk_dummy binder_names
1066 ; return (emptyBag, poly_ids, if all is_closed poly_ids
1067 then TopLevel else NotTopLevel) }
1068 where
1069 mk_dummy name
1070 | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up
1071 | otherwise = return (mkLocalId name forall_a_a) -- No signature
1072
1073 is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))
1074
1075 forall_a_a :: TcType
1076 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
1077
1078 {-
1079 Note [SPECIALISE pragmas]
1080 ~~~~~~~~~~~~~~~~~~~~~~~~~
1081 There is no point in a SPECIALISE pragma for a non-overloaded function:
1082 reverse :: [a] -> [a]
1083 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1084
1085 But SPECIALISE INLINE *can* make sense for GADTS:
1086 data Arr e where
1087 ArrInt :: !Int -> ByteArray# -> Arr Int
1088 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1089
1090 (!:) :: Arr e -> Int -> e
1091 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1092 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1093 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1094 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1095
1096 When (!:) is specialised it becomes non-recursive, and can usefully
1097 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1098 for a non-overloaded function.
1099
1100 ************************************************************************
1101 * *
1102 \subsection{tcMonoBind}
1103 * *
1104 ************************************************************************
1105
1106 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1107 The signatures have been dealt with already.
1108
1109 Note [Pattern bindings]
1110 ~~~~~~~~~~~~~~~~~~~~~~~
1111 The rule for typing pattern bindings is this:
1112
1113 ..sigs..
1114 p = e
1115
1116 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1117 typechecks exactly like
1118
1119 ..sigs..
1120 x = e -- Inferred type
1121 v1 = case x of p -> v1
1122 ..
1123 vn = case x of p -> vn
1124
1125 Note that
1126 (f :: forall a. a -> a) = id
1127 should not typecheck because
1128 case id of { (f :: forall a. a->a) -> f }
1129 will not typecheck.
1130 -}
1131
1132 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1133 -- i.e. the binders are mentioned in their RHSs, and
1134 -- we are not rescued by a type signature
1135 -> TcSigFun -> LetBndrSpec
1136 -> [LHsBind Name]
1137 -> TcM (LHsBinds TcId, [MonoBindInfo])
1138
1139 tcMonoBinds is_rec sig_fn no_gen
1140 [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
1141 fun_matches = matches, bind_fvs = fvs })]
1142 -- Single function binding,
1143 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1144 , Nothing <- sig_fn name -- ...with no type signature
1145 = -- In this very special case we infer the type of the
1146 -- right hand side first (it may have a higher-rank type)
1147 -- and *then* make the monomorphic Id for the LHS
1148 -- e.g. f = \(x::forall a. a->a) -> <body>
1149 -- We want to infer a higher-rank type for f
1150 setSrcSpan b_loc $
1151 do { rhs_ty <- newFlexiTyVarTy openTypeKind
1152 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1153 ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1154 -- We extend the error context even for a non-recursive
1155 -- function so that in type error messages we show the
1156 -- type of the thing whose rhs we are type checking
1157 tcMatchesFun name inf matches rhs_ty
1158
1159 ; return (unitBag $ L b_loc $
1160 FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
1161 fun_matches = matches', bind_fvs = fvs,
1162 fun_co_fn = co_fn, fun_tick = [] },
1163 [(name, Nothing, mono_id)]) }
1164
1165 tcMonoBinds _ sig_fn no_gen binds
1166 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1167
1168 -- Bring the monomorphic Ids, into scope for the RHSs
1169 ; let mono_info = getMonoBindInfo tc_binds
1170 rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
1171 , noCompleteSig mb_sig ]
1172 -- A monomorphic binding for each term variable that lacks
1173 -- a type sig. (Ones with a sig are already in scope.)
1174
1175 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1176 | (n,id) <- rhs_id_env]
1177 ; binds' <- tcExtendIdEnv2 rhs_id_env $
1178 mapM (wrapLocM tcRhs) tc_binds
1179 ; return (listToBag binds', mono_info) }
1180
1181 ------------------------
1182 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1183 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1184 -- if there's a signature for it, use the instantiated signature type
1185 -- otherwise invent a type variable
1186 -- You see that quite directly in the FunBind case.
1187 --
1188 -- But there's a complication for pattern bindings:
1189 -- data T = MkT (forall a. a->a)
1190 -- MkT f = e
1191 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1192 -- but we want to get (f::forall a. a->a) as the RHS environment.
1193 -- The simplest way to do this is to typecheck the pattern, and then look up the
1194 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1195 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1196
1197 data TcMonoBind -- Half completed; LHS done, RHS not done
1198 = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name))
1199 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1200
1201 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
1202 -- Type signature (if any), and
1203 -- the monomorphic bound things
1204
1205 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1206 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
1207 | Just sig <- sig_fn name
1208 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1209 , ppr name )
1210 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1211 -- or InferGen (partial signature)
1212 -- see Note [Partial type signatures and generalisation]
1213 -- Both InferGen and CheckGen gives rise to LetLclBndr
1214 do { mono_name <- newLocalName name
1215 ; let mono_id = mkLocalId mono_name (sig_tau sig)
1216 ; addErrCtxt (typeSigCtxt name sig) $
1217 emitWildcardHoleConstraints (sig_nwcs sig)
1218 ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
1219
1220 | otherwise
1221 = do { mono_ty <- newFlexiTyVarTy openTypeKind
1222 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1223 ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
1224
1225 -- TODOT: emit Hole Constraints for wildcards
1226 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1227 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1228 mapM lookup_info (collectPatBinders pat)
1229
1230 -- After typechecking the pattern, look up the binder
1231 -- names, which the pattern has brought into scope.
1232 lookup_info :: Name -> TcM MonoBindInfo
1233 lookup_info name = do { mono_id <- tcLookupId name
1234 ; return (name, sig_fn name, mono_id) }
1235
1236 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1237 tcInfer tc_pat
1238
1239 ; return (TcPatBind infos pat' grhss pat_ty) }
1240
1241 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1242 -- AbsBind, VarBind impossible
1243
1244 -------------------
1245 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1246 -- When we are doing pattern bindings, or multiple function bindings at a time
1247 -- we *don't* bring any scoped type variables into scope
1248 -- Wny not? They are not completely rigid.
1249 -- That's why we have the special case for a single FunBind in tcMonoBinds
1250 tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches)
1251 = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1252 tcExtendTyVarEnv2 tvsAndNwcs $
1253 -- NotTopLevel: it's a monomorphic binding
1254 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1255 ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
1256 matches (idType mono_id)
1257 ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
1258 , fun_matches = matches'
1259 , fun_co_fn = co_fn
1260 , bind_fvs = placeHolderNamesTc
1261 , fun_tick = [] }) }
1262 where
1263 tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig]
1264 ++ sig_nwcs sig) mb_sig
1265
1266 tcRhs (TcPatBind infos pat' grhss pat_ty)
1267 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $
1268 -- NotTopLevel: it's a monomorphic binding
1269 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1270 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1271 tcGRHSsPat grhss pat_ty
1272 ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
1273 , bind_fvs = placeHolderNamesTc
1274 , pat_ticks = ([],[]) }) }
1275
1276
1277 ---------------------
1278 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1279 getMonoBindInfo tc_binds
1280 = foldr (get_info . unLoc) [] tc_binds
1281 where
1282 get_info (TcFunBind info _ _ _) rest = info : rest
1283 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1284
1285 {-
1286 ************************************************************************
1287 * *
1288 Signatures
1289 * *
1290 ************************************************************************
1291
1292 Type signatures are tricky. See Note [Signature skolems] in TcType
1293
1294 @tcSigs@ checks the signatures for validity, and returns a list of
1295 {\em freshly-instantiated} signatures. That is, the types are already
1296 split up, and have fresh type variables installed. All non-type-signature
1297 "RenamedSigs" are ignored.
1298
1299 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1300 the variable's type, and after that checked to see whether they've
1301 been instantiated.
1302
1303 Note [Scoped tyvars]
1304 ~~~~~~~~~~~~~~~~~~~~
1305 The -XScopedTypeVariables flag brings lexically-scoped type variables
1306 into scope for any explicitly forall-quantified type variables:
1307 f :: forall a. a -> a
1308 f x = e
1309 Then 'a' is in scope inside 'e'.
1310
1311 However, we do *not* support this
1312 - For pattern bindings e.g
1313 f :: forall a. a->a
1314 (f,g) = e
1315
1316 Note [Signature skolems]
1317 ~~~~~~~~~~~~~~~~~~~~~~~~
1318 When instantiating a type signature, we do so with either skolems or
1319 SigTv meta-type variables depending on the use_skols boolean. This
1320 variable is set True when we are typechecking a single function
1321 binding; and False for pattern bindings and a group of several
1322 function bindings.
1323
1324 Reason: in the latter cases, the "skolems" can be unified together,
1325 so they aren't properly rigid in the type-refinement sense.
1326 NB: unless we are doing H98, each function with a sig will be done
1327 separately, even if it's mutually recursive, so use_skols will be True
1328
1329
1330 Note [Only scoped tyvars are in the TyVarEnv]
1331 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1332 We are careful to keep only the *lexically scoped* type variables in
1333 the type environment. Why? After all, the renamer has ensured
1334 that only legal occurrences occur, so we could put all type variables
1335 into the type env.
1336
1337 But we want to check that two distinct lexically scoped type variables
1338 do not map to the same internal type variable. So we need to know which
1339 the lexically-scoped ones are... and at the moment we do that by putting
1340 only the lexically scoped ones into the environment.
1341
1342 Note [Instantiate sig with fresh variables]
1343 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1344 It's vital to instantiate a type signature with fresh variables.
1345 For example:
1346 type T = forall a. [a] -> [a]
1347 f :: T;
1348 f = g where { g :: T; g = <rhs> }
1349
1350 We must not use the same 'a' from the defn of T at both places!!
1351 (Instantiation is only necessary because of type synonyms. Otherwise,
1352 it's all cool; each signature has distinct type variables from the renamer.)
1353
1354 Note [Fail eagerly on bad signatures]
1355 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1356 If a type signaure is wrong, fail immediately:
1357
1358 * the type sigs may bind type variables, so proceeding without them
1359 can lead to a cascade of errors
1360
1361 * the type signature might be ambiguous, in which case checking
1362 the code against the signature will give a very similar error
1363 to the ambiguity error.
1364
1365 ToDo: this means we fall over if any type sig
1366 is wrong (eg at the top level of the module),
1367 which is over-conservative
1368 -}
1369
1370 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar])
1371 tcTySigs hs_sigs
1372 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1373 do { (ty_sigs_s, tyvarsl) <- unzip <$> mapAndRecoverM tcTySig hs_sigs
1374 ; let ty_sigs = concat ty_sigs_s
1375 poly_ids = [id | TcSigInfo{ sig_id = id } <- ty_sigs]
1376 env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs]
1377 ; return (poly_ids, lookupNameEnv env, concat tyvarsl) }
1378
1379 tcTySig :: LSig Name -> TcM ([TcSigInfo], [TcTyVar])
1380 tcTySig (L _ (IdSig id))
1381 = do { sig <- instTcTySigFromId id
1382 ; return ([sig], []) }
1383 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
1384 = setSrcSpan loc $
1385 pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1386 -- so that they can be unified under the forall
1387 do { -- Generate fresh meta vars for the wildcards
1388 ; nwc_tvs <- mapM newWildcardVarMetaKind wcs
1389
1390 ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1 False) hs_ty
1391
1392 ; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
1393 (map unLoc names)
1394 ; return (sigs, nwc_tvs) }
1395 where
1396 extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra
1397 extra_cts _ = Nothing
1398
1399 tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
1400 = setSrcSpan loc $
1401 do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
1402 ; let ctxt = FunSigCtxt name False
1403 ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
1404 { ty' <- tcHsSigType ctxt ty
1405 ; req' <- tcHsContext req
1406 ; prov' <- tcHsContext prov
1407
1408 ; qtvs' <- mapM zonkQuantifiedTyVar qtvs'
1409
1410 ; let (_, pat_ty) = tcSplitFunTys ty'
1411 univ_set = tyVarsOfType pat_ty
1412 (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
1413
1414 ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
1415 ; let tpsi = TPSI{ patsig_name = name,
1416 patsig_tau = ty',
1417 patsig_ex = ex_tvs,
1418 patsig_univ = univ_tvs,
1419 patsig_prov = prov',
1420 patsig_req = req' }
1421 ; return ([TcPatSynInfo tpsi], []) }}
1422 tcTySig _ = return ([], [])
1423
1424 instTcTySigFromId :: Id -> TcM TcSigInfo
1425 instTcTySigFromId id
1426 = do { let loc = getSrcSpan id
1427 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1428 (idType id)
1429 ; return (TcSigInfo { sig_id = id, sig_loc = loc
1430 , sig_tvs = [(Nothing, tv) | tv <- tvs]
1431 , sig_nwcs = []
1432 , sig_theta = theta, sig_tau = tau
1433 , sig_extra_cts = Nothing
1434 , sig_partial = False
1435 , sig_warn_redundant = False
1436 -- Do not report redundant constraints for
1437 -- instance methods and record selectors
1438 }) }
1439
1440 instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType
1441 -> Maybe SrcSpan -- Just loc <=> an extra-constraints
1442 -- wildcard is present at location loc.
1443 -> [(Name, TcTyVar)] -- Named wildcards
1444 -> Name -- Name of the function
1445 -> TcM TcSigInfo
1446 instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
1447 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1448 ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty
1449 , sig_loc = loc
1450 , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs
1451 , sig_nwcs = nwcs
1452 , sig_theta = theta, sig_tau = tau
1453 , sig_extra_cts = extra_cts
1454 , sig_partial = isJust extra_cts || not (null nwcs)
1455 , sig_warn_redundant = True
1456 }) }
1457
1458 -------------------------------
1459 data GeneralisationPlan
1460 = NoGen -- No generalisation, no AbsBinds
1461
1462 | InferGen -- Implicit generalisation; there is an AbsBinds
1463 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1464 Bool -- True <=> bindings mention only variables with closed types
1465 -- See Note [Bindings with closed types] in TcRnTypes
1466
1467 | CheckGen (LHsBind Name) TcSigInfo
1468 -- One binding with a signature
1469 -- Explicit generalisation; there is an AbsBinds
1470
1471 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1472 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1473
1474 instance Outputable GeneralisationPlan where
1475 ppr NoGen = ptext (sLit "NoGen")
1476 ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
1477 ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
1478
1479 decideGeneralisationPlan
1480 :: DynFlags -> TcTypeEnv -> [Name]
1481 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1482 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1483 | strict_pat_binds = NoGen
1484 | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig
1485 -- See Note [Partial type signatures and generalisation]
1486 then infer_plan
1487 else CheckGen lbind sig
1488 | mono_local_binds = NoGen
1489 | otherwise = infer_plan
1490 where
1491 infer_plan = InferGen mono_restriction closed_flag
1492 bndr_set = mkNameSet bndr_names
1493 binds = map unLoc lbinds
1494
1495 strict_pat_binds = any isStrictHsBind binds
1496 -- Strict patterns (top level bang or unboxed tuple) must not
1497 -- be polymorphic, because we are going to force them
1498 -- See Trac #4498, #8762
1499
1500 mono_restriction = xopt Opt_MonomorphismRestriction dflags
1501 && any restricted binds
1502
1503 is_closed_ns :: NameSet -> Bool -> Bool
1504 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1505 -- ns are the Names referred to from the RHS of this bind
1506
1507 is_closed_id :: Name -> Bool
1508 -- See Note [Bindings with closed types] in TcRnTypes
1509 is_closed_id name
1510 | name `elemNameSet` bndr_set
1511 = True -- Ignore binders in this groups, of course
1512 | Just thing <- lookupNameEnv type_env name
1513 = case thing of
1514 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1515 ATyVar {} -> False -- In-scope type variables
1516 AGlobal {} -> True -- are not closed!
1517 _ -> pprPanic "is_closed_id" (ppr name)
1518 | otherwise
1519 = WARN( isInternalName name, ppr name ) True
1520 -- The free-var set for a top level binding mentions
1521 -- imported things too, so that we can report unused imports
1522 -- These won't be in the local type env.
1523 -- Ditto class method etc from the current module
1524
1525 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1526
1527 mono_local_binds = xopt Opt_MonoLocalBinds dflags
1528 && not closed_flag
1529
1530 no_sig n = noCompleteSig (sig_fn n)
1531
1532 -- With OutsideIn, all nested bindings are monomorphic
1533 -- except a single function binding with a signature
1534 one_funbind_with_sig
1535 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1536 , Just sig <- sig_fn (unLoc v)
1537 = Just (lbind, sig)
1538 | otherwise
1539 = Nothing
1540
1541 -- The Haskell 98 monomorphism resetriction
1542 restricted (PatBind {}) = True
1543 restricted (VarBind { var_id = v }) = no_sig v
1544 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1545 && no_sig (unLoc v)
1546 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1547 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1548
1549 restricted_match (MG { mg_alts = L _ (Match [] _ _) : _ }) = True
1550 restricted_match _ = False
1551 -- No args => like a pattern binding
1552 -- Some args => a function binding
1553
1554 -------------------
1555 checkStrictBinds :: TopLevelFlag -> RecFlag
1556 -> [LHsBind Name]
1557 -> LHsBinds TcId -> [Id]
1558 -> TcM ()
1559 -- Check that non-overloaded unlifted bindings are
1560 -- a) non-recursive,
1561 -- b) not top level,
1562 -- c) not a multiple-binding group (more or less implied by (a))
1563
1564 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1565 | unlifted_bndrs || any_strict_pat -- This binding group must be matched strictly
1566 = do { checkTc (isNotTopLevel top_lvl)
1567 (strictBindErr "Top-level" unlifted_bndrs orig_binds)
1568 ; checkTc (isNonRec rec_group)
1569 (strictBindErr "Recursive" unlifted_bndrs orig_binds)
1570
1571 ; checkTc (all is_monomorphic (bagToList tc_binds))
1572 (polyBindErr orig_binds)
1573 -- data Ptr a = Ptr Addr#
1574 -- f x = let p@(Ptr y) = ... in ...
1575 -- Here the binding for 'p' is polymorphic, but does
1576 -- not mix with an unlifted binding for 'y'. You should
1577 -- use a bang pattern. Trac #6078.
1578
1579 ; checkTc (isSingleton orig_binds)
1580 (strictBindErr "Multiple" unlifted_bndrs orig_binds)
1581
1582 -- Complain about a binding that looks lazy
1583 -- e.g. let I# y = x in ...
1584 -- Remember, in checkStrictBinds we are going to do strict
1585 -- matching, so (for software engineering reasons) we insist
1586 -- that the strictness is manifest on each binding
1587 -- However, lone (unboxed) variables are ok
1588 ; checkTc (not any_pat_looks_lazy)
1589 (unliftedMustBeBang orig_binds) }
1590 | otherwise
1591 = traceTc "csb2" (ppr poly_ids) >>
1592 return ()
1593 where
1594 unlifted_bndrs = any is_unlifted poly_ids
1595 any_strict_pat = any (isStrictHsBind . unLoc) orig_binds
1596 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1597
1598 is_unlifted id = case tcSplitSigmaTy (idType id) of
1599 (_, _, rho) -> isUnLiftedType rho
1600 -- For the is_unlifted check, we need to look inside polymorphism
1601 -- and overloading. E.g. x = (# 1, True #)
1602 -- would get type forall a. Num a => (# a, Bool #)
1603 -- and we want to reject that. See Trac #9140
1604
1605 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1606 = null tvs && null evs
1607 is_monomorphic _ = True
1608
1609 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1610 unliftedMustBeBang binds
1611 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1612 2 (vcat (map ppr binds))
1613
1614 polyBindErr :: [LHsBind Name] -> SDoc
1615 polyBindErr binds
1616 = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
1617 2 (vcat [vcat (map ppr binds),
1618 ptext (sLit "Probable fix: use a bang pattern")])
1619
1620 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1621 strictBindErr flavour unlifted_bndrs binds
1622 = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
1623 2 (vcat (map ppr binds))
1624 where
1625 msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types")
1626 | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
1627
1628 {-
1629 Note [Binding scoped type variables]
1630 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1631
1632 ************************************************************************
1633 * *
1634 \subsection[TcBinds-errors]{Error contexts and messages}
1635 * *
1636 ************************************************************************
1637 -}
1638
1639 -- This one is called on LHS, when pat and grhss are both Name
1640 -- and on RHS, when pat is TcId and grhss is still Name
1641 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
1642 patMonoBindsCtxt pat grhss
1643 = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1644
1645 typeSigCtxt :: Name -> TcSigInfo -> SDoc
1646 typeSigCtxt _ (TcPatSynInfo _)
1647 = panic "Should only be called with a TcSigInfo"
1648 typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs
1649 , sig_theta = theta, sig_tau = tau
1650 , sig_extra_cts = extra_cts })
1651 = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name False) <> colon
1652 , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
1653 (mkSigmaTy (map snd tvs) theta tau)) ]