Better treatment of signatures in cls/inst
[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 Type( pprSigmaTypeExtraCts )
38 import TyCon
39 import TcType
40 import TysPrim
41 import Id
42 import Var
43 import VarSet
44 import VarEnv( TidyEnv )
45 import Module
46 import Name
47 import NameSet
48 import NameEnv
49 import SrcLoc
50 import Bag
51 import ListSetOps
52 import ErrUtils
53 import Digraph
54 import Maybes
55 import Util
56 import BasicTypes
57 import Outputable
58 import FastString
59 import Type(mkStrLitTy)
60 import PrelNames( ipClassName, gHC_PRIM )
61 import TcValidity (checkValidType)
62
63 import Control.Monad
64 import Data.List (partition)
65
66 #include "HsVersions.h"
67
68 {-
69 ************************************************************************
70 * *
71 \subsection{Type-checking bindings}
72 * *
73 ************************************************************************
74
75 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
76 it needs to know something about the {\em usage} of the things bound,
77 so that it can create specialisations of them. So @tcBindsAndThen@
78 takes a function which, given an extended environment, E, typechecks
79 the scope of the bindings returning a typechecked thing and (most
80 important) an LIE. It is this LIE which is then used as the basis for
81 specialising the things bound.
82
83 @tcBindsAndThen@ also takes a "combiner" which glues together the
84 bindings and the "thing" to make a new "thing".
85
86 The real work is done by @tcBindWithSigsAndThen@.
87
88 Recursive and non-recursive binds are handled in essentially the same
89 way: because of uniques there are no scoping issues left. The only
90 difference is that non-recursive bindings can bind primitive values.
91
92 Even for non-recursive binding groups we add typings for each binder
93 to the LVE for the following reason. When each individual binding is
94 checked the type of its LHS is unified with that of its RHS; and
95 type-checking the LHS of course requires that the binder is in scope.
96
97 At the top-level the LIE is sure to contain nothing but constant
98 dictionaries, which we resolve at the module level.
99
100 Note [Polymorphic recursion]
101 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
102 The game plan for polymorphic recursion in the code above is
103
104 * Bind any variable for which we have a type signature
105 to an Id with a polymorphic type. Then when type-checking
106 the RHSs we'll make a full polymorphic call.
107
108 This fine, but if you aren't a bit careful you end up with a horrendous
109 amount of partial application and (worse) a huge space leak. For example:
110
111 f :: Eq a => [a] -> [a]
112 f xs = ...f...
113
114 If we don't take care, after typechecking we get
115
116 f = /\a -> \d::Eq a -> let f' = f a d
117 in
118 \ys:[a] -> ...f'...
119
120 Notice the the stupid construction of (f a d), which is of course
121 identical to the function we're executing. In this case, the
122 polymorphic recursion isn't being used (but that's a very common case).
123 This can lead to a massive space leak, from the following top-level defn
124 (post-typechecking)
125
126 ff :: [Int] -> [Int]
127 ff = f Int dEqInt
128
129 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
130 f' is another thunk which evaluates to the same thing... and you end
131 up with a chain of identical values all hung onto by the CAF ff.
132
133 ff = f Int dEqInt
134
135 = let f' = f Int dEqInt in \ys. ...f'...
136
137 = let f' = let f' = f Int dEqInt in \ys. ...f'...
138 in \ys. ...f'...
139
140 Etc.
141
142 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
143 which would make the space leak go away in this case
144
145 Solution: when typechecking the RHSs we always have in hand the
146 *monomorphic* Ids for each binding. So we just need to make sure that
147 if (Method f a d) shows up in the constraints emerging from (...f...)
148 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
149 to the "givens" when simplifying constraints. That's what the "lies_avail"
150 is doing.
151
152 Then we get
153
154 f = /\a -> \d::Eq a -> letrec
155 fm = \ys:[a] -> ...fm...
156 in
157 fm
158 -}
159
160 tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
161 -- The TcGblEnv contains the new tcg_binds and tcg_spects
162 -- The TcLclEnv has an extended type envt for the new bindings
163 tcTopBinds (ValBindsOut binds sigs)
164 = do { -- Pattern synonym bindings populate the global environment
165 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
166 do { gbl <- getGblEnv
167 ; lcl <- getLclEnv
168 ; return (gbl, lcl) }
169 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
170
171 ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
172 (tcg_binds tcg_env)
173 binds'
174 , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }
175
176 ; return (tcg_env', tcl_env) }
177 -- The top level bindings are flattened into a giant
178 -- implicitly-mutually-recursive LHsBinds
179
180 tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
181
182 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
183 tcRecSelBinds (ValBindsOut binds sigs)
184 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
185 do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
186 ; let tcg_env'
187 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
188 | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
189 (tcg_binds tcg_env)
190 rec_sel_binds }
191 -- Do not add the code for record-selector bindings when
192 -- compiling hs-boot files
193 ; return tcg_env' }
194 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
195
196 tcHsBootSigs :: HsValBinds Name -> TcM [Id]
197 -- A hs-boot file has only one BindGroup, and it only has type
198 -- signatures in it. The renamer checked all this
199 tcHsBootSigs (ValBindsOut binds sigs)
200 = do { checkTc (null binds) badBootDeclErr
201 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
202 where
203 tc_boot_sig (TypeSig lnames ty _) = mapM f lnames
204 where
205 f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name True) 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 (TcPatSynInfo 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 -- | No signature or a partial signature
494 noCompleteSig :: Maybe TcSigInfo -> Bool
495 noCompleteSig Nothing = True
496 noCompleteSig (Just sig) = isPartialSig sig
497
498 ------------------------
499 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
500
501 type BKey = Int -- Just number off the bindings
502
503 mkEdges sig_fn binds
504 = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
505 Just key <- [lookupNameEnv key_map n], no_sig n ])
506 | (bind, key) <- keyd_binds
507 ]
508 where
509 no_sig :: Name -> Bool
510 no_sig n = noCompleteSig (sig_fn n)
511
512 keyd_binds = bagToList binds `zip` [0::BKey ..]
513
514 key_map :: NameEnv BKey -- Which binding it comes from
515 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
516 , bndr <- collectHsBindBinders bind ]
517
518 ------------------------
519 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
520 -> RecFlag -- Whether the group is really recursive
521 -> RecFlag -- Whether it's recursive after breaking
522 -- dependencies based on type signatures
523 -> [LHsBind Name] -- None are PatSynBind
524 -> TcM (LHsBinds TcId, [TcId])
525
526 -- Typechecks a single bunch of values bindings all together,
527 -- and generalises them. The bunch may be only part of a recursive
528 -- group, because we use type signatures to maximise polymorphism
529 --
530 -- Returns a list because the input may be a single non-recursive binding,
531 -- in which case the dependency order of the resulting bindings is
532 -- important.
533 --
534 -- Knows nothing about the scope of the bindings
535 -- None of the bindings are pattern synonyms
536
537 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
538 = setSrcSpan loc $
539 recoverM (recoveryCode binder_names sig_fn) $ do
540 -- Set up main recover; take advantage of any type sigs
541
542 { traceTc "------------------------------------------------" Outputable.empty
543 ; traceTc "Bindings for {" (ppr binder_names)
544 ; dflags <- getDynFlags
545 ; type_env <- getLclTypeEnv
546 ; let plan = decideGeneralisationPlan dflags type_env
547 binder_names bind_list sig_fn
548 ; traceTc "Generalisation plan" (ppr plan)
549 ; result@(tc_binds, poly_ids) <- case plan of
550 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
551 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
552 CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
553
554 -- Check whether strict bindings are ok
555 -- These must be non-recursive etc, and are not generalised
556 -- They desugar to a case expression in the end
557 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
558 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
559 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
560 ])
561
562 ; return result }
563 where
564 binder_names = collectHsBindListBinders bind_list
565 loc = foldr1 combineSrcSpans (map getLoc bind_list)
566 -- The mbinds have been dependency analysed and
567 -- may no longer be adjacent; so find the narrowest
568 -- span that includes them all
569
570 ------------------
571 tcPolyNoGen -- No generalisation whatsoever
572 :: RecFlag -- Whether it's recursive after breaking
573 -- dependencies based on type signatures
574 -> TcPragEnv -> TcSigFun
575 -> [LHsBind Name]
576 -> TcM (LHsBinds TcId, [TcId])
577
578 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
579 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
580 (LetGblBndr prag_fn)
581 bind_list
582 ; mono_ids' <- mapM tc_mono_info mono_infos
583 ; return (binds', mono_ids') }
584 where
585 tc_mono_info (name, _, mono_id)
586 = do { mono_ty' <- zonkTcType (idType mono_id)
587 -- Zonk, mainly to expose unboxed types to checkStrictBinds
588 ; let mono_id' = setIdType mono_id mono_ty'
589 ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
590 ; return mono_id' }
591 -- NB: tcPrags generates error messages for
592 -- specialisation pragmas for non-overloaded sigs
593 -- Indeed that is why we call it here!
594 -- So we can safely ignore _specs
595
596 ------------------
597 tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
598 -- dependencies based on type signatures
599 -> TcPragEnv
600 -> TcSigInfo
601 -> LHsBind Name
602 -> TcM (LHsBinds TcId, [TcId])
603 -- There is just one binding,
604 -- it binds a single variable,
605 -- it has a complete type signature,
606 tcPolyCheck rec_tc prag_fn
607 sig@(TcSigInfo { sig_name = name, sig_poly_id = Just poly_id
608 , sig_tvs = tvs_w_scoped
609 , sig_nwcs = sig_nwcs, sig_theta = theta
610 , sig_tau = tau, sig_loc = loc
611 , sig_warn_redundant = warn_redundant })
612 bind
613 = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards
614 do { ev_vars <- newEvVars theta
615 ; let ctxt = FunSigCtxt name warn_redundant
616 skol_info = SigSkol ctxt (mkPhiTy theta tau)
617 prag_sigs = lookupPragEnv prag_fn name
618 tvs = map snd tvs_w_scoped
619 ; (ev_binds, (binds', [mono_info]))
620 <- setSrcSpan loc $
621 checkConstraints skol_info tvs ev_vars $
622 tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind]
623
624 ; spec_prags <- tcSpecPrags poly_id prag_sigs
625 ; poly_id <- addInlinePrags poly_id prag_sigs
626
627 ; let (_, _, mono_id) = mono_info
628 export = ABE { abe_wrap = idHsWrapper
629 , abe_poly = poly_id
630 , abe_mono = mono_id
631 , abe_prags = SpecPrags spec_prags }
632 abs_bind = L loc $ AbsBinds
633 { abs_tvs = tvs
634 , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
635 , abs_exports = [export], abs_binds = binds' }
636 ; return (unitBag abs_bind, [poly_id]) }
637
638 tcPolyCheck _rec_tc _prag_fn sig _bind
639 = pprPanic "tcPolyCheck" (ppr sig)
640
641 ------------------
642 tcPolyInfer
643 :: RecFlag -- Whether it's recursive after breaking
644 -- dependencies based on type signatures
645 -> TcPragEnv -> TcSigFun
646 -> Bool -- True <=> apply the monomorphism restriction
647 -> [LHsBind Name]
648 -> TcM (LHsBinds TcId, [TcId])
649 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
650 = do { ((binds', mono_infos), tclvl, wanted)
651 <- pushLevelAndCaptureConstraints $
652 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
653
654 ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
655 ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
656 ; (qtvs, givens, _mr_bites, ev_binds)
657 <- simplifyInfer tclvl mono 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 <- completeSigPolyId_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 -> TcSigInfo -> TcM TcThetaType
780 completeTheta _ (TcPatSynInfo _)
781 = panic "Extra-constraints wildcard not supported in a pattern signature"
782 completeTheta inferred_theta
783 sig@(TcSigInfo { sig_extra_cts = mb_extra_cts
784 , sig_theta = annotated_theta })
785 | Just loc <- mb_extra_cts
786 = do { annotated_theta <- zonkTcThetaType annotated_theta
787 ; let inferred_diff = minusList inferred_theta annotated_theta
788 final_theta = annotated_theta ++ inferred_diff
789 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
790 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
791 ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
792 ; case partial_sigs of
793 True | warn_partial_sigs -> reportWarning msg
794 | otherwise -> return ()
795 False -> reportError msg
796 ; return final_theta }
797
798 | otherwise
799 = zonkTcThetaType annotated_theta
800 -- No extra-constraints wildcard means no extra constraints will be added
801 -- to the context, so just return the possibly empty (zonked)
802 -- annotated_theta.
803 where
804 pts_hint = text "To use the inferred type, enable PartialTypeSignatures"
805 mk_msg inferred_diff suppress_hint
806 = vcat [ hang ((text "Found hole") <+> quotes (char '_'))
807 2 (text "with inferred constraints:")
808 <+> pprTheta inferred_diff
809 , if suppress_hint then empty else pts_hint
810 , typeSigCtxt sig ]
811
812 {-
813 Note [Partial type signatures and generalisation]
814 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
815 When we have a partial type signature, like
816 f :: _ -> Int
817 then we *always* use the InferGen plan, and hence tcPolyInfer.
818 We do this even for a local binding with -XMonoLocalBinds.
819 Reasons:
820 * The TcSigInfo for 'f' has a unification variable for the '_',
821 whose TcLevel is one level deeper than the current level.
822 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
823 the TcLevel like InferGen, so we lose the level invariant.
824
825 * The signature might be f :: forall a. _ -> a
826 so it really is polymorphic. It's not clear what it would
827 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
828 in the (Just sig) case, checks that if there is a signature
829 then we are using LetLclBndr, and hence a nested AbsBinds with
830 increased TcLevel
831
832 It might be possible to fix these difficulties somehow, but there
833 doesn't seem much point. Indeed, adding a partial type signature is a
834 way to get per-binding inferred generalisation.
835
836 Note [Validity of inferred types]
837 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
838 We need to check inferred type for validity, in case it uses language
839 extensions that are not turned on. The principle is that if the user
840 simply adds the inferred type to the program source, it'll compile fine.
841 See #8883.
842
843 Examples that might fail:
844 - an inferred theta that requires type equalities e.g. (F a ~ G b)
845 or multi-parameter type classes
846 - an inferred type that includes unboxed tuples
847
848 However we don't do the ambiguity check (checkValidType omits it for
849 InfSigCtxt) because the impedance-matching stage, which follows
850 immediately, will do it and we don't want two error messages.
851 Moreover, because of the impedance matching stage, the ambiguity-check
852 suggestion of -XAllowAmbiguiousTypes will not work.
853
854
855 Note [Impedence matching]
856 ~~~~~~~~~~~~~~~~~~~~~~~~~
857 Consider
858 f 0 x = x
859 f n x = g [] (not x)
860
861 g [] y = f 10 y
862 g _ y = f 9 y
863
864 After typechecking we'll get
865 f_mono_ty :: a -> Bool -> Bool
866 g_mono_ty :: [b] -> Bool -> Bool
867 with constraints
868 (Eq a, Num a)
869
870 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
871 The types we really want for f and g are
872 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
873 g :: forall b. [b] -> Bool -> Bool
874
875 We can get these by "impedance matching":
876 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
877 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
878
879 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
880 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
881
882 Suppose the shared quantified tyvars are qtvs and constraints theta.
883 Then we want to check that
884 f's polytype is more polymorphic than forall qtvs. theta => f_mono_ty
885 and the proof is the impedance matcher.
886
887 Notice that the impedance matcher may do defaulting. See Trac #7173.
888
889 It also cleverly does an ambiguity check; for example, rejecting
890 f :: F a -> a
891 where F is a non-injective type function.
892 -}
893
894 --------------
895 -- If typechecking the binds fails, then return with each
896 -- signature-less binder given type (forall a.a), to minimise
897 -- subsequent error messages
898 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
899 recoveryCode binder_names sig_fn
900 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
901 ; let poly_ids = map mk_dummy binder_names
902 ; return (emptyBag, poly_ids) }
903 where
904 mk_dummy name
905 | Just (TcSigInfo { sig_poly_id = Just poly_id }) <- sig_fn name
906 = poly_id
907 | otherwise
908 = mkLocalId name forall_a_a
909
910 forall_a_a :: TcType
911 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
912
913
914 {- *********************************************************************
915 * *
916 Pragmas, including SPECIALISE
917 * *
918 ************************************************************************
919
920 Note [Handling SPECIALISE pragmas]
921 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
922 The basic idea is this:
923
924 f:: Num a => a -> b -> a
925 {-# SPECIALISE foo :: Int -> b -> Int #-}
926
927 We check that
928 (forall a. Num a => a -> a)
929 is more polymorphic than
930 Int -> Int
931 (for which we could use tcSubType, but see below), generating a HsWrapper
932 to connect the two, something like
933 wrap = /\b. <hole> Int b dNumInt
934 This wrapper is put in the TcSpecPrag, in the ABExport record of
935 the AbsBinds.
936
937
938 f :: (Eq a, Ix b) => a -> b -> Bool
939 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
940 f = <poly_rhs>
941
942 From this the typechecker generates
943
944 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
945
946 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
947 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
948
949 From these we generate:
950
951 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
952 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
953
954 Spec bind: f_spec = wrap_fn <poly_rhs>
955
956 Note that
957
958 * The LHS of the rule may mention dictionary *expressions* (eg
959 $dfIxPair dp dq), and that is essential because the dp, dq are
960 needed on the RHS.
961
962 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
963 can fully specialise it.
964
965
966
967 From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
968
969 f_spec :: Int -> b -> Int
970 f_spec = wrap<f rhs>
971
972 RULE: forall b (d:Num b). f b d = f_spec b
973
974 The RULE is generated by taking apart the HsWrapper, which is a little
975 delicate, but works.
976
977 Some wrinkles
978
979 1. We don't use full-on tcSubType, because that does co and contra
980 variance and that in turn will generate too complex a LHS for the
981 RULE. So we use a single invocation of deeplySkolemise /
982 deeplyInstantiate in tcSpecWrapper. (Actually I think that even
983 the "deeply" stuff may be too much, because it introduces lambdas,
984 though I think it can be made to work without too much trouble.)
985
986 2. We need to take care with type families (Trac #5821). Consider
987 type instance F Int = Bool
988 f :: Num a => a -> F a
989 {-# SPECIALISE foo :: Int -> Bool #-}
990
991 We *could* try to generate an f_spec with precisely the declared type:
992 f_spec :: Int -> Bool
993 f_spec = <f rhs> Int dNumInt |> co
994
995 RULE: forall d. f Int d = f_spec |> sym co
996
997 but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
998 hard to generate. At all costs we must avoid this:
999 RULE: forall d. f Int d |> co = f_spec
1000 because the LHS will never match (indeed it's rejected in
1001 decomposeRuleLhs).
1002
1003 So we simply do this:
1004 - Generate a constraint to check that the specialised type (after
1005 skolemiseation) is equal to the instantiated function type.
1006 - But *discard* the evidence (coercion) for that constraint,
1007 so that we ultimately generate the simpler code
1008 f_spec :: Int -> F Int
1009 f_spec = <f rhs> Int dNumInt
1010
1011 RULE: forall d. f Int d = f_spec
1012 You can see this discarding happening in
1013
1014 3. Note that the HsWrapper can transform *any* function with the right
1015 type prefix
1016 forall ab. (Eq a, Ix b) => XXX
1017 regardless of XXX. It's sort of polymorphic in XXX. This is
1018 useful: we use the same wrapper to transform each of the class ops, as
1019 well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags
1020 -}
1021
1022 mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv
1023 mkPragEnv sigs binds
1024 = foldl extendPragEnv emptyNameEnv prs
1025 where
1026 prs = mapMaybe get_sig sigs
1027
1028 get_sig :: LSig Name -> Maybe (Name, LSig Name)
1029 get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
1030 get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
1031 get_sig _ = Nothing
1032
1033 add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
1034 | Inline <- inl_inline inl_prag
1035 -- add arity only for real INLINE pragmas, not INLINABLE
1036 = case lookupNameEnv ar_env n of
1037 Just ar -> inl_prag { inl_sat = Just ar }
1038 Nothing -> WARN( True, ptext (sLit "mkPragEnv no arity") <+> ppr n )
1039 -- There really should be a binding for every INLINE pragma
1040 inl_prag
1041 | otherwise
1042 = inl_prag
1043
1044 -- ar_env maps a local to the arity of its definition
1045 ar_env :: NameEnv Arity
1046 ar_env = foldrBag lhsBindArity emptyNameEnv binds
1047
1048 extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv
1049 extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
1050
1051 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
1052 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
1053 = extendNameEnv env (unLoc id) (matchGroupArity ms)
1054 lhsBindArity _ env = env -- PatBind/VarBind
1055
1056 ------------------
1057 tcSpecPrags :: Id -> [LSig Name]
1058 -> TcM [LTcSpecPrag]
1059 -- Add INLINE and SPECIALSE pragmas
1060 -- INLINE prags are added to the (polymorphic) Id directly
1061 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
1062 -- Pre-condition: the poly_id is zonked
1063 -- Reason: required by tcSubExp
1064 tcSpecPrags poly_id prag_sigs
1065 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
1066 ; unless (null bad_sigs) warn_discarded_sigs
1067 ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
1068 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
1069 where
1070 spec_sigs = filter isSpecLSig prag_sigs
1071 bad_sigs = filter is_bad_sig prag_sigs
1072 is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
1073
1074 warn_discarded_sigs
1075 = addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id)
1076 2 (vcat (map (ppr . getLoc) bad_sigs)))
1077
1078 --------------
1079 tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]
1080 tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
1081 -- See Note [Handling SPECIALISE pragmas]
1082 --
1083 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
1084 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
1085 -- for the selector Id, but the poly_id is something like $cop
1086 -- However we want to use fun_name in the error message, since that is
1087 -- what the user wrote (Trac #8537)
1088 = addErrCtxt (spec_ctxt prag) $
1089 do { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys
1090 ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
1091 (ptext (sLit "SPECIALISE pragma for non-overloaded function")
1092 <+> quotes (ppr fun_name))
1093 -- Note [SPECIALISE pragmas]
1094
1095 ; wraps <- mapM (tcSpecWrapper sig_ctxt poly_ty) spec_tys
1096 ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr (spec_tys `zip` wraps))))
1097 ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] }
1098 where
1099 name = idName poly_id
1100 poly_ty = idType poly_id
1101 sig_ctxt = FunSigCtxt name True
1102 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1103
1104 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
1105
1106 --------------
1107 tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
1108 -- A simpler variant of tcSubType, used for SPECIALISE pragmas
1109 -- See Note [Handling SPECIALISE pragmas], wrinkle 1
1110 tcSpecWrapper ctxt poly_ty spec_ty
1111 = do { (sk_wrap, inst_wrap)
1112 <- tcGen ctxt spec_ty $ \ _ spec_tau ->
1113 do { (inst_wrap, tau) <- deeplyInstantiate orig poly_ty
1114 ; _ <- unifyType spec_tau tau
1115 -- Deliberately ignore the evidence
1116 -- See Note [Handling SPECIALISE pragmas],
1117 -- wrinkle (2)
1118 ; return inst_wrap }
1119 ; return (sk_wrap <.> inst_wrap) }
1120 where
1121 orig = SpecPragOrigin ctxt
1122
1123 --------------
1124 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
1125 -- SPECIALISE pragmas for imported things
1126 tcImpPrags prags
1127 = do { this_mod <- getModule
1128 ; dflags <- getDynFlags
1129 ; if (not_specialising dflags) then
1130 return []
1131 else do
1132 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
1133 [L loc (name,prag)
1134 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
1135 , not (nameIsLocalOrFrom this_mod name) ]
1136 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
1137 where
1138 -- Ignore SPECIALISE pragmas for imported things
1139 -- when we aren't specialising, or when we aren't generating
1140 -- code. The latter happens when Haddocking the base library;
1141 -- we don't wnat complaints about lack of INLINABLE pragmas
1142 not_specialising dflags
1143 | not (gopt Opt_Specialise dflags) = True
1144 | otherwise = case hscTarget dflags of
1145 HscNothing -> True
1146 HscInterpreted -> True
1147 _other -> False
1148
1149 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
1150 tcImpSpec (name, prag)
1151 = do { id <- tcLookupId name
1152 ; unless (isAnyInlinePragma (idInlinePragma id))
1153 (addWarnTc (impSpecErr name))
1154 ; tcSpecPrag id prag }
1155
1156 impSpecErr :: Name -> SDoc
1157 impSpecErr name
1158 = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
1159 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
1160 , parens $ sep
1161 [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
1162 , ptext (sLit "was compiled without -O")]])
1163 where
1164 mod = nameModule name
1165
1166
1167 {- *********************************************************************
1168 * *
1169 Vectorisation
1170 * *
1171 ********************************************************************* -}
1172
1173 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1174 tcVectDecls decls
1175 = do { decls' <- mapM (wrapLocM tcVect) decls
1176 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1177 dups = findDupsEq (==) ids
1178 ; mapM_ reportVectDups dups
1179 ; traceTcConstraints "End of tcVectDecls"
1180 ; return decls'
1181 }
1182 where
1183 reportVectDups (first:_second:_more)
1184 = addErrAt (getSrcSpan first) $
1185 ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
1186 reportVectDups _ = return ()
1187
1188 --------------
1189 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1190 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1191 -- type of the original definition as this requires internals of the vectoriser not available
1192 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1193 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1194 -- from the vectoriser here.
1195 tcVect (HsVect s name rhs)
1196 = addErrCtxt (vectCtxt name) $
1197 do { var <- wrapLocM tcLookupId name
1198 ; let L rhs_loc (HsVar rhs_var_name) = rhs
1199 ; rhs_id <- tcLookupId rhs_var_name
1200 ; return $ HsVect s var (L rhs_loc (HsVar rhs_id))
1201 }
1202
1203 {- OLD CODE:
1204 -- turn the vectorisation declaration into a single non-recursive binding
1205 ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
1206 sigFun = const Nothing
1207 pragFun = emptyPragEnv
1208
1209 -- perform type inference (including generalisation)
1210 ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
1211
1212 ; traceTc "tcVect inferred type" $ ppr (varType id')
1213 ; traceTc "tcVect bindings" $ ppr binds
1214
1215 -- add all bindings, including the type variable and dictionary bindings produced by type
1216 -- generalisation to the right-hand side of the vectorisation declaration
1217 ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
1218 ; let [bind'] = bagToList actualBinds
1219 MatchGroup
1220 [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
1221 _ = (fun_matches . unLoc) bind'
1222 rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
1223
1224 -- We return the type-checked 'Id', to propagate the inferred signature
1225 -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
1226 ; return $ HsVect (L loc id') (Just rhsWrapped)
1227 }
1228 -}
1229 tcVect (HsNoVect s name)
1230 = addErrCtxt (vectCtxt name) $
1231 do { var <- wrapLocM tcLookupId name
1232 ; return $ HsNoVect s var
1233 }
1234 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1235 = addErrCtxt (vectCtxt lname) $
1236 do { tycon <- tcLookupLocatedTyCon lname
1237 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1238 || isJust rhs_name -- or we explicitly provide a vectorised type
1239 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1240 )
1241 scalarTyConMustBeNullary
1242
1243 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1244 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1245 }
1246 tcVect (HsVectTypeOut _ _ _)
1247 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1248 tcVect (HsVectClassIn _ lname)
1249 = addErrCtxt (vectCtxt lname) $
1250 do { cls <- tcLookupLocatedClass lname
1251 ; return $ HsVectClassOut cls
1252 }
1253 tcVect (HsVectClassOut _)
1254 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1255 tcVect (HsVectInstIn linstTy)
1256 = addErrCtxt (vectCtxt linstTy) $
1257 do { (cls, tys) <- tcHsVectInst linstTy
1258 ; inst <- tcLookupInstance cls tys
1259 ; return $ HsVectInstOut inst
1260 }
1261 tcVect (HsVectInstOut _)
1262 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1263
1264 vectCtxt :: Outputable thing => thing -> SDoc
1265 vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
1266
1267 scalarTyConMustBeNullary :: MsgDoc
1268 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
1269
1270 {-
1271 Note [SPECIALISE pragmas]
1272 ~~~~~~~~~~~~~~~~~~~~~~~~~
1273 There is no point in a SPECIALISE pragma for a non-overloaded function:
1274 reverse :: [a] -> [a]
1275 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1276
1277 But SPECIALISE INLINE *can* make sense for GADTS:
1278 data Arr e where
1279 ArrInt :: !Int -> ByteArray# -> Arr Int
1280 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1281
1282 (!:) :: Arr e -> Int -> e
1283 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1284 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1285 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1286 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1287
1288 When (!:) is specialised it becomes non-recursive, and can usefully
1289 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1290 for a non-overloaded function.
1291
1292 ************************************************************************
1293 * *
1294 tcMonoBinds
1295 * *
1296 ************************************************************************
1297
1298 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1299 The signatures have been dealt with already.
1300
1301 Note [Pattern bindings]
1302 ~~~~~~~~~~~~~~~~~~~~~~~
1303 The rule for typing pattern bindings is this:
1304
1305 ..sigs..
1306 p = e
1307
1308 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1309 typechecks exactly like
1310
1311 ..sigs..
1312 x = e -- Inferred type
1313 v1 = case x of p -> v1
1314 ..
1315 vn = case x of p -> vn
1316
1317 Note that
1318 (f :: forall a. a -> a) = id
1319 should not typecheck because
1320 case id of { (f :: forall a. a->a) -> f }
1321 will not typecheck.
1322 -}
1323
1324 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1325 -- i.e. the binders are mentioned in their RHSs, and
1326 -- we are not rescued by a type signature
1327 -> TcSigFun -> LetBndrSpec
1328 -> [LHsBind Name]
1329 -> TcM (LHsBinds TcId, [MonoBindInfo])
1330
1331 tcMonoBinds is_rec sig_fn no_gen
1332 [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
1333 fun_matches = matches, bind_fvs = fvs })]
1334 -- Single function binding,
1335 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1336 , Nothing <- sig_fn name -- ...with no type signature
1337 = -- In this very special case we infer the type of the
1338 -- right hand side first (it may have a higher-rank type)
1339 -- and *then* make the monomorphic Id for the LHS
1340 -- e.g. f = \(x::forall a. a->a) -> <body>
1341 -- We want to infer a higher-rank type for f
1342 setSrcSpan b_loc $
1343 do { rhs_ty <- newFlexiTyVarTy openTypeKind
1344 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1345 ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1346 -- We extend the error context even for a non-recursive
1347 -- function so that in type error messages we show the
1348 -- type of the thing whose rhs we are type checking
1349 tcMatchesFun name inf matches rhs_ty
1350
1351 ; return (unitBag $ L b_loc $
1352 FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
1353 fun_matches = matches', bind_fvs = fvs,
1354 fun_co_fn = co_fn, fun_tick = [] },
1355 [(name, Nothing, mono_id)]) }
1356
1357 tcMonoBinds _ sig_fn no_gen binds
1358 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1359
1360 -- Bring the monomorphic Ids, into scope for the RHSs
1361 ; let mono_info = getMonoBindInfo tc_binds
1362 rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
1363 , noCompleteSig mb_sig ]
1364 -- A monomorphic binding for each term variable that lacks
1365 -- a type sig. (Ones with a sig are already in scope.)
1366
1367 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1368 | (n,id) <- rhs_id_env]
1369 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1370 mapM (wrapLocM tcRhs) tc_binds
1371 ; return (listToBag binds', mono_info) }
1372
1373 ------------------------
1374 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1375 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1376 -- if there's a signature for it, use the instantiated signature type
1377 -- otherwise invent a type variable
1378 -- You see that quite directly in the FunBind case.
1379 --
1380 -- But there's a complication for pattern bindings:
1381 -- data T = MkT (forall a. a->a)
1382 -- MkT f = e
1383 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1384 -- but we want to get (f::forall a. a->a) as the RHS environment.
1385 -- The simplest way to do this is to typecheck the pattern, and then look up the
1386 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1387 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1388
1389 data TcMonoBind -- Half completed; LHS done, RHS not done
1390 = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name))
1391 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1392
1393 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
1394 -- Type signature (if any), and
1395 -- the monomorphic bound things
1396
1397 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1398 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
1399 | Just sig <- sig_fn name
1400 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1401 , ppr name )
1402 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1403 -- or InferGen (partial signature)
1404 -- see Note [Partial type signatures and generalisation]
1405 -- Both InferGen and CheckGen gives rise to LetLclBndr
1406 do { mono_name <- newLocalName name
1407 ; let mono_id = mkLocalId mono_name (sig_tau sig)
1408 ; addErrCtxt (typeSigCtxt sig) $
1409 emitWildcardHoleConstraints (sig_nwcs sig)
1410 ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
1411
1412 | otherwise
1413 = do { mono_ty <- newFlexiTyVarTy openTypeKind
1414 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1415 ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
1416
1417 -- TODO: emit Hole Constraints for wildcards
1418 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1419 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1420 mapM lookup_info (collectPatBinders pat)
1421
1422 -- After typechecking the pattern, look up the binder
1423 -- names, which the pattern has brought into scope.
1424 lookup_info :: Name -> TcM MonoBindInfo
1425 lookup_info name = do { mono_id <- tcLookupId name
1426 ; return (name, sig_fn name, mono_id) }
1427
1428 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1429 tcInfer tc_pat
1430
1431 ; return (TcPatBind infos pat' grhss pat_ty) }
1432
1433 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1434 -- AbsBind, VarBind impossible
1435
1436 -------------------
1437 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1438 tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc inf matches)
1439 = tcExtendForRhs [info] $
1440 tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $
1441 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1442 ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
1443 matches (idType mono_id)
1444 ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
1445 , fun_matches = matches'
1446 , fun_co_fn = co_fn
1447 , bind_fvs = placeHolderNamesTc
1448 , fun_tick = [] }) }
1449 where
1450 lexically_scoped_tvs :: Maybe TcSigInfo -> [(Name, TcTyVar)]
1451 lexically_scoped_tvs (Just (TcSigInfo { sig_tvs = user_tvs, sig_nwcs = hole_tvs }))
1452 = [(n, tv) | (Just n, tv) <- user_tvs] ++ hole_tvs
1453 lexically_scoped_tvs _ = []
1454
1455 tcRhs (TcPatBind infos pat' grhss pat_ty)
1456 = -- When we are doing pattern bindings we *don't* bring any scoped
1457 -- type variables into scope unlike function bindings
1458 -- Wny not? They are not completely rigid.
1459 -- That's why we have the special case for a single FunBind in tcMonoBinds
1460 tcExtendForRhs infos $
1461 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1462 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1463 tcGRHSsPat grhss pat_ty
1464 ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
1465 , bind_fvs = placeHolderNamesTc
1466 , pat_ticks = ([],[]) }) }
1467
1468 tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1469 -- Extend the TcIdBinderStack for the RHS of the binding, with
1470 -- the monomorphic Id. That way, if we have, say
1471 -- f = \x -> blah
1472 -- and something goes wrong in 'blah', we get a "relevant binding"
1473 -- looking like f :: alpha -> beta
1474 -- This applies if 'f' has a type signature too:
1475 -- f :: forall a. [a] -> [a]
1476 -- f x = True
1477 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1478 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1479 -- would not be reported as relevant, because its type is closed
1480 tcExtendForRhs infos thing_inside
1481 = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside
1482 -- NotTopLevel: it's a monomorphic binding
1483
1484 ---------------------
1485 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1486 getMonoBindInfo tc_binds
1487 = foldr (get_info . unLoc) [] tc_binds
1488 where
1489 get_info (TcFunBind info _ _ _) rest = info : rest
1490 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1491
1492 {-
1493 ************************************************************************
1494 * *
1495 Signatures
1496 * *
1497 ************************************************************************
1498
1499 Type signatures are tricky. See Note [Signature skolems] in TcType
1500
1501 @tcSigs@ checks the signatures for validity, and returns a list of
1502 {\em freshly-instantiated} signatures. That is, the types are already
1503 split up, and have fresh type variables installed. All non-type-signature
1504 "RenamedSigs" are ignored.
1505
1506 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1507 the variable's type, and after that checked to see whether they've
1508 been instantiated.
1509
1510 Note [Scoped tyvars]
1511 ~~~~~~~~~~~~~~~~~~~~
1512 The -XScopedTypeVariables flag brings lexically-scoped type variables
1513 into scope for any explicitly forall-quantified type variables:
1514 f :: forall a. a -> a
1515 f x = e
1516 Then 'a' is in scope inside 'e'.
1517
1518 However, we do *not* support this
1519 - For pattern bindings e.g
1520 f :: forall a. a->a
1521 (f,g) = e
1522
1523 Note [Signature skolems]
1524 ~~~~~~~~~~~~~~~~~~~~~~~~
1525 When instantiating a type signature, we do so with either skolems or
1526 SigTv meta-type variables depending on the use_skols boolean. This
1527 variable is set True when we are typechecking a single function
1528 binding; and False for pattern bindings and a group of several
1529 function bindings.
1530
1531 Reason: in the latter cases, the "skolems" can be unified together,
1532 so they aren't properly rigid in the type-refinement sense.
1533 NB: unless we are doing H98, each function with a sig will be done
1534 separately, even if it's mutually recursive, so use_skols will be True
1535
1536
1537 Note [Only scoped tyvars are in the TyVarEnv]
1538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1539 We are careful to keep only the *lexically scoped* type variables in
1540 the type environment. Why? After all, the renamer has ensured
1541 that only legal occurrences occur, so we could put all type variables
1542 into the type env.
1543
1544 But we want to check that two distinct lexically scoped type variables
1545 do not map to the same internal type variable. So we need to know which
1546 the lexically-scoped ones are... and at the moment we do that by putting
1547 only the lexically scoped ones into the environment.
1548
1549 Note [Instantiate sig with fresh variables]
1550 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1551 It's vital to instantiate a type signature with fresh variables.
1552 For example:
1553 type T = forall a. [a] -> [a]
1554 f :: T;
1555 f = g where { g :: T; g = <rhs> }
1556
1557 We must not use the same 'a' from the defn of T at both places!!
1558 (Instantiation is only necessary because of type synonyms. Otherwise,
1559 it's all cool; each signature has distinct type variables from the renamer.)
1560
1561 Note [Fail eagerly on bad signatures]
1562 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1563 If a type signaure is wrong, fail immediately:
1564
1565 * the type sigs may bind type variables, so proceeding without them
1566 can lead to a cascade of errors
1567
1568 * the type signature might be ambiguous, in which case checking
1569 the code against the signature will give a very similar error
1570 to the ambiguity error.
1571
1572 ToDo: this means we fall over if any type sig
1573 is wrong (eg at the top level of the module),
1574 which is over-conservative
1575 -}
1576
1577 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
1578 tcTySigs hs_sigs
1579 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1580 do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
1581 ; let ty_sigs = concat ty_sigs_s
1582 poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
1583 -- The returned [TcId] are the ones for which we have
1584 -- a complete type signature.
1585 -- See Note [Complete and partial type signatures]
1586 env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs]
1587 ; return (poly_ids, lookupNameEnv env) }
1588
1589 tcTySig :: LSig Name -> TcM [TcSigInfo]
1590 tcTySig (L _ (IdSig id))
1591 = do { sig <- instTcTySigFromId id
1592 ; return [sig] }
1593 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
1594 = setSrcSpan loc $
1595 pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1596 -- so that they can be unified under the forall
1597 do { -- Generate fresh meta vars for the wildcards
1598 ; nwc_tvs <- mapM newWildcardVarMetaKind wcs
1599
1600 ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1 False) hs_ty
1601
1602 ; mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
1603 (map unLoc names) }
1604 where
1605 extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra
1606 extra_cts _ = Nothing
1607
1608 tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
1609 = setSrcSpan loc $
1610 do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
1611 ; let ctxt = FunSigCtxt name False
1612 ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
1613 { ty' <- tcHsSigType ctxt ty
1614 ; req' <- tcHsContext req
1615 ; prov' <- tcHsContext prov
1616
1617 ; qtvs' <- mapM zonkQuantifiedTyVar qtvs'
1618
1619 ; let (_, pat_ty) = tcSplitFunTys ty'
1620 univ_set = tyVarsOfType pat_ty
1621 (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
1622
1623 ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
1624 ; let tpsi = TPSI{ patsig_name = name,
1625 patsig_tau = ty',
1626 patsig_ex = ex_tvs,
1627 patsig_univ = univ_tvs,
1628 patsig_prov = prov',
1629 patsig_req = req' }
1630 ; return [TcPatSynInfo tpsi] }}
1631
1632 tcTySig _ = return []
1633
1634 instTcTySigFromId :: Id -> TcM TcSigInfo
1635 instTcTySigFromId id
1636 = do { let loc = getSrcSpan id
1637 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1638 (idType id)
1639 ; return (TcSigInfo { sig_name = idName id
1640 , sig_poly_id = Just id, sig_loc = loc
1641 , sig_tvs = [(Nothing, tv) | tv <- tvs]
1642 , sig_nwcs = []
1643 , sig_theta = theta, sig_tau = tau
1644 , sig_extra_cts = Nothing
1645 , sig_warn_redundant = False
1646 -- Do not report redundant constraints for
1647 -- instance methods and record selectors
1648 }) }
1649
1650 instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType
1651 -> Maybe SrcSpan -- Just loc <=> an extra-constraints
1652 -- wildcard is present at location loc.
1653 -> [(Name, TcTyVar)] -- Named wildcards
1654 -> Name -- Name of the function
1655 -> TcM TcSigInfo
1656 instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
1657 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1658 ; let mb_poly_id | isNothing extra_cts && null nwcs
1659 = Just $ mkLocalId name sigma_ty -- non-partial
1660 | otherwise = Nothing -- partial type signature
1661 ; return (TcSigInfo { sig_name = name
1662 , sig_poly_id = mb_poly_id
1663 , sig_loc = loc
1664 , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs
1665 , sig_nwcs = nwcs
1666 , sig_theta = theta, sig_tau = tau
1667 , sig_extra_cts = extra_cts
1668 , sig_warn_redundant = True
1669 }) }
1670
1671 -------------------------------
1672 data GeneralisationPlan
1673 = NoGen -- No generalisation, no AbsBinds
1674
1675 | InferGen -- Implicit generalisation; there is an AbsBinds
1676 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1677
1678 | CheckGen (LHsBind Name) TcSigInfo
1679 -- One binding with a signature
1680 -- Explicit generalisation; there is an AbsBinds
1681
1682 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1683 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1684
1685 instance Outputable GeneralisationPlan where
1686 ppr NoGen = ptext (sLit "NoGen")
1687 ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b
1688 ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
1689
1690 decideGeneralisationPlan
1691 :: DynFlags -> TcTypeEnv -> [Name]
1692 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1693 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1694 | strict_pat_binds = NoGen
1695 | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig
1696 -- See Note [Partial type signatures and generalisation]
1697 then infer_plan
1698 else CheckGen lbind sig
1699 | mono_local_binds = NoGen
1700 | otherwise = infer_plan
1701 where
1702 infer_plan = InferGen mono_restriction
1703 bndr_set = mkNameSet bndr_names
1704 binds = map unLoc lbinds
1705
1706 strict_pat_binds = any isStrictHsBind binds
1707 -- Strict patterns (top level bang or unboxed tuple) must not
1708 -- be polymorphic, because we are going to force them
1709 -- See Trac #4498, #8762
1710
1711 mono_restriction = xopt Opt_MonomorphismRestriction dflags
1712 && any restricted binds
1713
1714 is_closed_ns :: NameSet -> Bool -> Bool
1715 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1716 -- ns are the Names referred to from the RHS of this bind
1717
1718 is_closed_id :: Name -> Bool
1719 -- See Note [Bindings with closed types] in TcRnTypes
1720 is_closed_id name
1721 | name `elemNameSet` bndr_set
1722 = True -- Ignore binders in this groups, of course
1723 | Just thing <- lookupNameEnv type_env name
1724 = case thing of
1725 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1726 ATyVar {} -> False -- In-scope type variables
1727 AGlobal {} -> True -- are not closed!
1728 _ -> pprPanic "is_closed_id" (ppr name)
1729 | otherwise
1730 = WARN( isInternalName name, ppr name ) True
1731 -- The free-var set for a top level binding mentions
1732 -- imported things too, so that we can report unused imports
1733 -- These won't be in the local type env.
1734 -- Ditto class method etc from the current module
1735
1736 mono_local_binds = xopt Opt_MonoLocalBinds dflags
1737 && not closed_flag
1738
1739 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1740
1741 no_sig n = noCompleteSig (sig_fn n)
1742
1743 -- With OutsideIn, all nested bindings are monomorphic
1744 -- except a single function binding with a signature
1745 one_funbind_with_sig
1746 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1747 , Just sig <- sig_fn (unLoc v)
1748 = Just (lbind, sig)
1749 | otherwise
1750 = Nothing
1751
1752 -- The Haskell 98 monomorphism resetriction
1753 restricted (PatBind {}) = True
1754 restricted (VarBind { var_id = v }) = no_sig v
1755 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1756 && no_sig (unLoc v)
1757 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1758 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1759
1760 restricted_match (MG { mg_alts = L _ (Match _ [] _ _) : _ }) = True
1761 restricted_match _ = False
1762 -- No args => like a pattern binding
1763 -- Some args => a function binding
1764
1765 -------------------
1766 checkStrictBinds :: TopLevelFlag -> RecFlag
1767 -> [LHsBind Name]
1768 -> LHsBinds TcId -> [Id]
1769 -> TcM ()
1770 -- Check that non-overloaded unlifted bindings are
1771 -- a) non-recursive,
1772 -- b) not top level,
1773 -- c) not a multiple-binding group (more or less implied by (a))
1774
1775 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1776 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1777 = do { check (isNotTopLevel top_lvl)
1778 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1779 ; check (isNonRec rec_group)
1780 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1781
1782 ; check (all is_monomorphic (bagToList tc_binds))
1783 (polyBindErr orig_binds)
1784 -- data Ptr a = Ptr Addr#
1785 -- f x = let p@(Ptr y) = ... in ...
1786 -- Here the binding for 'p' is polymorphic, but does
1787 -- not mix with an unlifted binding for 'y'. You should
1788 -- use a bang pattern. Trac #6078.
1789
1790 ; check (isSingleton orig_binds)
1791 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1792
1793 -- Complain about a binding that looks lazy
1794 -- e.g. let I# y = x in ...
1795 -- Remember, in checkStrictBinds we are going to do strict
1796 -- matching, so (for software engineering reasons) we insist
1797 -- that the strictness is manifest on each binding
1798 -- However, lone (unboxed) variables are ok
1799 ; check (not any_pat_looks_lazy)
1800 (unliftedMustBeBang orig_binds) }
1801 | otherwise
1802 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1803 return ()
1804 where
1805 any_unlifted_bndr = any is_unlifted poly_ids
1806 any_strict_pat = any (isStrictHsBind . unLoc) orig_binds
1807 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1808
1809 is_unlifted id = case tcSplitSigmaTy (idType id) of
1810 (_, _, rho) -> isUnLiftedType rho
1811 -- For the is_unlifted check, we need to look inside polymorphism
1812 -- and overloading. E.g. x = (# 1, True #)
1813 -- would get type forall a. Num a => (# a, Bool #)
1814 -- and we want to reject that. See Trac #9140
1815
1816 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1817 = null tvs && null evs
1818 is_monomorphic _ = True
1819
1820 check :: Bool -> MsgDoc -> TcM ()
1821 -- Just like checkTc, but with a special case for module GHC.Prim:
1822 -- see Note [Compiling GHC.Prim]
1823 check True _ = return ()
1824 check False err = do { mod <- getModule
1825 ; checkTc (mod == gHC_PRIM) err }
1826
1827 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1828 unliftedMustBeBang binds
1829 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1830 2 (vcat (map ppr binds))
1831
1832 polyBindErr :: [LHsBind Name] -> SDoc
1833 polyBindErr binds
1834 = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
1835 2 (vcat [vcat (map ppr binds),
1836 ptext (sLit "Probable fix: use a bang pattern")])
1837
1838 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1839 strictBindErr flavour any_unlifted_bndr binds
1840 = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
1841 2 (vcat (map ppr binds))
1842 where
1843 msg | any_unlifted_bndr = ptext (sLit "bindings for unlifted types")
1844 | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
1845
1846
1847 {- Note [Compiling GHC.Prim]
1848 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1849 Module GHC.Prim has no source code: it is the host module for
1850 primitive, built-in functions and types. However, for Haddock-ing
1851 purposes we generate (via utils/genprimopcode) a fake source file
1852 GHC/Prim.hs, and give it to Haddock, so that it can generate
1853 documentation. It contains definitions like
1854 nullAddr# :: NullAddr#
1855 which would normally be rejected as a top-level unlifted binding. But
1856 we don't want to complain, because we are only "compiling" this fake
1857 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
1858 in checkStrictBinds.
1859
1860 (We only make the test if things look wrong, so there is no cost in
1861 the common case.) -}
1862
1863
1864 {- *********************************************************************
1865 * *
1866 Error contexts and messages
1867 * *
1868 ********************************************************************* -}
1869
1870 -- This one is called on LHS, when pat and grhss are both Name
1871 -- and on RHS, when pat is TcId and grhss is still Name
1872 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
1873 patMonoBindsCtxt pat grhss
1874 = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1875
1876 typeSigCtxt :: TcSigInfo -> SDoc
1877 typeSigCtxt (TcPatSynInfo _)
1878 = panic "Should only be called with a TcSigInfo"
1879 typeSigCtxt (TcSigInfo { sig_name = name, sig_tvs = tvs
1880 , sig_theta = theta, sig_tau = tau
1881 , sig_extra_cts = extra_cts })
1882 = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name False) <> colon
1883 , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
1884 (mkSigmaTy (map snd tvs) theta tau)) ]