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