Add NOINLINE for hs-boot functions
[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 , Just ar <- lookupNameEnv ar_env n
1037 = inl_prag { inl_sat = Just ar }
1038 | otherwise
1039 = inl_prag
1040
1041 -- ar_env maps a local to the arity of its definition
1042 ar_env :: NameEnv Arity
1043 ar_env = foldrBag lhsBindArity emptyNameEnv binds
1044
1045 extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv
1046 extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
1047
1048 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
1049 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
1050 = extendNameEnv env (unLoc id) (matchGroupArity ms)
1051 lhsBindArity _ env = env -- PatBind/VarBind
1052
1053 ------------------
1054 tcSpecPrags :: Id -> [LSig Name]
1055 -> TcM [LTcSpecPrag]
1056 -- Add INLINE and SPECIALSE pragmas
1057 -- INLINE prags are added to the (polymorphic) Id directly
1058 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
1059 -- Pre-condition: the poly_id is zonked
1060 -- Reason: required by tcSubExp
1061 tcSpecPrags poly_id prag_sigs
1062 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
1063 ; unless (null bad_sigs) warn_discarded_sigs
1064 ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
1065 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
1066 where
1067 spec_sigs = filter isSpecLSig prag_sigs
1068 bad_sigs = filter is_bad_sig prag_sigs
1069 is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
1070
1071 warn_discarded_sigs
1072 = addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id)
1073 2 (vcat (map (ppr . getLoc) bad_sigs)))
1074
1075 --------------
1076 tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]
1077 tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
1078 -- See Note [Handling SPECIALISE pragmas]
1079 --
1080 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
1081 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
1082 -- for the selector Id, but the poly_id is something like $cop
1083 -- However we want to use fun_name in the error message, since that is
1084 -- what the user wrote (Trac #8537)
1085 = addErrCtxt (spec_ctxt prag) $
1086 do { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys
1087 ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
1088 (ptext (sLit "SPECIALISE pragma for non-overloaded function")
1089 <+> quotes (ppr fun_name))
1090 -- Note [SPECIALISE pragmas]
1091
1092 ; wraps <- mapM (tcSpecWrapper sig_ctxt poly_ty) spec_tys
1093 ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr (spec_tys `zip` wraps))))
1094 ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] }
1095 where
1096 name = idName poly_id
1097 poly_ty = idType poly_id
1098 sig_ctxt = FunSigCtxt name True
1099 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1100
1101 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
1102
1103 --------------
1104 tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
1105 -- A simpler variant of tcSubType, used for SPECIALISE pragmas
1106 -- See Note [Handling SPECIALISE pragmas], wrinkle 1
1107 tcSpecWrapper ctxt poly_ty spec_ty
1108 = do { (sk_wrap, inst_wrap)
1109 <- tcGen ctxt spec_ty $ \ _ spec_tau ->
1110 do { (inst_wrap, tau) <- deeplyInstantiate orig poly_ty
1111 ; _ <- unifyType spec_tau tau
1112 -- Deliberately ignore the evidence
1113 -- See Note [Handling SPECIALISE pragmas],
1114 -- wrinkle (2)
1115 ; return inst_wrap }
1116 ; return (sk_wrap <.> inst_wrap) }
1117 where
1118 orig = SpecPragOrigin ctxt
1119
1120 --------------
1121 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
1122 -- SPECIALISE pragmas for imported things
1123 tcImpPrags prags
1124 = do { this_mod <- getModule
1125 ; dflags <- getDynFlags
1126 ; if (not_specialising dflags) then
1127 return []
1128 else do
1129 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
1130 [L loc (name,prag)
1131 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
1132 , not (nameIsLocalOrFrom this_mod name) ]
1133 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
1134 where
1135 -- Ignore SPECIALISE pragmas for imported things
1136 -- when we aren't specialising, or when we aren't generating
1137 -- code. The latter happens when Haddocking the base library;
1138 -- we don't wnat complaints about lack of INLINABLE pragmas
1139 not_specialising dflags
1140 | not (gopt Opt_Specialise dflags) = True
1141 | otherwise = case hscTarget dflags of
1142 HscNothing -> True
1143 HscInterpreted -> True
1144 _other -> False
1145
1146 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
1147 tcImpSpec (name, prag)
1148 = do { id <- tcLookupId name
1149 ; unless (isAnyInlinePragma (idInlinePragma id))
1150 (addWarnTc (impSpecErr name))
1151 ; tcSpecPrag id prag }
1152
1153 impSpecErr :: Name -> SDoc
1154 impSpecErr name
1155 = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
1156 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
1157 , parens $ sep
1158 [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
1159 , ptext (sLit "was compiled without -O")]])
1160 where
1161 mod = nameModule name
1162
1163
1164 {- *********************************************************************
1165 * *
1166 Vectorisation
1167 * *
1168 ********************************************************************* -}
1169
1170 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1171 tcVectDecls decls
1172 = do { decls' <- mapM (wrapLocM tcVect) decls
1173 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1174 dups = findDupsEq (==) ids
1175 ; mapM_ reportVectDups dups
1176 ; traceTcConstraints "End of tcVectDecls"
1177 ; return decls'
1178 }
1179 where
1180 reportVectDups (first:_second:_more)
1181 = addErrAt (getSrcSpan first) $
1182 ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
1183 reportVectDups _ = return ()
1184
1185 --------------
1186 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1187 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1188 -- type of the original definition as this requires internals of the vectoriser not available
1189 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1190 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1191 -- from the vectoriser here.
1192 tcVect (HsVect s name rhs)
1193 = addErrCtxt (vectCtxt name) $
1194 do { var <- wrapLocM tcLookupId name
1195 ; let L rhs_loc (HsVar rhs_var_name) = rhs
1196 ; rhs_id <- tcLookupId rhs_var_name
1197 ; return $ HsVect s var (L rhs_loc (HsVar rhs_id))
1198 }
1199
1200 {- OLD CODE:
1201 -- turn the vectorisation declaration into a single non-recursive binding
1202 ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
1203 sigFun = const Nothing
1204 pragFun = emptyPragEnv
1205
1206 -- perform type inference (including generalisation)
1207 ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
1208
1209 ; traceTc "tcVect inferred type" $ ppr (varType id')
1210 ; traceTc "tcVect bindings" $ ppr binds
1211
1212 -- add all bindings, including the type variable and dictionary bindings produced by type
1213 -- generalisation to the right-hand side of the vectorisation declaration
1214 ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
1215 ; let [bind'] = bagToList actualBinds
1216 MatchGroup
1217 [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
1218 _ = (fun_matches . unLoc) bind'
1219 rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
1220
1221 -- We return the type-checked 'Id', to propagate the inferred signature
1222 -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
1223 ; return $ HsVect (L loc id') (Just rhsWrapped)
1224 }
1225 -}
1226 tcVect (HsNoVect s name)
1227 = addErrCtxt (vectCtxt name) $
1228 do { var <- wrapLocM tcLookupId name
1229 ; return $ HsNoVect s var
1230 }
1231 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1232 = addErrCtxt (vectCtxt lname) $
1233 do { tycon <- tcLookupLocatedTyCon lname
1234 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1235 || isJust rhs_name -- or we explicitly provide a vectorised type
1236 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1237 )
1238 scalarTyConMustBeNullary
1239
1240 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1241 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1242 }
1243 tcVect (HsVectTypeOut _ _ _)
1244 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1245 tcVect (HsVectClassIn _ lname)
1246 = addErrCtxt (vectCtxt lname) $
1247 do { cls <- tcLookupLocatedClass lname
1248 ; return $ HsVectClassOut cls
1249 }
1250 tcVect (HsVectClassOut _)
1251 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1252 tcVect (HsVectInstIn linstTy)
1253 = addErrCtxt (vectCtxt linstTy) $
1254 do { (cls, tys) <- tcHsVectInst linstTy
1255 ; inst <- tcLookupInstance cls tys
1256 ; return $ HsVectInstOut inst
1257 }
1258 tcVect (HsVectInstOut _)
1259 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1260
1261 vectCtxt :: Outputable thing => thing -> SDoc
1262 vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
1263
1264 scalarTyConMustBeNullary :: MsgDoc
1265 scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
1266
1267 {-
1268 Note [SPECIALISE pragmas]
1269 ~~~~~~~~~~~~~~~~~~~~~~~~~
1270 There is no point in a SPECIALISE pragma for a non-overloaded function:
1271 reverse :: [a] -> [a]
1272 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1273
1274 But SPECIALISE INLINE *can* make sense for GADTS:
1275 data Arr e where
1276 ArrInt :: !Int -> ByteArray# -> Arr Int
1277 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1278
1279 (!:) :: Arr e -> Int -> e
1280 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1281 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1282 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1283 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1284
1285 When (!:) is specialised it becomes non-recursive, and can usefully
1286 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1287 for a non-overloaded function.
1288
1289 ************************************************************************
1290 * *
1291 tcMonoBinds
1292 * *
1293 ************************************************************************
1294
1295 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1296 The signatures have been dealt with already.
1297
1298 Note [Pattern bindings]
1299 ~~~~~~~~~~~~~~~~~~~~~~~
1300 The rule for typing pattern bindings is this:
1301
1302 ..sigs..
1303 p = e
1304
1305 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1306 typechecks exactly like
1307
1308 ..sigs..
1309 x = e -- Inferred type
1310 v1 = case x of p -> v1
1311 ..
1312 vn = case x of p -> vn
1313
1314 Note that
1315 (f :: forall a. a -> a) = id
1316 should not typecheck because
1317 case id of { (f :: forall a. a->a) -> f }
1318 will not typecheck.
1319 -}
1320
1321 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1322 -- i.e. the binders are mentioned in their RHSs, and
1323 -- we are not rescued by a type signature
1324 -> TcSigFun -> LetBndrSpec
1325 -> [LHsBind Name]
1326 -> TcM (LHsBinds TcId, [MonoBindInfo])
1327
1328 tcMonoBinds is_rec sig_fn no_gen
1329 [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
1330 fun_matches = matches, bind_fvs = fvs })]
1331 -- Single function binding,
1332 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1333 , Nothing <- sig_fn name -- ...with no type signature
1334 = -- In this very special case we infer the type of the
1335 -- right hand side first (it may have a higher-rank type)
1336 -- and *then* make the monomorphic Id for the LHS
1337 -- e.g. f = \(x::forall a. a->a) -> <body>
1338 -- We want to infer a higher-rank type for f
1339 setSrcSpan b_loc $
1340 do { rhs_ty <- newFlexiTyVarTy openTypeKind
1341 ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1342 ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
1343 -- We extend the error context even for a non-recursive
1344 -- function so that in type error messages we show the
1345 -- type of the thing whose rhs we are type checking
1346 tcMatchesFun name inf matches rhs_ty
1347
1348 ; return (unitBag $ L b_loc $
1349 FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
1350 fun_matches = matches', bind_fvs = fvs,
1351 fun_co_fn = co_fn, fun_tick = [] },
1352 [(name, Nothing, mono_id)]) }
1353
1354 tcMonoBinds _ sig_fn no_gen binds
1355 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1356
1357 -- Bring the monomorphic Ids, into scope for the RHSs
1358 ; let mono_info = getMonoBindInfo tc_binds
1359 rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
1360 , noCompleteSig mb_sig ]
1361 -- A monomorphic binding for each term variable that lacks
1362 -- a type sig. (Ones with a sig are already in scope.)
1363
1364 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1365 | (n,id) <- rhs_id_env]
1366 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1367 mapM (wrapLocM tcRhs) tc_binds
1368 ; return (listToBag binds', mono_info) }
1369
1370 ------------------------
1371 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1372 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1373 -- if there's a signature for it, use the instantiated signature type
1374 -- otherwise invent a type variable
1375 -- You see that quite directly in the FunBind case.
1376 --
1377 -- But there's a complication for pattern bindings:
1378 -- data T = MkT (forall a. a->a)
1379 -- MkT f = e
1380 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1381 -- but we want to get (f::forall a. a->a) as the RHS environment.
1382 -- The simplest way to do this is to typecheck the pattern, and then look up the
1383 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1384 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1385
1386 data TcMonoBind -- Half completed; LHS done, RHS not done
1387 = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name))
1388 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1389
1390 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
1391 -- Type signature (if any), and
1392 -- the monomorphic bound things
1393
1394 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1395 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
1396 | Just sig <- sig_fn name
1397 = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
1398 , ppr name )
1399 -- { f :: ty; f x = e } is always done via CheckGen (full signature)
1400 -- or InferGen (partial signature)
1401 -- see Note [Partial type signatures and generalisation]
1402 -- Both InferGen and CheckGen gives rise to LetLclBndr
1403 do { mono_name <- newLocalName name
1404 ; let mono_id = mkLocalId mono_name (sig_tau sig)
1405 ; addErrCtxt (typeSigCtxt sig) $
1406 emitWildcardHoleConstraints (sig_nwcs sig)
1407 ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
1408
1409 | otherwise
1410 = do { mono_ty <- newFlexiTyVarTy openTypeKind
1411 ; mono_id <- newNoSigLetBndr no_gen name mono_ty
1412 ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
1413
1414 -- TODO: emit Hole Constraints for wildcards
1415 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1416 = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
1417 mapM lookup_info (collectPatBinders pat)
1418
1419 -- After typechecking the pattern, look up the binder
1420 -- names, which the pattern has brought into scope.
1421 lookup_info :: Name -> TcM MonoBindInfo
1422 lookup_info name = do { mono_id <- tcLookupId name
1423 ; return (name, sig_fn name, mono_id) }
1424
1425 ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1426 tcInfer tc_pat
1427
1428 ; return (TcPatBind infos pat' grhss pat_ty) }
1429
1430 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1431 -- AbsBind, VarBind impossible
1432
1433 -------------------
1434 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1435 tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc inf matches)
1436 = tcExtendForRhs [info] $
1437 tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $
1438 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1439 ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
1440 matches (idType mono_id)
1441 ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
1442 , fun_matches = matches'
1443 , fun_co_fn = co_fn
1444 , bind_fvs = placeHolderNamesTc
1445 , fun_tick = [] }) }
1446 where
1447 lexically_scoped_tvs :: Maybe TcSigInfo -> [(Name, TcTyVar)]
1448 lexically_scoped_tvs (Just (TcSigInfo { sig_tvs = user_tvs, sig_nwcs = hole_tvs }))
1449 = [(n, tv) | (Just n, tv) <- user_tvs] ++ hole_tvs
1450 lexically_scoped_tvs _ = []
1451
1452 tcRhs (TcPatBind infos pat' grhss pat_ty)
1453 = -- When we are doing pattern bindings we *don't* bring any scoped
1454 -- type variables into scope unlike function bindings
1455 -- Wny not? They are not completely rigid.
1456 -- That's why we have the special case for a single FunBind in tcMonoBinds
1457 tcExtendForRhs infos $
1458 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1459 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1460 tcGRHSsPat grhss pat_ty
1461 ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
1462 , bind_fvs = placeHolderNamesTc
1463 , pat_ticks = ([],[]) }) }
1464
1465 tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1466 -- Extend the TcIdBinderStack for the RHS of the binding, with
1467 -- the monomorphic Id. That way, if we have, say
1468 -- f = \x -> blah
1469 -- and something goes wrong in 'blah', we get a "relevant binding"
1470 -- looking like f :: alpha -> beta
1471 -- This applies if 'f' has a type signature too:
1472 -- f :: forall a. [a] -> [a]
1473 -- f x = True
1474 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1475 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1476 -- would not be reported as relevant, because its type is closed
1477 tcExtendForRhs infos thing_inside
1478 = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside
1479 -- NotTopLevel: it's a monomorphic binding
1480
1481 ---------------------
1482 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1483 getMonoBindInfo tc_binds
1484 = foldr (get_info . unLoc) [] tc_binds
1485 where
1486 get_info (TcFunBind info _ _ _) rest = info : rest
1487 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1488
1489 {-
1490 ************************************************************************
1491 * *
1492 Signatures
1493 * *
1494 ************************************************************************
1495
1496 Type signatures are tricky. See Note [Signature skolems] in TcType
1497
1498 @tcSigs@ checks the signatures for validity, and returns a list of
1499 {\em freshly-instantiated} signatures. That is, the types are already
1500 split up, and have fresh type variables installed. All non-type-signature
1501 "RenamedSigs" are ignored.
1502
1503 The @TcSigInfo@ contains @TcTypes@ because they are unified with
1504 the variable's type, and after that checked to see whether they've
1505 been instantiated.
1506
1507 Note [Scoped tyvars]
1508 ~~~~~~~~~~~~~~~~~~~~
1509 The -XScopedTypeVariables flag brings lexically-scoped type variables
1510 into scope for any explicitly forall-quantified type variables:
1511 f :: forall a. a -> a
1512 f x = e
1513 Then 'a' is in scope inside 'e'.
1514
1515 However, we do *not* support this
1516 - For pattern bindings e.g
1517 f :: forall a. a->a
1518 (f,g) = e
1519
1520 Note [Signature skolems]
1521 ~~~~~~~~~~~~~~~~~~~~~~~~
1522 When instantiating a type signature, we do so with either skolems or
1523 SigTv meta-type variables depending on the use_skols boolean. This
1524 variable is set True when we are typechecking a single function
1525 binding; and False for pattern bindings and a group of several
1526 function bindings.
1527
1528 Reason: in the latter cases, the "skolems" can be unified together,
1529 so they aren't properly rigid in the type-refinement sense.
1530 NB: unless we are doing H98, each function with a sig will be done
1531 separately, even if it's mutually recursive, so use_skols will be True
1532
1533
1534 Note [Only scoped tyvars are in the TyVarEnv]
1535 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1536 We are careful to keep only the *lexically scoped* type variables in
1537 the type environment. Why? After all, the renamer has ensured
1538 that only legal occurrences occur, so we could put all type variables
1539 into the type env.
1540
1541 But we want to check that two distinct lexically scoped type variables
1542 do not map to the same internal type variable. So we need to know which
1543 the lexically-scoped ones are... and at the moment we do that by putting
1544 only the lexically scoped ones into the environment.
1545
1546 Note [Instantiate sig with fresh variables]
1547 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1548 It's vital to instantiate a type signature with fresh variables.
1549 For example:
1550 type T = forall a. [a] -> [a]
1551 f :: T;
1552 f = g where { g :: T; g = <rhs> }
1553
1554 We must not use the same 'a' from the defn of T at both places!!
1555 (Instantiation is only necessary because of type synonyms. Otherwise,
1556 it's all cool; each signature has distinct type variables from the renamer.)
1557
1558 Note [Fail eagerly on bad signatures]
1559 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1560 If a type signaure is wrong, fail immediately:
1561
1562 * the type sigs may bind type variables, so proceeding without them
1563 can lead to a cascade of errors
1564
1565 * the type signature might be ambiguous, in which case checking
1566 the code against the signature will give a very similar error
1567 to the ambiguity error.
1568
1569 ToDo: this means we fall over if any type sig
1570 is wrong (eg at the top level of the module),
1571 which is over-conservative
1572 -}
1573
1574 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
1575 tcTySigs hs_sigs
1576 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
1577 do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
1578 ; let ty_sigs = concat ty_sigs_s
1579 poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
1580 -- The returned [TcId] are the ones for which we have
1581 -- a complete type signature.
1582 -- See Note [Complete and partial type signatures]
1583 env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs]
1584 ; return (poly_ids, lookupNameEnv env) }
1585
1586 tcTySig :: LSig Name -> TcM [TcSigInfo]
1587 tcTySig (L _ (IdSig id))
1588 = do { sig <- instTcTySigFromId id
1589 ; return [sig] }
1590 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
1591 = setSrcSpan loc $
1592 pushTcLevelM_ $ -- When instantiating the signature, do so "one level in"
1593 -- so that they can be unified under the forall
1594 do { -- Generate fresh meta vars for the wildcards
1595 ; nwc_tvs <- mapM newWildcardVarMetaKind wcs
1596
1597 ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1 False) hs_ty
1598
1599 ; mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
1600 (map unLoc names) }
1601 where
1602 extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra
1603 extra_cts _ = Nothing
1604
1605 tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
1606 = setSrcSpan loc $
1607 do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
1608 ; let ctxt = FunSigCtxt name False
1609 ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
1610 { ty' <- tcHsSigType ctxt ty
1611 ; req' <- tcHsContext req
1612 ; prov' <- tcHsContext prov
1613
1614 ; qtvs' <- mapM zonkQuantifiedTyVar qtvs'
1615
1616 ; let (_, pat_ty) = tcSplitFunTys ty'
1617 univ_set = tyVarsOfType pat_ty
1618 (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
1619
1620 ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
1621 ; let tpsi = TPSI{ patsig_name = name,
1622 patsig_tau = ty',
1623 patsig_ex = ex_tvs,
1624 patsig_univ = univ_tvs,
1625 patsig_prov = prov',
1626 patsig_req = req' }
1627 ; return [TcPatSynInfo tpsi] }}
1628
1629 tcTySig _ = return []
1630
1631 instTcTySigFromId :: Id -> TcM TcSigInfo
1632 instTcTySigFromId id
1633 = do { let loc = getSrcSpan id
1634 ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
1635 (idType id)
1636 ; return (TcSigInfo { sig_name = idName id
1637 , sig_poly_id = Just id, sig_loc = loc
1638 , sig_tvs = [(Nothing, tv) | tv <- tvs]
1639 , sig_nwcs = []
1640 , sig_theta = theta, sig_tau = tau
1641 , sig_extra_cts = Nothing
1642 , sig_warn_redundant = False
1643 -- Do not report redundant constraints for
1644 -- instance methods and record selectors
1645 }) }
1646
1647 instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType
1648 -> Maybe SrcSpan -- Just loc <=> an extra-constraints
1649 -- wildcard is present at location loc.
1650 -> [(Name, TcTyVar)] -- Named wildcards
1651 -> Name -- Name of the function
1652 -> TcM TcSigInfo
1653 instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
1654 = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
1655 ; let mb_poly_id | isNothing extra_cts && null nwcs
1656 = Just $ mkLocalId name sigma_ty -- non-partial
1657 | otherwise = Nothing -- partial type signature
1658 ; return (TcSigInfo { sig_name = name
1659 , sig_poly_id = mb_poly_id
1660 , sig_loc = loc
1661 , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs
1662 , sig_nwcs = nwcs
1663 , sig_theta = theta, sig_tau = tau
1664 , sig_extra_cts = extra_cts
1665 , sig_warn_redundant = True
1666 }) }
1667
1668 -------------------------------
1669 data GeneralisationPlan
1670 = NoGen -- No generalisation, no AbsBinds
1671
1672 | InferGen -- Implicit generalisation; there is an AbsBinds
1673 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1674
1675 | CheckGen (LHsBind Name) TcSigInfo
1676 -- One binding with a signature
1677 -- Explicit generalisation; there is an AbsBinds
1678
1679 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1680 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1681
1682 instance Outputable GeneralisationPlan where
1683 ppr NoGen = ptext (sLit "NoGen")
1684 ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b
1685 ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
1686
1687 decideGeneralisationPlan
1688 :: DynFlags -> TcTypeEnv -> [Name]
1689 -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
1690 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
1691 | strict_pat_binds = NoGen
1692 | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig
1693 -- See Note [Partial type signatures and generalisation]
1694 then infer_plan
1695 else CheckGen lbind sig
1696 | mono_local_binds = NoGen
1697 | otherwise = infer_plan
1698 where
1699 infer_plan = InferGen mono_restriction
1700 bndr_set = mkNameSet bndr_names
1701 binds = map unLoc lbinds
1702
1703 strict_pat_binds = any isStrictHsBind binds
1704 -- Strict patterns (top level bang or unboxed tuple) must not
1705 -- be polymorphic, because we are going to force them
1706 -- See Trac #4498, #8762
1707
1708 mono_restriction = xopt Opt_MonomorphismRestriction dflags
1709 && any restricted binds
1710
1711 is_closed_ns :: NameSet -> Bool -> Bool
1712 is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
1713 -- ns are the Names referred to from the RHS of this bind
1714
1715 is_closed_id :: Name -> Bool
1716 -- See Note [Bindings with closed types] in TcRnTypes
1717 is_closed_id name
1718 | name `elemNameSet` bndr_set
1719 = True -- Ignore binders in this groups, of course
1720 | Just thing <- lookupNameEnv type_env name
1721 = case thing of
1722 ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
1723 ATyVar {} -> False -- In-scope type variables
1724 AGlobal {} -> True -- are not closed!
1725 _ -> pprPanic "is_closed_id" (ppr name)
1726 | otherwise
1727 = WARN( isInternalName name, ppr name ) True
1728 -- The free-var set for a top level binding mentions
1729 -- imported things too, so that we can report unused imports
1730 -- These won't be in the local type env.
1731 -- Ditto class method etc from the current module
1732
1733 mono_local_binds = xopt Opt_MonoLocalBinds dflags
1734 && not closed_flag
1735
1736 closed_flag = foldr (is_closed_ns . bind_fvs) True binds
1737
1738 no_sig n = noCompleteSig (sig_fn n)
1739
1740 -- With OutsideIn, all nested bindings are monomorphic
1741 -- except a single function binding with a signature
1742 one_funbind_with_sig
1743 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1744 , Just sig <- sig_fn (unLoc v)
1745 = Just (lbind, sig)
1746 | otherwise
1747 = Nothing
1748
1749 -- The Haskell 98 monomorphism resetriction
1750 restricted (PatBind {}) = True
1751 restricted (VarBind { var_id = v }) = no_sig v
1752 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1753 && no_sig (unLoc v)
1754 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1755 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1756
1757 restricted_match (MG { mg_alts = L _ (Match _ [] _ _) : _ }) = True
1758 restricted_match _ = False
1759 -- No args => like a pattern binding
1760 -- Some args => a function binding
1761
1762 -------------------
1763 checkStrictBinds :: TopLevelFlag -> RecFlag
1764 -> [LHsBind Name]
1765 -> LHsBinds TcId -> [Id]
1766 -> TcM ()
1767 -- Check that non-overloaded unlifted bindings are
1768 -- a) non-recursive,
1769 -- b) not top level,
1770 -- c) not a multiple-binding group (more or less implied by (a))
1771
1772 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1773 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1774 = do { check (isNotTopLevel top_lvl)
1775 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1776 ; check (isNonRec rec_group)
1777 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1778
1779 ; check (all is_monomorphic (bagToList tc_binds))
1780 (polyBindErr orig_binds)
1781 -- data Ptr a = Ptr Addr#
1782 -- f x = let p@(Ptr y) = ... in ...
1783 -- Here the binding for 'p' is polymorphic, but does
1784 -- not mix with an unlifted binding for 'y'. You should
1785 -- use a bang pattern. Trac #6078.
1786
1787 ; check (isSingleton orig_binds)
1788 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1789
1790 -- Complain about a binding that looks lazy
1791 -- e.g. let I# y = x in ...
1792 -- Remember, in checkStrictBinds we are going to do strict
1793 -- matching, so (for software engineering reasons) we insist
1794 -- that the strictness is manifest on each binding
1795 -- However, lone (unboxed) variables are ok
1796 ; check (not any_pat_looks_lazy)
1797 (unliftedMustBeBang orig_binds) }
1798 | otherwise
1799 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1800 return ()
1801 where
1802 any_unlifted_bndr = any is_unlifted poly_ids
1803 any_strict_pat = any (isStrictHsBind . unLoc) orig_binds
1804 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1805
1806 is_unlifted id = case tcSplitSigmaTy (idType id) of
1807 (_, _, rho) -> isUnLiftedType rho
1808 -- For the is_unlifted check, we need to look inside polymorphism
1809 -- and overloading. E.g. x = (# 1, True #)
1810 -- would get type forall a. Num a => (# a, Bool #)
1811 -- and we want to reject that. See Trac #9140
1812
1813 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1814 = null tvs && null evs
1815 is_monomorphic _ = True
1816
1817 check :: Bool -> MsgDoc -> TcM ()
1818 -- Just like checkTc, but with a special case for module GHC.Prim:
1819 -- see Note [Compiling GHC.Prim]
1820 check True _ = return ()
1821 check False err = do { mod <- getModule
1822 ; checkTc (mod == gHC_PRIM) err }
1823
1824 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1825 unliftedMustBeBang binds
1826 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1827 2 (vcat (map ppr binds))
1828
1829 polyBindErr :: [LHsBind Name] -> SDoc
1830 polyBindErr binds
1831 = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
1832 2 (vcat [vcat (map ppr binds),
1833 ptext (sLit "Probable fix: use a bang pattern")])
1834
1835 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1836 strictBindErr flavour any_unlifted_bndr binds
1837 = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
1838 2 (vcat (map ppr binds))
1839 where
1840 msg | any_unlifted_bndr = ptext (sLit "bindings for unlifted types")
1841 | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
1842
1843
1844 {- Note [Compiling GHC.Prim]
1845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1846 Module GHC.Prim has no source code: it is the host module for
1847 primitive, built-in functions and types. However, for Haddock-ing
1848 purposes we generate (via utils/genprimopcode) a fake source file
1849 GHC/Prim.hs, and give it to Haddock, so that it can generate
1850 documentation. It contains definitions like
1851 nullAddr# :: NullAddr#
1852 which would normally be rejected as a top-level unlifted binding. But
1853 we don't want to complain, because we are only "compiling" this fake
1854 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
1855 in checkStrictBinds.
1856
1857 (We only make the test if things look wrong, so there is no cost in
1858 the common case.) -}
1859
1860
1861 {- *********************************************************************
1862 * *
1863 Error contexts and messages
1864 * *
1865 ********************************************************************* -}
1866
1867 -- This one is called on LHS, when pat and grhss are both Name
1868 -- and on RHS, when pat is TcId and grhss is still Name
1869 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
1870 patMonoBindsCtxt pat grhss
1871 = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
1872
1873 typeSigCtxt :: TcSigInfo -> SDoc
1874 typeSigCtxt (TcPatSynInfo _)
1875 = panic "Should only be called with a TcSigInfo"
1876 typeSigCtxt (TcSigInfo { sig_name = name, sig_tvs = tvs
1877 , sig_theta = theta, sig_tau = tau
1878 , sig_extra_cts = extra_cts })
1879 = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name False) <> colon
1880 , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
1881 (mkSigmaTy (map snd tvs) theta tau)) ]