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