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