b4bb65d074f421e8bc327c42694478ddd9d772e1
[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) 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 [] -> panic "tc_group: empty list of binds"
366 [bind] -> bind
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, _ids, thing) <- go sccs
379 -- Here is where we should do bindInstsOfLocalFuns
380 -- if we start having Methods again
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 = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
390
391 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
392 go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc
393 ; (binds2, ids2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
394 go sccs
395 ; return (binds1 `unionBags` binds2, ids1 ++ ids2, 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 = tcPolyBinds top_lvl sig_fn prag_fn Recursive
402
403 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
404 recursivePatSynErr binds
405 = failWithTc $
406 hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
407 2 (vcat $ map pprLBind . bagToList $ binds)
408 where
409 pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
410 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
411 pprLoc loc
412
413 tc_single :: forall thing.
414 TopLevelFlag -> TcSigFun -> PragFun
415 -> LHsBind Name -> TcM thing
416 -> TcM (LHsBinds TcId, thing)
417 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
418 = do { (pat_syn, aux_binds) <- tc_pat_syn_decl
419 ; let tything = AConLike (PatSynCon pat_syn)
420 -- SLPJ: Why is this necessary?
421 -- implicit_ids = patSynMatcher pat_syn :
422 -- maybeToList (patSynWorker pat_syn)
423
424 ; thing <- tcExtendGlobalEnv [tything] $
425 -- tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
426 thing_inside
427 ; return (aux_binds, thing)
428 }
429 where
430 tc_pat_syn_decl = case sig_fn name of
431 Nothing -> tcInferPatSynDecl psb
432 Just (TcPatSynInfo tpsi) -> tcCheckPatSynDecl psb tpsi
433 Just _ -> panic "tc_single"
434
435 tc_single top_lvl sig_fn prag_fn lbind thing_inside
436 = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
437 NonRecursive NonRecursive
438 [lbind]
439 ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
440 ; return (binds1, thing) }
441
442 -- | No signature or a partial signature
443 noCompleteSig :: Maybe TcSigInfo -> Bool
444 noCompleteSig Nothing = True
445 noCompleteSig (Just sig) = isPartialSig sig
446
447 ------------------------
448 mkEdges :: TcSigFun -> LHsBinds Name
449 -> [(LHsBind Name, BKey, [BKey])]
450
451 type BKey = Int -- Just number off the bindings
452
453 mkEdges sig_fn binds
454 = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
455 Just key <- [lookupNameEnv key_map n], no_sig n ])
456 | (bind, key) <- keyd_binds
457 ]
458 where
459 no_sig :: Name -> Bool
460 no_sig n = noCompleteSig (sig_fn n)
461
462 keyd_binds = bagToList binds `zip` [0::BKey ..]
463
464 key_map :: NameEnv BKey -- Which binding it comes from
465 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
466 , bndr <- bindersOfHsBind bind ]
467
468 bindersOfHsBind :: HsBind Name -> [Name]
469 bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat
470 bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
471 bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn]
472 bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds"
473 bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind"
474
475 ------------------------
476 tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
477 -> RecFlag -- Whether the group is really recursive
478 -> RecFlag -- Whether it's recursive after breaking
479 -- dependencies based on type signatures
480 -> [LHsBind Name]
481 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
482
483 -- Typechecks a single bunch of bindings all together,
484 -- and generalises them. The bunch may be only part of a recursive
485 -- group, because we use type signatures to maximise polymorphism
486 --
487 -- Returns a list because the input may be a single non-recursive binding,
488 -- in which case the dependency order of the resulting bindings is
489 -- important.
490 --
491 -- Knows nothing about the scope of the bindings
492
493 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
494 = setSrcSpan loc $
495 recoverM (recoveryCode binder_names sig_fn) $ do
496 -- Set up main recover; take advantage of any type sigs
497
498 { traceTc "------------------------------------------------" Outputable.empty
499 ; traceTc "Bindings for {" (ppr binder_names)
500 ; dflags <- getDynFlags
501 ; type_env <- getLclTypeEnv
502 ; let plan = decideGeneralisationPlan dflags type_env
503 binder_names bind_list sig_fn
504 ; traceTc "Generalisation plan" (ppr plan)
505 ; result@(tc_binds, poly_ids, _) <- case plan of
506 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
507 InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list
508 CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
509
510 -- Check whether strict bindings are ok
511 -- These must be non-recursive etc, and are not generalised
512 -- They desugar to a case expression in the end
513 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
514 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
515 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
516 ])
517
518 ; return result }
519 where
520 binder_names = collectHsBindListBinders bind_list
521 loc = foldr1 combineSrcSpans (map getLoc bind_list)
522 -- The mbinds have been dependency analysed and
523 -- may no longer be adjacent; so find the narrowest
524 -- span that includes them all
525
526 ------------------
527 tcPolyNoGen -- No generalisation whatsoever
528 :: RecFlag -- Whether it's recursive after breaking
529 -- dependencies based on type signatures
530 -> PragFun -> TcSigFun
531 -> [LHsBind Name]
532 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
533
534 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
535 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
536 (LetGblBndr prag_fn)
537 bind_list
538 ; mono_ids' <- mapM tc_mono_info mono_infos
539 ; return (binds', mono_ids', NotTopLevel) }
540 where
541 tc_mono_info (name, _, mono_id)
542 = do { mono_ty' <- zonkTcType (idType mono_id)
543 -- Zonk, mainly to expose unboxed types to checkStrictBinds
544 ; let mono_id' = setIdType mono_id mono_ty'
545 ; _specs <- tcSpecPrags mono_id' (prag_fn name)
546 ; return mono_id' }
547 -- NB: tcPrags generates error messages for
548 -- specialisation pragmas for non-overloaded sigs
549 -- Indeed that is why we call it here!
550 -- So we can safely ignore _specs
551
552 ------------------
553 tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
554 -- dependencies based on type signatures
555 -> PragFun -> TcSigInfo
556 -> LHsBind Name
557 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
558 -- There is just one binding,
559 -- it binds a single variable,
560 -- it has a signature,
561 tcPolyCheck rec_tc prag_fn
562 sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
563 , sig_nwcs = sig_nwcs, sig_theta = theta
564 , sig_tau = tau, sig_loc = loc })
565 bind
566 = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards
567 do { ev_vars <- newEvVars theta
568 ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
569 prag_sigs = prag_fn (idName poly_id)
570 tvs = map snd tvs_w_scoped
571 ; (ev_binds, (binds', [mono_info]))
572 <- setSrcSpan loc $
573 checkConstraints skol_info tvs ev_vars $
574 tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind]
575
576 ; spec_prags <- tcSpecPrags poly_id prag_sigs
577 ; poly_id <- addInlinePrags poly_id prag_sigs
578
579 ; let (_, _, mono_id) = mono_info
580 export = ABE { abe_wrap = idHsWrapper
581 , abe_poly = poly_id
582 , abe_mono = mono_id
583 , abe_prags = SpecPrags spec_prags }
584 abs_bind = L loc $ AbsBinds
585 { abs_tvs = tvs
586 , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
587 , abs_exports = [export], abs_binds = binds' }
588 closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
589 | otherwise = NotTopLevel
590 ; return (unitBag abs_bind, [poly_id], closed) }
591
592 tcPolyCheck _rec_tc _prag_fn sig _bind
593 = pprPanic "tcPolyCheck" (ppr sig)
594
595 ------------------
596 tcPolyInfer
597 :: RecFlag -- Whether it's recursive after breaking
598 -- dependencies based on type signatures
599 -> PragFun -> TcSigFun
600 -> Bool -- True <=> apply the monomorphism restriction
601 -> Bool -- True <=> free vars have closed types
602 -> [LHsBind Name]
603 -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
604 tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
605 = do { (((binds', mono_infos), tclvl), wanted)
606 <- captureConstraints $
607 captureTcLevel $
608 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
609
610 ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
611 ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
612 ; (qtvs, givens, mr_bites, ev_binds)
613 <- simplifyInfer tclvl mono name_taus wanted
614
615 ; inferred_theta <- zonkTcThetaType (map evVarPred givens)
616 ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs inferred_theta)
617 mono_infos
618
619 ; loc <- getSrcSpanM
620 ; let poly_ids = map abe_poly exports
621 final_closed | closed && not mr_bites = TopLevel
622 | otherwise = NotTopLevel
623 abs_bind = L loc $
624 AbsBinds { abs_tvs = qtvs
625 , abs_ev_vars = givens, abs_ev_binds = ev_binds
626 , abs_exports = exports, abs_binds = binds' }
627
628 ; traceTc "Binding:" (ppr final_closed $$
629 ppr (poly_ids `zip` map idType poly_ids))
630 ; return (unitBag abs_bind, poly_ids, final_closed) }
631 -- poly_ids are guaranteed zonked by mkExport
632
633 --------------
634 mkExport :: PragFun
635 -> [TyVar] -> TcThetaType -- Both already zonked
636 -> MonoBindInfo
637 -> TcM (ABExport Id)
638 -- Only called for generalisation plan IferGen, not by CheckGen or NoGen
639 --
640 -- mkExport generates exports with
641 -- zonked type variables,
642 -- zonked poly_ids
643 -- The former is just because no further unifications will change
644 -- the quantified type variables, so we can fix their final form
645 -- right now.
646 -- The latter is needed because the poly_ids are used to extend the
647 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
648
649 -- Pre-condition: the qtvs and theta are already zonked
650
651 mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
652 = do { mono_ty <- zonkTcType (idType mono_id)
653
654 ; poly_id <- case mb_sig of
655 Nothing -> mkInferredPolyId poly_name qtvs inferred_theta mono_ty
656 Just (TcPatSynInfo _) -> panic "mkExport"
657 Just sig | isPartialSig sig
658 -> do { final_theta <- completeTheta inferred_theta sig
659 ; mkInferredPolyId poly_name qtvs final_theta mono_ty }
660 | otherwise
661 -> return (sig_id sig)
662
663 -- NB: poly_id has a zonked type
664 ; poly_id <- addInlinePrags poly_id prag_sigs
665 ; spec_prags <- tcSpecPrags poly_id prag_sigs
666 -- tcPrags requires a zonked poly_id
667
668 ; let sel_poly_ty = mkSigmaTy qtvs inferred_theta mono_ty
669 ; traceTc "mkExport: check sig"
670 (vcat [ ppr poly_name, ppr sel_poly_ty, ppr (idType poly_id) ])
671
672 -- Perform the impedence-matching and ambiguity check
673 -- right away. If it fails, we want to fail now (and recover
674 -- in tcPolyBinds). If we delay checking, we get an error cascade.
675 -- Remember we are in the tcPolyInfer case, so the type envt is
676 -- closed (unless we are doing NoMonoLocalBinds in which case all bets
677 -- are off)
678 -- See Note [Impedence matching]
679 ; (wrap, wanted) <- addErrCtxtM (mk_bind_msg inferred True poly_name (idType poly_id)) $
680 captureConstraints $
681 tcSubType_NC sig_ctxt sel_poly_ty (idType poly_id)
682 ; ev_binds <- simplifyTop wanted
683
684 ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
685 , abe_poly = poly_id
686 , abe_mono = mono_id
687 , abe_prags = SpecPrags spec_prags }) }
688 where
689 inferred = isNothing mb_sig
690 prag_sigs = prag_fn poly_name
691 sig_ctxt = InfSigCtxt poly_name
692
693 mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id
694 -- In the inference case (no signature) this stuff figures out
695 -- the right type variables and theta to quantify over
696 -- See Note [Validity of inferred types]
697 mkInferredPolyId poly_name qtvs theta mono_ty
698 = do { fam_envs <- tcGetFamInstEnvs
699
700 ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty
701 -- Unification may not have normalised the type,
702 -- (see Note [Lazy flattening] in TcFlatten) so do it
703 -- here to make it as uncomplicated as possible.
704 -- Example: f :: [F Int] -> Bool
705 -- should be rewritten to f :: [Char] -> Bool, if possible
706
707 my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty))
708 -- Include kind variables! Trac #7916
709
710 my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order
711 my_theta = filter (quantifyPred my_tvs2) theta
712 inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty
713
714 ; addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $
715 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
716
717 ; return (mkLocalId poly_name inferred_poly_ty) }
718
719 mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
720 mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env
721 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env poly_ty
722 ; return (tidy_env', mk_msg tidy_ty) }
723 where
724 mk_msg ty = vcat [ ptext (sLit "When checking that") <+> quotes (ppr poly_name)
725 <+> ptext (sLit "has the") <+> what <+> ptext (sLit "type")
726 , nest 2 (ppr poly_name <+> dcolon <+> ppr ty)
727 , ppWhen want_ambig $
728 ptext (sLit "Probable cause: the inferred type is ambiguous") ]
729 what | inferred = ptext (sLit "inferred")
730 | otherwise = ptext (sLit "specified")
731
732
733 -- | Report the inferred constraints for an extra-constraints wildcard/hole as
734 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
735 -- case, the extra inferred constraints are accepted without complaining.
736 -- Returns the annotated constraints combined with the inferred constraints.
737 completeTheta :: TcThetaType -> TcSigInfo -> TcM TcThetaType
738 completeTheta _ (TcPatSynInfo _)
739 = panic "Extra-constraints wildcard not supported in a pattern signature"
740 completeTheta inferred_theta
741 sig@(TcSigInfo { sig_id = poly_id
742 , sig_extra_cts = mb_extra_cts
743 , sig_theta = annotated_theta })
744 | Just loc <- mb_extra_cts
745 = do { annotated_theta <- zonkTcThetaType annotated_theta
746 ; let inferred_diff = minusList inferred_theta annotated_theta
747 final_theta = annotated_theta ++ inferred_diff
748 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
749 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
750 ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
751 ; case partial_sigs of
752 True | warn_partial_sigs -> reportWarning $ makeIntoWarning msg
753 | otherwise -> return ()
754 False -> reportError msg
755 ; return final_theta }
756
757 | otherwise
758 = zonkTcThetaType annotated_theta
759 -- No extra-constraints wildcard means no extra constraints will be added
760 -- to the context, so just return the possibly empty (zonked)
761 -- annotated_theta.
762 where
763 pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
764 mk_msg inferred_diff suppress_hint
765 = vcat [ hang ((text "Found hole") <+> quotes (char '_'))
766 2 (text "with inferred constraints:")
767 <+> pprTheta inferred_diff
768 , if suppress_hint then empty else pts_hint
769 , typeSigCtxt (idName poly_id) sig ]
770
771 {-
772 Note [Partial type signatures and generalisation]
773 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
774 When we have a partial type signature, like
775 f :: _ -> Int
776 then we *always* use the InferGen plan, and hence tcPolyInfer.
777 We do this even for a local binding with -XMonoLocalBinds.
778 Reasons:
779 * The TcSigInfo for 'f' has a unification variable for the '_',
780 whose TcLevel is one level deeper than the current level.
781 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
782 the TcLevel like InferGen, so we lose the level invariant.
783
784 * The signature might be f :: forall a. _ -> a
785 so it really is polymorphic. It's not clear what it would
786 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
787 in the (Just sig) case, checks that if there is a signature
788 then we are using LetLclBndr, and hence a nested AbsBinds with
789 increased TcLevel
790
791 It might be possible to fix these difficulties somehow, but there
792 doesn't seem much point. Indeed, adding a partial type signature is a
793 way to get per-binding inferred generalisation.
794
795 Note [Validity of inferred types]
796 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
797 We need to check inferred type for validity, in case it uses language
798 extensions that are not turned on. The principle is that if the user
799 simply adds the inferred type to the program source, it'll compile fine.
800 See #8883.
801
802 Examples that might fail:
803 - an inferred theta that requires type equalities e.g. (F a ~ G b)
804 or multi-parameter type classes
805 - an inferred type that includes unboxed tuples
806
807 However we don't do the ambiguity check (checkValidType omits it for
808 InfSigCtxt) because the impedence-matching stage, which follows
809 immediately, will do it and we don't want two error messages.
810 Moreover, because of the impedence matching stage, the ambiguity-check
811 suggestion of -XAllowAmbiguiousTypes will not work.
812
813
814 Note [Impedence matching]
815 ~~~~~~~~~~~~~~~~~~~~~~~~~
816 Consider
817 f 0 x = x
818 f n x = g [] (not x)
819
820 g [] y = f 10 y
821 g _ y = f 9 y
822
823 After typechecking we'll get
824 f_mono_ty :: a -> Bool -> Bool
825 g_mono_ty :: [b] -> Bool -> Bool
826 with constraints
827 (Eq a, Num a)
828
829 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
830 The types we really want for f and g are
831 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
832 g :: forall b. [b] -> Bool -> Bool
833
834 We can get these by "impedence matching":
835 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
836 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
837
838 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
839 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
840
841 Suppose the shared quantified tyvars are qtvs and constraints theta.
842 Then we want to check that
843 f's polytype is more polymorphic than forall qtvs. theta => f_mono_ty
844 and the proof is the impedence matcher.
845
846 Notice that the impedence matcher may do defaulting. See Trac #7173.
847
848 It also cleverly does an ambiguity check; for example, rejecting
849 f :: F a -> a
850 where F is a non-injective type function.
851 -}
852
853 type PragFun = Name -> [LSig Name]
854
855 mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
856 mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
857 where
858 prs = mapMaybe get_sig sigs
859
860 get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
861 get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl))
862 get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl))
863 get_sig _ = Nothing
864
865 add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function
866 | Just ar <- lookupNameEnv ar_env n,
867 Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar }
868 -- add arity only for real INLINE pragmas, not INLINABLE
869 | otherwise = inl_prag
870
871 prag_env :: NameEnv [LSig Name]
872 prag_env = foldl add emptyNameEnv prs
873 add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
874
875 -- ar_env maps a local to the arity of its definition
876 ar_env :: NameEnv Arity
877 ar_env = foldrBag lhsBindArity emptyNameEnv binds
878
879 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
880 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
881 = extendNameEnv env (unLoc id) (matchGroupArity ms)
882 lhsBindArity _ env = env -- PatBind/VarBind
883
884 ------------------
885 tcSpecPrags :: Id -> [LSig Name]
886 -> TcM [LTcSpecPrag]
887 -- Add INLINE and SPECIALSE pragmas
888 -- INLINE prags are added to the (polymorphic) Id directly
889 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
890 -- Pre-condition: the poly_id is zonked
891 -- Reason: required by tcSubExp
892 tcSpecPrags poly_id prag_sigs
893 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
894 ; unless (null bad_sigs) warn_discarded_sigs
895 ; pss <- mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs
896 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
897 where
898 spec_sigs = filter isSpecLSig prag_sigs
899 bad_sigs = filter is_bad_sig prag_sigs
900 is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
901
902 warn_discarded_sigs = warnPrags poly_id bad_sigs $
903 ptext (sLit "Discarding unexpected pragmas for")
904
905
906 --------------
907 tcSpec :: TcId -> Sig Name -> TcM [TcSpecPrag]
908 tcSpec poly_id prag@(SpecSig fun_name hs_tys inl)
909 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
910 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
911 -- for the selector Id, but the poly_id is something like $cop
912 -- However we want to use fun_name in the error message, since that is
913 -- what the user wrote (Trac #8537)
914 = addErrCtxt (spec_ctxt prag) $
915 do { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys
916 ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
917 (ptext (sLit "SPECIALISE pragma for non-overloaded function")
918 <+> quotes (ppr fun_name))
919 -- Note [SPECIALISE pragmas]
920 ; wraps <- mapM (tcSubType sig_ctxt (idType poly_id)) spec_tys
921 ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] }
922 where
923 name = idName poly_id
924 poly_ty = idType poly_id
925 sig_ctxt = FunSigCtxt name
926 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
927
928 tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
929
930 --------------
931 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
932 -- SPECIALISE pragmas for imported things
933 tcImpPrags prags
934 = do { this_mod <- getModule
935 ; dflags <- getDynFlags
936 ; if (not_specialising dflags) then
937 return []
938 else do
939 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
940 [L loc (name,prag)
941 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
942 , not (nameIsLocalOrFrom this_mod name) ]
943 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
944 where
945 -- Ignore SPECIALISE pragmas for imported things
946 -- when we aren't specialising, or when we aren't generating
947 -- code. The latter happens when Haddocking the base library;
948 -- we don't wnat complaints about lack of INLINABLE pragmas
949 not_specialising dflags
950 | not (gopt Opt_Specialise dflags) = True
951 | otherwise = case hscTarget dflags of
952 HscNothing -> True
953 HscInterpreted -> True
954 _other -> False
955
956 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
957 tcImpSpec (name, prag)
958 = do { id <- tcLookupId name
959 ; unless (isAnyInlinePragma (idInlinePragma id))
960 (addWarnTc (impSpecErr name))
961 ; tcSpec id prag }
962
963 impSpecErr :: Name -> SDoc
964 impSpecErr name
965 = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
966 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
967 , parens $ sep
968 [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
969 , ptext (sLit "was compiled without -O")]])
970 where
971 mod = nameModule name
972
973 --------------
974 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
975 tcVectDecls decls
976 = do { decls' <- mapM (wrapLocM tcVect) decls
977 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
978 dups = findDupsEq (==) ids
979 ; mapM_ reportVectDups dups
980 ; traceTcConstraints "End of tcVectDecls"
981 ; return decls'
982 }
983 where
984 reportVectDups (first:_second:_more)
985 = addErrAt (getSrcSpan first) $
986 ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
987 reportVectDups _ = return ()
988
989 --------------
990 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
991 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
992 -- type of the original definition as this requires internals of the vectoriser not available
993 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
994 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
995 -- from the vectoriser here.
996 tcVect (HsVect name rhs)
997 = addErrCtxt (vectCtxt name) $
998 do { var <- wrapLocM tcLookupId name
999 ; let L rhs_loc (HsVar rhs_var_name) = rhs
1000 ; rhs_id <- tcLookupId rhs_var_name
1001 ; return $ HsVect var (L rhs_loc (HsVar rhs_id))
1002 }
1003
1004 {- OLD CODE:
1005 -- turn the vectorisation declaration into a single non-recursive binding
1006 ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
1007 sigFun = const Nothing
1008 pragFun = mkPragFun [] (unitBag bind)
1009
1010 -- perform type inference (including generalisation)
1011 ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
1012
1013 ; traceTc "tcVect inferred type" $ ppr (varType id')
1014 ; traceTc "tcVect bindings" $ ppr binds
1015
1016 -- add all bindings, including the type variable and dictionary bindings produced by type
1017 -- generalisation to the right-hand side of the vectorisation declaration
1018 ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
1019 ; let [bind'] = bagToList actualBinds
1020 MatchGroup
1021 [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
1022 _ = (fun_matches . unLoc) bind'
1023 rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
1024
1025 -- We return the type-checked 'Id', to propagate the inferred signature
1026 -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
1027 ; return $ HsVect (L loc id') (Just rhsWrapped)
1028 }
1029 -}
1030 tcVect (HsNoVect name)
1031 = addErrCtxt (vectCtxt name) $
1032 do { var <- wrapLocM tcLookupId name
1033 ; return $ HsNoVect var
1034 }
1035 tcVect (HsVectTypeIn isScalar lname rhs_name)
1036 = addErrCtxt (vectCtxt lname) $
1037 do { tycon <- tcLookupLocatedTyCon lname
1038 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1039 || isJust rhs_name -- or we explicitly provide a vectorised type
1040 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1041 )
1042 scalarTyConMustBeNullary
1043
1044 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1045 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1046 }
1047 tcVect (HsVectTypeOut _ _ _)
1048 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1049 tcVect (HsVectClassIn lname)
1050 = addErrCtxt (vectCtxt lname) $
1051 do { cls <- tcLookupLocatedClass lname
1052 ; return $ HsVectClassOut cls
1053 }
1054 tcVect (HsVectClassOut _)
1055 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1056 tcVect (HsVectInstIn linstTy)
1057 = addErrCtxt (vectCtxt linstTy) $
1058 do { (cls, tys) <- tcHsVectInst linstTy
1059 ; inst <- tcLookupInstance cls tys
1060 ; return $ HsVectInstOut inst
1061 }
1062 tcVect (HsVectInstOut _)
1063 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1064
1065 vectCtxt :: Outputable thing => thing -> SDoc
1066 vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
1067
1068 scalarTyConMustBeNullary :: MsgDoc
1069 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
1070
1071 --------------
1072 -- If typechecking the binds fails, then return with each
1073 -- signature-less binder given type (forall a.a), to minimise
1074 -- subsequent error messages
1075 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
1076 recoveryCode binder_names sig_fn
1077 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
1078 ; poly_ids <- mapM mk_dummy binder_names
1079 ; return (emptyBag, poly_ids, if all is_closed poly_ids
1080 then TopLevel else NotTopLevel) }
1081 where
1082 mk_dummy name
1083 | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up
1084 | otherwise = return (mkLocalId name forall_a_a) -- No signature
1085
1086 is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))
1087
1088 forall_a_a :: TcType
1089 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
1090
1091 {-
1092 Note [SPECIALISE pragmas]
1093 ~~~~~~~~~~~~~~~~~~~~~~~~~
1094 There is no point in a SPECIALISE pragma for a non-overloaded function:
1095 reverse :: [a] -> [a]
1096 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1097
1098 But SPECIALISE INLINE *can* make sense for GADTS:
1099 data Arr e where
1100 ArrInt :: !Int -> ByteArray# -> Arr Int
1101 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1102
1103 (!:) :: Arr e -> Int -> e
1104 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1105 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1106 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1107 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1108
1109 When (!:) is specialised it becomes non-recursive, and can usefully
1110 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1111 for a non-overloaded function.
1112
1113 ************************************************************************
1114 * *
1115 \subsection{tcMonoBind}
1116 * *
1117 ************************************************************************
1118
1119 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1120 The signatures have been dealt with already.
1121
1122 Note [Pattern bindings]
1123 ~~~~~~~~~~~~~~~~~~~~~~~
1124 The rule for typing pattern bindings is this:
1125
1126 ..sigs..
1127 p = e
1128
1129 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1130 typechecks exactly like
1131
1132 ..sigs..
1133 x = e -- Inferred type
1134 v1 = case x of p -> v1
1135 ..
1136 vn = case x of p -> vn
1137
1138 Note that
1139 (f :: forall a. a -> a) = id
1140 should not typecheck because
1141 case id of { (f :: forall a. a->a) -> f }
1142 will not typecheck.
1143 -}
1144
1145 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1146 -- i.e. the binders are mentioned in their RHSs, and
1147 -- we are not rescued by a type signature
1148 -> TcSigFun -> LetBndrSpec
1149 -> [LHsBind Name]
1150 -> TcM (LHsBinds TcId, [MonoBindInfo])
1151
1152 tcMonoBinds is_rec sig_fn no_gen
1153 [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
1154 fun_matches = matches, bind_fvs = fvs })]
1155 -- Single function binding,
1156 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1157 , Nothing <- sig_fn name -- ...with no type signature
1158 = -- In this very special case we infer the type of the
1159 -- right hand side first (it may have a higher-rank type)
1160 -- and *then* make the monomorphic Id for the LHS
1161 -- e.g. f = \(x::forall a. a->a) -> <body>
1162 -- We want to infer a higher-rank type for f
1163 setSrcSpan b_loc $
1164 do { rhs_ty <- newFlexiTyVarTy openTypeKind
1165 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1166 ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1167 -- We extend the error context even for a non-recursive
1168 -- function so that in type error messages we show the
1169 -- type of the thing whose rhs we are type checking
1170 tcMatchesFun name inf matches rhs_ty
1171
1172 ; return (unitBag $ L b_loc $
1173 FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
1174 fun_matches = matches', bind_fvs = fvs,
1175 fun_co_fn = co_fn, fun_tick = [] },
1176 [(name, Nothing, mono_id)]) }
1177
1178 tcMonoBinds _ sig_fn no_gen binds
1179 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1180
1181 -- Bring the monomorphic Ids, into scope for the RHSs
1182 ; let mono_info = getMonoBindInfo tc_binds
1183 rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
1184 , noCompleteSig mb_sig ]
1185 -- A monomorphic binding for each term variable that lacks
1186 -- a type sig. (Ones with a sig are already in scope.)
1187
1188 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1189 | (n,id) <- rhs_id_env]
1190 ; binds' <- tcExtendIdEnv2 rhs_id_env $
1191 mapM (wrapLocM tcRhs) tc_binds
1192 ; return (listToBag binds', mono_info) }
1193
1194 ------------------------
1195 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1196 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1197 -- if there's a signature for it, use the instantiated signature type
1198 -- otherwise invent a type variable
1199 -- You see that quite directly in the FunBind case.
1200 --
1201 -- But there's a complication for pattern bindings:
1202 -- data T = MkT (forall a. a->a)
1203 -- MkT f = e
1204 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1205 -- but we want to get (f::forall a. a->a) as the RHS environment.
1206 -- The simplest way to do this is to typecheck the pattern, and then look up the
1207 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1208 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1209
1210 data TcMonoBind -- Half completed; LHS done, RHS not done
1211 = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name))
1212 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1213
1214 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
1215 -- Type signature (if any), and
1216 -- the monomorphic bound things
1217
1218 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1219 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
1220 | Just sig <- sig_fn name
1221 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1222 , ppr name )
1223 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1224 -- or InferGen (partial signature)
1225 -- see Note [Partial type signatures and generalisation]
1226 -- Both InferGen and CheckGen gives rise to LetLclBndr
1227 do { mono_name <- newLocalName name
1228 ; let mono_id = mkLocalId mono_name (sig_tau sig)
1229 ; addErrCtxt (typeSigCtxt name sig) $
1230 emitWildcardHoleConstraints (sig_nwcs sig)
1231 ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
1232
1233 | otherwise
1234 = do { mono_ty <- newFlexiTyVarTy openTypeKind
1235 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1236 ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
1237
1238 -- TODOT: emit Hole Constraints for wildcards
1239 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1240 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1241 mapM lookup_info (collectPatBinders pat)
1242
1243 -- After typechecking the pattern, look up the binder
1244 -- names, which the pattern has brought into scope.
1245 lookup_info :: Name -> TcM MonoBindInfo
1246 lookup_info name = do { mono_id <- tcLookupId name
1247 ; return (name, sig_fn name, mono_id) }
1248
1249 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1250 tcInfer tc_pat
1251
1252 ; return (TcPatBind infos pat' grhss pat_ty) }
1253
1254 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1255 -- AbsBind, VarBind impossible
1256
1257 -------------------
1258 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1259 -- When we are doing pattern bindings, or multiple function bindings at a time
1260 -- we *don't* bring any scoped type variables into scope
1261 -- Wny not? They are not completely rigid.
1262 -- That's why we have the special case for a single FunBind in tcMonoBinds
1263 tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches)
1264 = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1265 tcExtendTyVarEnv2 tvsAndNwcs $
1266 -- NotTopLevel: it's a monomorphic binding
1267 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1268 ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
1269 matches (idType mono_id)
1270 ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
1271 , fun_matches = matches'
1272 , fun_co_fn = co_fn
1273 , bind_fvs = placeHolderNamesTc
1274 , fun_tick = [] }) }
1275 where
1276 tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig]
1277 ++ sig_nwcs sig) mb_sig
1278
1279 tcRhs (TcPatBind infos pat' grhss pat_ty)
1280 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $
1281 -- NotTopLevel: it's a monomorphic binding
1282 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1283 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1284 tcGRHSsPat grhss pat_ty
1285 ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
1286 , bind_fvs = placeHolderNamesTc
1287 , pat_ticks = ([],[]) }) }
1288
1289
1290 ---------------------
1291 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1292 getMonoBindInfo tc_binds
1293 = foldr (get_info . unLoc) [] tc_binds
1294 where
1295 get_info (TcFunBind info _ _ _) rest = info : rest
1296 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1297
1298 {-
1299 ************************************************************************
1300 * *
1301 Signatures
1302 * *
1303 ************************************************************************
1304
1305 Type signatures are tricky. See Note [Signature skolems] in TcType
1306
1307 @tcSigs@ checks the signatures for validity, and returns a list of
1308 {\em freshly-instantiated} signatures. That is, the types are already
1309 split up, and have fresh type variables installed. All non-type-signature
1310 "RenamedSigs" are ignored.
1311
1312 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1313 the variable's type, and after that checked to see whether they've
1314 been instantiated.
1315
1316 Note [Scoped tyvars]
1317 ~~~~~~~~~~~~~~~~~~~~
1318 The -XScopedTypeVariables flag brings lexically-scoped type variables
1319 into scope for any explicitly forall-quantified type variables:
1320 f :: forall a. a -> a
1321 f x = e
1322 Then 'a' is in scope inside 'e'.
1323
1324 However, we do *not* support this
1325 - For pattern bindings e.g
1326 f :: forall a. a->a
1327 (f,g) = e
1328
1329 Note [Signature skolems]
1330 ~~~~~~~~~~~~~~~~~~~~~~~~
1331 When instantiating a type signature, we do so with either skolems or
1332 SigTv meta-type variables depending on the use_skols boolean. This
1333 variable is set True when we are typechecking a single function
1334 binding; and False for pattern bindings and a group of several
1335 function bindings.
1336
1337 Reason: in the latter cases, the "skolems" can be unified together,
1338 so they aren't properly rigid in the type-refinement sense.
1339 NB: unless we are doing H98, each function with a sig will be done
1340 separately, even if it's mutually recursive, so use_skols will be True
1341
1342
1343 Note [Only scoped tyvars are in the TyVarEnv]
1344 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1345 We are careful to keep only the *lexically scoped* type variables in
1346 the type environment. Why? After all, the renamer has ensured
1347 that only legal occurrences occur, so we could put all type variables
1348 into the type env.
1349
1350 But we want to check that two distinct lexically scoped type variables
1351 do not map to the same internal type variable. So we need to know which
1352 the lexically-scoped ones are... and at the moment we do that by putting
1353 only the lexically scoped ones into the environment.
1354
1355 Note [Instantiate sig with fresh variables]
1356 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1357 It's vital to instantiate a type signature with fresh variables.
1358 For example:
1359 type T = forall a. [a] -> [a]
1360 f :: T;
1361 f = g where { g :: T; g = <rhs> }
1362
1363 We must not use the same 'a' from the defn of T at both places!!
1364 (Instantiation is only necessary because of type synonyms. Otherwise,
1365 it's all cool; each signature has distinct type variables from the renamer.)
1366
1367 Note [Fail eagerly on bad signatures]
1368 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1369 If a type signaure is wrong, fail immediately:
1370
1371 * the type sigs may bind type variables, so proceeding without them
1372 can lead to a cascade of errors
1373
1374 * the type signature might be ambiguous, in which case checking
1375 the code against the signature will give a very similar error
1376 to the ambiguity error.
1377
1378 ToDo: this means we fall over if any type sig
1379 is wrong (eg at the top level of the module),
1380 which is over-conservative
1381 -}
1382
1383 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar])
1384 tcTySigs hs_sigs
1385 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1386 do { (ty_sigs_s, tyvarsl) <- unzip <$> mapAndRecoverM tcTySig hs_sigs
1387 ; let ty_sigs = concat ty_sigs_s
1388 poly_ids = [id | TcSigInfo{ sig_id = id } <- ty_sigs]
1389 env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs]
1390 ; return (poly_ids, lookupNameEnv env, concat tyvarsl) }
1391
1392 tcTySig :: LSig Name -> TcM ([TcSigInfo], [TcTyVar])
1393 tcTySig (L _ (IdSig id))
1394 = do { sig <- instTcTySigFromId id
1395 ; return ([sig], []) }
1396 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
1397 = setSrcSpan loc $
1398 pushTcLevelM $
1399 do { nwc_tvs <- mapM newWildcardVarMetaKind wcs -- Generate fresh meta vars for the wildcards
1400 ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1) hs_ty
1401 ; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
1402 (map unLoc names)
1403 ; return (sigs, nwc_tvs) }
1404 where
1405 extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra
1406 extra_cts _ = Nothing
1407
1408 tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
1409 = setSrcSpan loc $
1410 do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
1411 ; let ctxt = FunSigCtxt name
1412 ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
1413 { ty' <- tcHsSigType ctxt ty
1414 ; req' <- tcHsContext req
1415 ; prov' <- tcHsContext prov
1416
1417 ; qtvs' <- mapM zonkQuantifiedTyVar qtvs'
1418
1419 ; let (_, pat_ty) = tcSplitFunTys ty'
1420 univ_set = tyVarsOfType pat_ty
1421 (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
1422
1423 ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
1424 ; let tpsi = TPSI{ patsig_name = name,
1425 patsig_tau = ty',
1426 patsig_ex = ex_tvs,
1427 patsig_univ = univ_tvs,
1428 patsig_prov = prov',
1429 patsig_req = req' }
1430 ; return ([TcPatSynInfo tpsi], []) }}
1431 tcTySig _ = return ([], [])
1432
1433 instTcTySigFromId :: Id -> TcM TcSigInfo
1434 instTcTySigFromId id
1435 = do { let loc = getSrcSpan id
1436 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1437 (idType id)
1438 ; return (TcSigInfo { sig_id = id, sig_loc = loc
1439 , sig_tvs = [(Nothing, tv) | tv <- tvs]
1440 , sig_nwcs = []
1441 , sig_theta = theta, sig_tau = tau
1442 , sig_extra_cts = Nothing
1443 , sig_partial = False }) }
1444
1445 instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType
1446 -> Maybe SrcSpan -- Just loc <=> an extra-constraints
1447 -- wildcard is present at location loc.
1448 -> [(Name, TcTyVar)] -> Name -> TcM TcSigInfo
1449 instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
1450 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1451 ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty
1452 , sig_loc = loc
1453 , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs
1454 , sig_nwcs = nwcs
1455 , sig_theta = theta, sig_tau = tau
1456 , sig_extra_cts = extra_cts
1457 , sig_partial = isJust extra_cts || not (null nwcs) }) }
1458
1459 -------------------------------
1460 data GeneralisationPlan
1461 = NoGen -- No generalisation, no AbsBinds
1462
1463 | InferGen -- Implicit generalisation; there is an AbsBinds
1464 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1465 Bool -- True <=> bindings mention only variables with closed types
1466 -- See Note [Bindings with closed types] in TcRnTypes
1467
1468 | CheckGen (LHsBind Name) TcSigInfo
1469 -- One binding with a signature
1470 -- Explicit generalisation; there is an AbsBinds
1471
1472 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1473 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1474
1475 instance Outputable GeneralisationPlan where
1476 ppr NoGen = ptext (sLit "NoGen")
1477 ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
1478 ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
1479
1480 decideGeneralisationPlan
1481 :: DynFlags -> TcTypeEnv -> [Name]
1482 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1483 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1484 | strict_pat_binds = NoGen
1485 | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig
1486 -- See Note [Partial type signatures and generalisation]
1487 then infer_plan
1488 else CheckGen lbind sig
1489 | mono_local_binds = NoGen
1490 | otherwise = infer_plan
1491 where
1492 infer_plan = InferGen mono_restriction closed_flag
1493 bndr_set = mkNameSet bndr_names
1494 binds = map unLoc lbinds
1495
1496 strict_pat_binds = any isStrictHsBind binds
1497 -- Strict patterns (top level bang or unboxed tuple) must not
1498 -- be polymorphic, because we are going to force them
1499 -- See Trac #4498, #8762
1500
1501 mono_restriction = xopt Opt_MonomorphismRestriction dflags
1502 && any restricted binds
1503
1504 is_closed_ns :: NameSet -> Bool -> Bool
1505 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1506 -- ns are the Names referred to from the RHS of this bind
1507
1508 is_closed_id :: Name -> Bool
1509 -- See Note [Bindings with closed types] in TcRnTypes
1510 is_closed_id name
1511 | name `elemNameSet` bndr_set
1512 = True -- Ignore binders in this groups, of course
1513 | Just thing <- lookupNameEnv type_env name
1514 = case thing of
1515 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1516 ATyVar {} -> False -- In-scope type variables
1517 AGlobal {} -> True -- are not closed!
1518 _ -> pprPanic "is_closed_id" (ppr name)
1519 | otherwise
1520 = WARN( isInternalName name, ppr name ) True
1521 -- The free-var set for a top level binding mentions
1522 -- imported things too, so that we can report unused imports
1523 -- These won't be in the local type env.
1524 -- Ditto class method etc from the current module
1525
1526 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1527
1528 mono_local_binds = xopt Opt_MonoLocalBinds dflags
1529 && not closed_flag
1530
1531 no_sig n = noCompleteSig (sig_fn n)
1532
1533 -- With OutsideIn, all nested bindings are monomorphic
1534 -- except a single function binding with a signature
1535 one_funbind_with_sig
1536 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1537 , Just sig <- sig_fn (unLoc v)
1538 = Just (lbind, sig)
1539 | otherwise
1540 = Nothing
1541
1542 -- The Haskell 98 monomorphism resetriction
1543 restricted (PatBind {}) = True
1544 restricted (VarBind { var_id = v }) = no_sig v
1545 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1546 && no_sig (unLoc v)
1547 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1548 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1549
1550 restricted_match (MG { mg_alts = L _ (Match [] _ _) : _ }) = True
1551 restricted_match _ = False
1552 -- No args => like a pattern binding
1553 -- Some args => a function binding
1554
1555 -------------------
1556 checkStrictBinds :: TopLevelFlag -> RecFlag
1557 -> [LHsBind Name]
1558 -> LHsBinds TcId -> [Id]
1559 -> TcM ()
1560 -- Check that non-overloaded unlifted bindings are
1561 -- a) non-recursive,
1562 -- b) not top level,
1563 -- c) not a multiple-binding group (more or less implied by (a))
1564
1565 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1566 | unlifted_bndrs || any_strict_pat -- This binding group must be matched strictly
1567 = do { checkTc (isNotTopLevel top_lvl)
1568 (strictBindErr "Top-level" unlifted_bndrs orig_binds)
1569 ; checkTc (isNonRec rec_group)
1570 (strictBindErr "Recursive" unlifted_bndrs orig_binds)
1571
1572 ; checkTc (all is_monomorphic (bagToList tc_binds))
1573 (polyBindErr orig_binds)
1574 -- data Ptr a = Ptr Addr#
1575 -- f x = let p@(Ptr y) = ... in ...
1576 -- Here the binding for 'p' is polymorphic, but does
1577 -- not mix with an unlifted binding for 'y'. You should
1578 -- use a bang pattern. Trac #6078.
1579
1580 ; checkTc (isSingleton orig_binds)
1581 (strictBindErr "Multiple" unlifted_bndrs orig_binds)
1582
1583 -- Complain about a binding that looks lazy
1584 -- e.g. let I# y = x in ...
1585 -- Remember, in checkStrictBinds we are going to do strict
1586 -- matching, so (for software engineering reasons) we insist
1587 -- that the strictness is manifest on each binding
1588 -- However, lone (unboxed) variables are ok
1589 ; checkTc (not any_pat_looks_lazy)
1590 (unliftedMustBeBang orig_binds) }
1591 | otherwise
1592 = traceTc "csb2" (ppr poly_ids) >>
1593 return ()
1594 where
1595 unlifted_bndrs = any is_unlifted poly_ids
1596 any_strict_pat = any (isStrictHsBind . unLoc) orig_binds
1597 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1598
1599 is_unlifted id = case tcSplitSigmaTy (idType id) of
1600 (_, _, rho) -> isUnLiftedType rho
1601 -- For the is_unlifted check, we need to look inside polymorphism
1602 -- and overloading. E.g. x = (# 1, True #)
1603 -- would get type forall a. Num a => (# a, Bool #)
1604 -- and we want to reject that. See Trac #9140
1605
1606 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1607 = null tvs && null evs
1608 is_monomorphic _ = True
1609
1610 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1611 unliftedMustBeBang binds
1612 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1613 2 (vcat (map ppr binds))
1614
1615 polyBindErr :: [LHsBind Name] -> SDoc
1616 polyBindErr binds
1617 = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
1618 2 (vcat [vcat (map ppr binds),
1619 ptext (sLit "Probable fix: use a bang pattern")])
1620
1621 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1622 strictBindErr flavour unlifted_bndrs binds
1623 = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
1624 2 (vcat (map ppr binds))
1625 where
1626 msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types")
1627 | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
1628
1629 {-
1630 Note [Binding scoped type variables]
1631 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1632
1633 ************************************************************************
1634 * *
1635 \subsection[TcBinds-errors]{Error contexts and messages}
1636 * *
1637 ************************************************************************
1638 -}
1639
1640 -- This one is called on LHS, when pat and grhss are both Name
1641 -- and on RHS, when pat is TcId and grhss is still Name
1642 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
1643 patMonoBindsCtxt pat grhss
1644 = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1645
1646 typeSigCtxt :: Name -> TcSigInfo -> SDoc
1647 typeSigCtxt _ (TcPatSynInfo _)
1648 = panic "Should only be called with a TcSigInfo"
1649 typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs
1650 , sig_theta = theta, sig_tau = tau
1651 , sig_extra_cts = extra_cts })
1652 = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon
1653 , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
1654 (mkSigmaTy (map snd tvs) theta tau)) ]