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