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