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