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