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