Support SCC pragmas in declaration context
[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 {-# LANGUAGE FlexibleContexts #-}
10
11 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
12 tcValBinds, tcHsBootSigs, tcPolyCheck,
13 tcVectDecls, addTypecheckedBinds,
14 chooseInferredQuantifiers,
15 badBootDeclErr ) where
16
17 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
18 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
19 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
20 , tcPatSynBuilderBind )
21 import CoreSyn (Tickish (..))
22 import CostCentre (mkUserCC)
23 import DynFlags
24 import FastString
25 import HsSyn
26 import HscTypes( isHsBootOrSig )
27 import TcSigs
28 import TcRnMonad
29 import TcEnv
30 import TcUnify
31 import TcSimplify
32 import TcEvidence
33 import TcHsType
34 import TcPat
35 import TcMType
36 import Inst( deeplyInstantiate )
37 import FamInstEnv( normaliseType )
38 import FamInst( tcGetFamInstEnvs )
39 import TyCon
40 import TcType
41 import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder )
42 import TysPrim
43 import TysWiredIn( cTupleTyConName )
44 import Id
45 import Var
46 import VarSet
47 import VarEnv( TidyEnv )
48 import Module
49 import Name
50 import NameSet
51 import NameEnv
52 import SrcLoc
53 import Bag
54 import ListSetOps
55 import ErrUtils
56 import Digraph
57 import Maybes
58 import Util
59 import BasicTypes
60 import Outputable
61 import PrelNames( gHC_PRIM, ipClassName )
62 import TcValidity (checkValidType)
63 import Unique (getUnique)
64 import UniqFM
65 import qualified GHC.LanguageExtensions as LangExt
66
67 import Control.Monad
68
69 #include "HsVersions.h"
70
71 {- *********************************************************************
72 * *
73 A useful helper function
74 * *
75 ********************************************************************* -}
76
77 addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv
78 addTypecheckedBinds tcg_env binds
79 | isHsBootOrSig (tcg_src tcg_env) = tcg_env
80 -- Do not add the code for record-selector bindings
81 -- when compiling hs-boot files
82 | otherwise = tcg_env { tcg_binds = foldr unionBags
83 (tcg_binds tcg_env)
84 binds }
85
86 {-
87 ************************************************************************
88 * *
89 \subsection{Type-checking bindings}
90 * *
91 ************************************************************************
92
93 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
94 it needs to know something about the {\em usage} of the things bound,
95 so that it can create specialisations of them. So @tcBindsAndThen@
96 takes a function which, given an extended environment, E, typechecks
97 the scope of the bindings returning a typechecked thing and (most
98 important) an LIE. It is this LIE which is then used as the basis for
99 specialising the things bound.
100
101 @tcBindsAndThen@ also takes a "combiner" which glues together the
102 bindings and the "thing" to make a new "thing".
103
104 The real work is done by @tcBindWithSigsAndThen@.
105
106 Recursive and non-recursive binds are handled in essentially the same
107 way: because of uniques there are no scoping issues left. The only
108 difference is that non-recursive bindings can bind primitive values.
109
110 Even for non-recursive binding groups we add typings for each binder
111 to the LVE for the following reason. When each individual binding is
112 checked the type of its LHS is unified with that of its RHS; and
113 type-checking the LHS of course requires that the binder is in scope.
114
115 At the top-level the LIE is sure to contain nothing but constant
116 dictionaries, which we resolve at the module level.
117
118 Note [Polymorphic recursion]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
120 The game plan for polymorphic recursion in the code above is
121
122 * Bind any variable for which we have a type signature
123 to an Id with a polymorphic type. Then when type-checking
124 the RHSs we'll make a full polymorphic call.
125
126 This fine, but if you aren't a bit careful you end up with a horrendous
127 amount of partial application and (worse) a huge space leak. For example:
128
129 f :: Eq a => [a] -> [a]
130 f xs = ...f...
131
132 If we don't take care, after typechecking we get
133
134 f = /\a -> \d::Eq a -> let f' = f a d
135 in
136 \ys:[a] -> ...f'...
137
138 Notice the the stupid construction of (f a d), which is of course
139 identical to the function we're executing. In this case, the
140 polymorphic recursion isn't being used (but that's a very common case).
141 This can lead to a massive space leak, from the following top-level defn
142 (post-typechecking)
143
144 ff :: [Int] -> [Int]
145 ff = f Int dEqInt
146
147 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
148 f' is another thunk which evaluates to the same thing... and you end
149 up with a chain of identical values all hung onto by the CAF ff.
150
151 ff = f Int dEqInt
152
153 = let f' = f Int dEqInt in \ys. ...f'...
154
155 = let f' = let f' = f Int dEqInt in \ys. ...f'...
156 in \ys. ...f'...
157
158 Etc.
159
160 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
161 which would make the space leak go away in this case
162
163 Solution: when typechecking the RHSs we always have in hand the
164 *monomorphic* Ids for each binding. So we just need to make sure that
165 if (Method f a d) shows up in the constraints emerging from (...f...)
166 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
167 to the "givens" when simplifying constraints. That's what the "lies_avail"
168 is doing.
169
170 Then we get
171
172 f = /\a -> \d::Eq a -> letrec
173 fm = \ys:[a] -> ...fm...
174 in
175 fm
176 -}
177
178 tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv)
179 -- The TcGblEnv contains the new tcg_binds and tcg_spects
180 -- The TcLclEnv has an extended type envt for the new bindings
181 tcTopBinds binds sigs
182 = do { -- Pattern synonym bindings populate the global environment
183 (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
184 do { gbl <- getGblEnv
185 ; lcl <- getLclEnv
186 ; return (gbl, lcl) }
187 ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
188
189 ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
190 `addTypecheckedBinds` map snd binds' }
191
192 ; return (tcg_env', tcl_env) }
193 -- The top level bindings are flattened into a giant
194 -- implicitly-mutually-recursive LHsBinds
195
196 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
197 tcRecSelBinds (ValBindsOut binds sigs)
198 = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
199 do { (rec_sel_binds, tcg_env) <- discardWarnings $
200 tcValBinds TopLevel binds sigs getGblEnv
201 ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
202 ; return tcg_env' }
203 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
204
205 tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]
206 -- A hs-boot file has only one BindGroup, and it only has type
207 -- signatures in it. The renamer checked all this
208 tcHsBootSigs binds sigs
209 = do { checkTc (null binds) badBootDeclErr
210 ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
211 where
212 tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
213 where
214 f (L _ name)
215 = do { sigma_ty <- solveEqualities $
216 tcHsSigWcType (FunSigCtxt name False) hs_ty
217 ; return (mkVanillaGlobal name sigma_ty) }
218 -- Notice that we make GlobalIds, not LocalIds
219 tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
220
221 badBootDeclErr :: MsgDoc
222 badBootDeclErr = text "Illegal declarations in an hs-boot file"
223
224 ------------------------
225 tcLocalBinds :: HsLocalBinds Name -> TcM thing
226 -> TcM (HsLocalBinds TcId, thing)
227
228 tcLocalBinds EmptyLocalBinds thing_inside
229 = do { thing <- thing_inside
230 ; return (EmptyLocalBinds, thing) }
231
232 tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
233 = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
234 ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
235 tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
236
237 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
238 = do { ipClass <- tcLookupClass ipClassName
239 ; (given_ips, ip_binds') <-
240 mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
241
242 -- If the binding binds ?x = E, we must now
243 -- discharge any ?x constraints in expr_lie
244 -- See Note [Implicit parameter untouchables]
245 ; (ev_binds, result) <- checkConstraints (IPSkol ips)
246 [] given_ips thing_inside
247
248 ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
249 where
250 ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
251
252 -- I wonder if we should do these one at at time
253 -- Consider ?x = 4
254 -- ?y = ?x + 1
255 tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
256 = do { ty <- newOpenFlexiTyVarTy
257 ; let p = mkStrLitTy $ hsIPNameFS ip
258 ; ip_id <- newDict ipClass [ p, ty ]
259 ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
260 ; let d = toDict ipClass p ty `fmap` expr'
261 ; return (ip_id, (IPBind (Right ip_id) d)) }
262 tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
263
264 -- Coerces a `t` into a dictionry for `IP "x" t`.
265 -- co : t -> IP "x" t
266 toDict ipClass x ty = HsWrap $ mkWpCastR $
267 wrapIP $ mkClassPred ipClass [x,ty]
268
269 {- Note [Implicit parameter untouchables]
270 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
271 We add the type variables in the types of the implicit parameters
272 as untouchables, not so much because we really must not unify them,
273 but rather because we otherwise end up with constraints like this
274 Num alpha, Implic { wanted = alpha ~ Int }
275 The constraint solver solves alpha~Int by unification, but then
276 doesn't float that solved constraint out (it's not an unsolved
277 wanted). Result disaster: the (Num alpha) is again solved, this
278 time by defaulting. No no no.
279
280 However [Oct 10] this is all handled automatically by the
281 untouchable-range idea.
282
283 Note [Inlining and hs-boot files]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 Consider this example (Trac #10083):
286
287 ---------- RSR.hs-boot ------------
288 module RSR where
289 data RSR
290 eqRSR :: RSR -> RSR -> Bool
291
292 ---------- SR.hs ------------
293 module SR where
294 import {-# SOURCE #-} RSR
295 data SR = MkSR RSR
296 eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
297
298 ---------- RSR.hs ------------
299 module RSR where
300 import SR
301 data RSR = MkRSR SR -- deriving( Eq )
302 eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
303 foo x y = not (eqRSR x y)
304
305 When compiling RSR we get this code
306
307 RSR.eqRSR :: RSR -> RSR -> Bool
308 RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
309 case ds1 of _ { RSR.MkRSR s1 ->
310 case ds2 of _ { RSR.MkRSR s2 ->
311 SR.eqSR s1 s2 }}
312
313 RSR.foo :: RSR -> RSR -> Bool
314 RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)
315
316 Now, when optimising foo:
317 Inline eqRSR (small, non-rec)
318 Inline eqSR (small, non-rec)
319 but the result of inlining eqSR from SR is another call to eqRSR, so
320 everything repeats. Neither eqSR nor eqRSR are (apparently) loop
321 breakers.
322
323 Solution: when compiling RSR, add a NOINLINE pragma to every function
324 exported by the boot-file for RSR (if it exists).
325
326 ALAS: doing so makes the boostrappted GHC itself slower by 8% overall
327 (on Trac #9872a-d, and T1969. So I un-did this change, and
328 parked it for now. Sigh.
329 -}
330
331 tcValBinds :: TopLevelFlag
332 -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
333 -> TcM thing
334 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
335
336 tcValBinds top_lvl binds sigs thing_inside
337 = do { let patsyns = getPatSynBinds binds
338
339 -- Typecheck the signature
340 ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
341 tcTySigs sigs
342
343 ; _self_boot <- tcSelfBootInfo
344 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
345
346 -- ------- See Note [Inlining and hs-boot files] (change parked) --------
347 -- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files]
348 -- , SelfBoot { sb_ids = boot_id_names } <- self_boot
349 -- = foldNameSet add_no_inl prag_fn1 boot_id_names
350 -- | otherwise
351 -- = prag_fn1
352 -- add_no_inl boot_id_name prag_fn
353 -- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name)
354 -- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma)
355 -- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module")
356
357 -- Extend the envt right away with all the Ids
358 -- declared with complete type signatures
359 -- Do not extend the TcIdBinderStack; instead
360 -- we extend it on a per-rhs basis in tcExtendForRhs
361 ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
362 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
363 { thing <- thing_inside
364 -- See Note [Pattern synonym builders don't yield dependencies]
365 ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
366 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
367 ; return (extra_binds, thing) }
368 ; return (binds' ++ extra_binds', thing) }}
369
370 ------------------------
371 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
372 -> [(RecFlag, LHsBinds Name)] -> TcM thing
373 -> TcM ([(RecFlag, LHsBinds TcId)], thing)
374 -- Typecheck a whole lot of value bindings,
375 -- one strongly-connected component at a time
376 -- Here a "strongly connected component" has the strightforward
377 -- meaning of a group of bindings that mention each other,
378 -- ignoring type signatures (that part comes later)
379
380 tcBindGroups _ _ _ [] thing_inside
381 = do { thing <- thing_inside
382 ; return ([], thing) }
383
384 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
385 = do { -- See Note [Closed binder groups]
386 closed <- isClosedBndrGroup $ snd group
387 ; (group', (groups', thing))
388 <- tc_group top_lvl sig_fn prag_fn group closed $
389 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
390 ; return (group' ++ groups', thing) }
391
392 -- Note [Closed binder groups]
393 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
394 --
395 -- A mutually recursive group is "closed" if all of the free variables of
396 -- the bindings are closed. For example
397 --
398 -- > h = \x -> let f = ...g...
399 -- > g = ....f...x...
400 -- > in ...
401 --
402 -- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
403 -- closed.
404 --
405 -- So we need to compute closed-ness on each strongly connected components,
406 -- before we sub-divide it based on what type signatures it has.
407 --
408
409 ------------------------
410 tc_group :: forall thing.
411 TopLevelFlag -> TcSigFun -> TcPragEnv
412 -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> 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) closed 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 closed
428 thing_inside
429 ; return ( [(NonRecursive, bind')], thing) }
430
431 tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
432 = -- To maximise polymorphism, we do a new
433 -- strongly-connected-component analysis, this time omitting
434 -- any references to variables with type signatures.
435 -- (This used to be optional, but isn't now.)
436 -- See Note [Polymorphic recursion] in HsBinds.
437 do { traceTc "tc_group rec" (pprLHsBinds binds)
438 ; when hasPatSyn $ recursivePatSynErr binds
439 ; (binds1, thing) <- go sccs
440 ; return ([(Recursive, binds1)], thing) }
441 -- Rec them all together
442 where
443 hasPatSyn = anyBag (isPatSyn . unLoc) binds
444 isPatSyn PatSynBind{} = True
445 isPatSyn _ = False
446
447 sccs :: [SCC (LHsBind Name)]
448 sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
449
450 go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
451 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
452 ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1
453 (go sccs)
454 ; return (binds1 `unionBags` binds2, thing) }
455 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
456
457 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
458 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
459
460 tc_sub_group rec_tc binds =
461 tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
462
463 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
464 recursivePatSynErr binds
465 = failWithTc $
466 hang (text "Recursive pattern synonym definition with following bindings:")
467 2 (vcat $ map pprLBind . bagToList $ binds)
468 where
469 pprLoc loc = parens (text "defined at" <+> ppr loc)
470 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
471 pprLoc loc
472
473 tc_single :: forall thing.
474 TopLevelFlag -> TcSigFun -> TcPragEnv
475 -> LHsBind Name -> IsGroupClosed -> TcM thing
476 -> TcM (LHsBinds TcId, thing)
477 tc_single _top_lvl sig_fn _prag_fn
478 (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
479 _ thing_inside
480 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
481 ; thing <- setGblEnv tcg_env thing_inside
482 ; return (aux_binds, thing)
483 }
484 where
485 tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
486 tc_pat_syn_decl = case sig_fn name of
487 Nothing -> tcInferPatSynDecl psb
488 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
489 Just _ -> panic "tc_single"
490
491 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
492 = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
493 NonRecursive NonRecursive
494 closed
495 [lbind]
496 ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
497 ; return (binds1, thing) }
498
499 ------------------------
500 type BKey = Int -- Just number off the bindings
501
502 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
503 -- See Note [Polymorphic recursion] in HsBinds.
504 mkEdges sig_fn binds
505 = [ (bind, key, [key | n <- nonDetEltsUFM (bind_fvs (unLoc bind)),
506 Just key <- [lookupNameEnv key_map n], no_sig n ])
507 | (bind, key) <- keyd_binds
508 ]
509 -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
510 -- is still deterministic even if the edges are in nondeterministic order
511 -- as explained in Note [Deterministic SCC] in Digraph.
512 where
513 no_sig :: Name -> Bool
514 no_sig n = noCompleteSig (sig_fn n)
515
516 keyd_binds = bagToList binds `zip` [0::BKey ..]
517
518 key_map :: NameEnv BKey -- Which binding it comes from
519 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
520 , bndr <- collectHsBindBinders bind ]
521
522 ------------------------
523 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
524 -> RecFlag -- Whether the group is really recursive
525 -> RecFlag -- Whether it's recursive after breaking
526 -- dependencies based on type signatures
527 -> IsGroupClosed -- Whether the group is closed
528 -> [LHsBind Name] -- None are PatSynBind
529 -> TcM (LHsBinds TcId, [TcId])
530
531 -- Typechecks a single bunch of values bindings all together,
532 -- and generalises them. The bunch may be only part of a recursive
533 -- group, because we use type signatures to maximise polymorphism
534 --
535 -- Returns a list because the input may be a single non-recursive binding,
536 -- in which case the dependency order of the resulting bindings is
537 -- important.
538 --
539 -- Knows nothing about the scope of the bindings
540 -- None of the bindings are pattern synonyms
541
542 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
543 = setSrcSpan loc $
544 recoverM (recoveryCode binder_names sig_fn) $ do
545 -- Set up main recover; take advantage of any type sigs
546
547 { traceTc "------------------------------------------------" Outputable.empty
548 ; traceTc "Bindings for {" (ppr binder_names)
549 ; dflags <- getDynFlags
550 ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
551 ; traceTc "Generalisation plan" (ppr plan)
552 ; result@(tc_binds, poly_ids) <- case plan of
553 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
554 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
555 CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
556
557 -- Check whether strict bindings are ok
558 -- These must be non-recursive etc, and are not generalised
559 -- They desugar to a case expression in the end
560 ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
561 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
562 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
563 ])
564
565 ; return result }
566 where
567 binder_names = collectHsBindListBinders bind_list
568 loc = foldr1 combineSrcSpans (map getLoc bind_list)
569 -- The mbinds have been dependency analysed and
570 -- may no longer be adjacent; so find the narrowest
571 -- span that includes them all
572
573 --------------
574 -- If typechecking the binds fails, then return with each
575 -- signature-less binder given type (forall a.a), to minimise
576 -- subsequent error messages
577 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
578 recoveryCode binder_names sig_fn
579 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
580 ; let poly_ids = map mk_dummy binder_names
581 ; return (emptyBag, poly_ids) }
582 where
583 mk_dummy name
584 | Just sig <- sig_fn name
585 , Just poly_id <- completeSigPolyId_maybe sig
586 = poly_id
587 | otherwise
588 = mkLocalId name forall_a_a
589
590 forall_a_a :: TcType
591 forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
592
593 {- *********************************************************************
594 * *
595 tcPolyNoGen
596 * *
597 ********************************************************************* -}
598
599 tcPolyNoGen -- No generalisation whatsoever
600 :: RecFlag -- Whether it's recursive after breaking
601 -- dependencies based on type signatures
602 -> TcPragEnv -> TcSigFun
603 -> [LHsBind Name]
604 -> TcM (LHsBinds TcId, [TcId])
605
606 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
607 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
608 (LetGblBndr prag_fn)
609 bind_list
610 ; mono_ids' <- mapM tc_mono_info mono_infos
611 ; return (binds', mono_ids') }
612 where
613 tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
614 = do { mono_ty' <- zonkTcType (idType mono_id)
615 -- Zonk, mainly to expose unboxed types to checkStrictBinds
616 ; let mono_id' = setIdType mono_id mono_ty'
617 ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
618 ; return mono_id' }
619 -- NB: tcPrags generates error messages for
620 -- specialisation pragmas for non-overloaded sigs
621 -- Indeed that is why we call it here!
622 -- So we can safely ignore _specs
623
624
625 {- *********************************************************************
626 * *
627 tcPolyCheck
628 * *
629 ********************************************************************* -}
630
631 tcPolyCheck :: TcPragEnv
632 -> TcIdSigInfo -- Must be a complete signature
633 -> LHsBind Name -- Must be a FunBind
634 -> TcM (LHsBinds TcId, [TcId])
635 -- There is just one binding,
636 -- it is a Funbind
637 -- it has a complete type signature,
638 tcPolyCheck prag_fn
639 (CompleteSig { sig_bndr = poly_id
640 , sig_ctxt = ctxt
641 , sig_loc = sig_loc })
642 (L loc (FunBind { fun_id = L nm_loc name
643 , fun_matches = matches }))
644 = setSrcSpan sig_loc $
645 do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
646 ; (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars sig_loc) poly_id
647 -- See Note [Instantiate sig with fresh variables]
648
649 ; mono_name <- newNameAt (nameOccName name) nm_loc
650 ; ev_vars <- newEvVars theta
651 ; let mono_id = mkLocalId mono_name tau
652 skol_info = SigSkol ctxt (mkPhiTy theta tau)
653 skol_tvs = map snd tv_prs
654
655 ; (ev_binds, (co_fn, matches'))
656 <- checkConstraints skol_info skol_tvs ev_vars $
657 tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
658 tcExtendTyVarEnv2 tv_prs $
659 setSrcSpan loc $
660 tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
661
662 ; let prag_sigs = lookupPragEnv prag_fn name
663 ; spec_prags <- tcSpecPrags poly_id prag_sigs
664 ; poly_id <- addInlinePrags poly_id prag_sigs
665
666 ; mod <- getModule
667 ; let bind' = FunBind { fun_id = L nm_loc mono_id
668 , fun_matches = matches'
669 , fun_co_fn = co_fn
670 , bind_fvs = placeHolderNamesTc
671 , fun_tick = funBindTicks nm_loc mono_id mod prag_sigs }
672
673 abs_bind = L loc $ AbsBindsSig
674 { abs_sig_export = poly_id
675 , abs_tvs = skol_tvs
676 , abs_ev_vars = ev_vars
677 , abs_sig_prags = SpecPrags spec_prags
678 , abs_sig_ev_bind = ev_binds
679 , abs_sig_bind = L loc bind' }
680
681 ; return (unitBag abs_bind, [poly_id]) }
682
683 tcPolyCheck _prag_fn sig bind
684 = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
685
686 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig Name] -> [Tickish TcId]
687 funBindTicks loc fun_id mod sigs
688 | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
689 -- this can only be a singleton list, as duplicate pragmas are rejected
690 -- by the renamer
691 , let cc_str
692 | Just cc_str <- mb_cc_str
693 = sl_fs cc_str
694 | otherwise
695 = getOccFS (Var.varName fun_id)
696 cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
697 cc = mkUserCC cc_name mod loc (getUnique fun_id)
698 = [ProfNote cc True True]
699 | otherwise
700 = []
701
702 {- Note [Instantiate sig with fresh variables]
703 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
704 It's vital to instantiate a type signature with fresh variables.
705 For example:
706 type T = forall a. [a] -> [a]
707 f :: T;
708 f = g where { g :: T; g = <rhs> }
709
710 We must not use the same 'a' from the defn of T at both places!!
711 (Instantiation is only necessary because of type synonyms. Otherwise,
712 it's all cool; each signature has distinct type variables from the renamer.)
713 -}
714
715
716 {- *********************************************************************
717 * *
718 tcPolyInfer
719 * *
720 ********************************************************************* -}
721
722 tcPolyInfer
723 :: RecFlag -- Whether it's recursive after breaking
724 -- dependencies based on type signatures
725 -> TcPragEnv -> TcSigFun
726 -> Bool -- True <=> apply the monomorphism restriction
727 -> [LHsBind Name]
728 -> TcM (LHsBinds TcId, [TcId])
729 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
730 = do { (tclvl, wanted, (binds', mono_infos))
731 <- pushLevelAndCaptureConstraints $
732 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
733
734 ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
735 | info <- mono_infos ]
736 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
737 infer_mode = if mono then ApplyMR else NoRestrictions
738
739 ; mapM_ (checkOverloadedSig mono) sigs
740
741 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
742 ; (qtvs, givens, ev_binds)
743 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
744
745 ; let inferred_theta = map evVarPred givens
746 ; exports <- checkNoErrs $
747 mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
748
749 ; loc <- getSrcSpanM
750 ; let poly_ids = map abe_poly exports
751 abs_bind = L loc $
752 AbsBinds { abs_tvs = qtvs
753 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
754 , abs_exports = exports, abs_binds = binds' }
755
756 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
757 ; return (unitBag abs_bind, poly_ids) }
758 -- poly_ids are guaranteed zonked by mkExport
759
760 --------------
761 mkExport :: TcPragEnv
762 -> [TyVar] -> TcThetaType -- Both already zonked
763 -> MonoBindInfo
764 -> TcM (ABExport Id)
765 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
766 --
767 -- mkExport generates exports with
768 -- zonked type variables,
769 -- zonked poly_ids
770 -- The former is just because no further unifications will change
771 -- the quantified type variables, so we can fix their final form
772 -- right now.
773 -- The latter is needed because the poly_ids are used to extend the
774 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
775
776 -- Pre-condition: the qtvs and theta are already zonked
777
778 mkExport prag_fn qtvs theta
779 mono_info@(MBI { mbi_poly_name = poly_name
780 , mbi_sig = mb_sig
781 , mbi_mono_id = mono_id })
782 = do { mono_ty <- zonkTcType (idType mono_id)
783 ; poly_id <- mkInferredPolyId qtvs theta poly_name mb_sig mono_ty
784
785 -- NB: poly_id has a zonked type
786 ; poly_id <- addInlinePrags poly_id prag_sigs
787 ; spec_prags <- tcSpecPrags poly_id prag_sigs
788 -- tcPrags requires a zonked poly_id
789
790 -- See Note [Impedence matching]
791 -- NB: we have already done checkValidType, including an ambiguity check,
792 -- on the type; either when we checked the sig or in mkInferredPolyId
793 ; let poly_ty = idType poly_id
794 sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
795 -- This type is just going into tcSubType,
796 -- so Inferred vs. Specified doesn't matter
797
798 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
799 then return idHsWrapper -- Fast path; also avoids complaint when we infer
800 -- an ambiguouse type and have AllowAmbiguousType
801 -- e..g infer x :: forall a. F a -> Int
802 else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
803 tcSubType_NC sig_ctxt sel_poly_ty (mkCheckExpType poly_ty)
804
805 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
806 ; when warn_missing_sigs $
807 localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
808
809 ; return (ABE { abe_wrap = wrap
810 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
811 , abe_poly = poly_id
812 , abe_mono = mono_id
813 , abe_prags = SpecPrags spec_prags}) }
814 where
815 prag_sigs = lookupPragEnv prag_fn poly_name
816 sig_ctxt = InfSigCtxt poly_name
817
818 mkInferredPolyId :: [TyVar] -> TcThetaType
819 -> Name -> Maybe TcIdSigInst -> TcType
820 -> TcM TcId
821 mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty
822 | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
823 , CompleteSig { sig_bndr = poly_id } <- sig
824 = return poly_id
825
826 | otherwise -- Either no type sig or partial type sig
827 = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous
828 -- we don't carry on to the impedence matching, and generate
829 -- a duplicate ambiguity error. There is a similar
830 -- checkNoErrs for complete type signatures too.
831 do { fam_envs <- tcGetFamInstEnvs
832 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
833 -- Unification may not have normalised the type,
834 -- (see Note [Lazy flattening] in TcFlatten) so do it
835 -- here to make it as uncomplicated as possible.
836 -- Example: f :: [F Int] -> Bool
837 -- should be rewritten to f :: [Char] -> Bool, if possible
838 --
839 -- We can discard the coercion _co, because we'll reconstruct
840 -- it in the call to tcSubType below
841
842 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
843 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
844
845 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
846
847 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
848 , ppr inferred_poly_ty])
849 ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
850 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
851 -- See Note [Validity of inferred types]
852
853 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
854
855
856 chooseInferredQuantifiers :: TcThetaType -- inferred
857 -> TcTyVarSet -- tvs free in tau type
858 -> [TcTyVar] -- inferred quantified tvs
859 -> Maybe TcIdSigInst
860 -> TcM ([TyVarBinder], TcThetaType)
861 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
862 = -- No type signature (partial or complete) for this binder,
863 do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
864 -- Include kind variables! Trac #7916
865 my_theta = pickCapturedPreds free_tvs inferred_theta
866 binders = [ mkTyVarBinder Inferred tv
867 | tv <- qtvs
868 , tv `elemVarSet` free_tvs ]
869 ; return (binders, my_theta) }
870
871 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
872 (Just (TISI { sig_inst_sig = sig -- Always PartialSig
873 , sig_inst_wcx = wcx
874 , sig_inst_theta = annotated_theta
875 , sig_inst_skols = annotated_tvs }))
876 | Nothing <- wcx
877 = do { annotated_theta <- zonkTcTypes annotated_theta
878 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
879 `unionVarSet` tau_tvs)
880 ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs])
881 ; return (mk_binders free_tvs, annotated_theta) }
882
883 | Just wc_var <- wcx
884 = do { annotated_theta <- zonkTcTypes annotated_theta
885 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
886 `unionVarSet` tau_tvs)
887 my_theta = pickCapturedPreds free_tvs inferred_theta
888
889 -- Report the inferred constraints for an extra-constraints wildcard/hole as
890 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
891 -- case, the extra inferred constraints are accepted without complaining.
892 -- NB: inferred_theta already includes all the annotated constraints
893 inferred_diff = [ pred
894 | pred <- my_theta
895 , all (not . (`eqType` pred)) annotated_theta ]
896 ; ctuple <- mk_ctuple inferred_diff
897 ; writeMetaTyVar wc_var ctuple
898 ; traceTc "completeTheta" $
899 vcat [ ppr sig
900 , ppr annotated_theta, ppr inferred_theta
901 , ppr inferred_diff ]
902
903 ; return (mk_binders free_tvs, my_theta) }
904
905 | otherwise -- A complete type signature is dealt with in mkInferredPolyId
906 = pprPanic "chooseInferredQuantifiers" (ppr sig)
907
908 where
909 spec_tv_set = mkVarSet $ map snd annotated_tvs
910 mk_binders free_tvs
911 = [ mkTyVarBinder vis tv
912 | tv <- qtvs
913 , tv `elemVarSet` free_tvs
914 , let vis | tv `elemVarSet` spec_tv_set = Specified
915 | otherwise = Inferred ]
916 -- Pulling from qtvs maintains original order
917
918 mk_ctuple [pred] = return pred
919 mk_ctuple preds = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))
920 ; return (mkTyConApp tc preds) }
921
922 mk_impedence_match_msg :: MonoBindInfo
923 -> TcType -> TcType
924 -> TidyEnv -> TcM (TidyEnv, SDoc)
925 -- This is a rare but rather awkward error messages
926 mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
927 inf_ty sig_ty tidy_env
928 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
929 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
930 ; let msg = vcat [ text "When checking that the inferred type"
931 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
932 , text "is as general as its" <+> what <+> text "signature"
933 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
934 ; return (tidy_env2, msg) }
935 where
936 what = case mb_sig of
937 Nothing -> text "inferred"
938 Just sig | isPartialSig sig -> text "(partial)"
939 | otherwise -> empty
940
941
942 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
943 mk_inf_msg poly_name poly_ty tidy_env
944 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
945 ; let msg = vcat [ text "When checking the inferred type"
946 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
947 ; return (tidy_env1, msg) }
948
949
950 -- | Warn the user about polymorphic local binders that lack type signatures.
951 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
952 localSigWarn flag id mb_sig
953 | Just _ <- mb_sig = return ()
954 | not (isSigmaTy (idType id)) = return ()
955 | otherwise = warnMissingSignatures flag msg id
956 where
957 msg = text "Polymorphic local binding with no type signature:"
958
959 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
960 warnMissingSignatures flag msg id
961 = do { env0 <- tcInitTidyEnv
962 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
963 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
964 where
965 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
966
967 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
968 -- Example:
969 -- f :: Eq a => a -> a
970 -- K f = e
971 -- The MR applies, but the signature is overloaded, and it's
972 -- best to complain about this directly
973 -- c.f Trac #11339
974 checkOverloadedSig monomorphism_restriction_applies sig
975 | not (null (sig_inst_theta sig))
976 , monomorphism_restriction_applies
977 , let orig_sig = sig_inst_sig sig
978 = setSrcSpan (sig_loc orig_sig) $
979 failWith $
980 hang (text "Overloaded signature conflicts with monomorphism restriction")
981 2 (ppr orig_sig)
982 | otherwise
983 = return ()
984
985 {- Note [Partial type signatures and generalisation]
986 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
987 If /any/ of the signatures in the gropu is a partial type signature
988 f :: _ -> Int
989 then we *always* use the InferGen plan, and hence tcPolyInfer.
990 We do this even for a local binding with -XMonoLocalBinds, when
991 we normally use NoGen.
992
993 Reasons:
994 * The TcSigInfo for 'f' has a unification variable for the '_',
995 whose TcLevel is one level deeper than the current level.
996 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
997 the TcLevel like InferGen, so we lose the level invariant.
998
999 * The signature might be f :: forall a. _ -> a
1000 so it really is polymorphic. It's not clear what it would
1001 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
1002 in the (Just sig) case, checks that if there is a signature
1003 then we are using LetLclBndr, and hence a nested AbsBinds with
1004 increased TcLevel
1005
1006 It might be possible to fix these difficulties somehow, but there
1007 doesn't seem much point. Indeed, adding a partial type signature is a
1008 way to get per-binding inferred generalisation.
1009
1010 We apply the MR if /all/ of the partial signatures lack a context.
1011 In particular (Trac #11016):
1012 f2 :: (?loc :: Int) => _
1013 f2 = ?loc
1014 It's stupid to apply the MR here. This test includes an extra-constraints
1015 wildcard; that is, we don't apply the MR if you write
1016 f3 :: _ => blah
1017
1018 Note [Validity of inferred types]
1019 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1020 We need to check inferred type for validity, in case it uses language
1021 extensions that are not turned on. The principle is that if the user
1022 simply adds the inferred type to the program source, it'll compile fine.
1023 See #8883.
1024
1025 Examples that might fail:
1026 - the type might be ambiguous
1027
1028 - an inferred theta that requires type equalities e.g. (F a ~ G b)
1029 or multi-parameter type classes
1030 - an inferred type that includes unboxed tuples
1031
1032
1033 Note [Impedence matching]
1034 ~~~~~~~~~~~~~~~~~~~~~~~~~
1035 Consider
1036 f 0 x = x
1037 f n x = g [] (not x)
1038
1039 g [] y = f 10 y
1040 g _ y = f 9 y
1041
1042 After typechecking we'll get
1043 f_mono_ty :: a -> Bool -> Bool
1044 g_mono_ty :: [b] -> Bool -> Bool
1045 with constraints
1046 (Eq a, Num a)
1047
1048 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
1049 The types we really want for f and g are
1050 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
1051 g :: forall b. [b] -> Bool -> Bool
1052
1053 We can get these by "impedance matching":
1054 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
1055 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
1056
1057 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
1058 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
1059
1060 Suppose the shared quantified tyvars are qtvs and constraints theta.
1061 Then we want to check that
1062 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1063 and the proof is the impedance matcher.
1064
1065 Notice that the impedance matcher may do defaulting. See Trac #7173.
1066
1067 It also cleverly does an ambiguity check; for example, rejecting
1068 f :: F a -> F a
1069 where F is a non-injective type function.
1070 -}
1071
1072 {- *********************************************************************
1073 * *
1074 Vectorisation
1075 * *
1076 ********************************************************************* -}
1077
1078 tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
1079 tcVectDecls decls
1080 = do { decls' <- mapM (wrapLocM tcVect) decls
1081 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1082 dups = findDupsEq (==) ids
1083 ; mapM_ reportVectDups dups
1084 ; traceTcConstraints "End of tcVectDecls"
1085 ; return decls'
1086 }
1087 where
1088 reportVectDups (first:_second:_more)
1089 = addErrAt (getSrcSpan first) $
1090 text "Duplicate vectorisation declarations for" <+> ppr first
1091 reportVectDups _ = return ()
1092
1093 --------------
1094 tcVect :: VectDecl Name -> TcM (VectDecl TcId)
1095 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1096 -- type of the original definition as this requires internals of the vectoriser not available
1097 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1098 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1099 -- from the vectoriser here.
1100 tcVect (HsVect s name rhs)
1101 = addErrCtxt (vectCtxt name) $
1102 do { var <- wrapLocM tcLookupId name
1103 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1104 ; rhs_id <- tcLookupId rhs_var_name
1105 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1106 }
1107
1108 tcVect (HsNoVect s name)
1109 = addErrCtxt (vectCtxt name) $
1110 do { var <- wrapLocM tcLookupId name
1111 ; return $ HsNoVect s var
1112 }
1113 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1114 = addErrCtxt (vectCtxt lname) $
1115 do { tycon <- tcLookupLocatedTyCon lname
1116 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1117 || isJust rhs_name -- or we explicitly provide a vectorised type
1118 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1119 )
1120 scalarTyConMustBeNullary
1121
1122 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1123 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1124 }
1125 tcVect (HsVectTypeOut _ _ _)
1126 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1127 tcVect (HsVectClassIn _ lname)
1128 = addErrCtxt (vectCtxt lname) $
1129 do { cls <- tcLookupLocatedClass lname
1130 ; return $ HsVectClassOut cls
1131 }
1132 tcVect (HsVectClassOut _)
1133 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1134 tcVect (HsVectInstIn linstTy)
1135 = addErrCtxt (vectCtxt linstTy) $
1136 do { (cls, tys) <- tcHsVectInst linstTy
1137 ; inst <- tcLookupInstance cls tys
1138 ; return $ HsVectInstOut inst
1139 }
1140 tcVect (HsVectInstOut _)
1141 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1142
1143 vectCtxt :: Outputable thing => thing -> SDoc
1144 vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
1145
1146 scalarTyConMustBeNullary :: MsgDoc
1147 scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
1148
1149 {-
1150 Note [SPECIALISE pragmas]
1151 ~~~~~~~~~~~~~~~~~~~~~~~~~
1152 There is no point in a SPECIALISE pragma for a non-overloaded function:
1153 reverse :: [a] -> [a]
1154 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1155
1156 But SPECIALISE INLINE *can* make sense for GADTS:
1157 data Arr e where
1158 ArrInt :: !Int -> ByteArray# -> Arr Int
1159 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1160
1161 (!:) :: Arr e -> Int -> e
1162 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1163 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1164 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1165 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1166
1167 When (!:) is specialised it becomes non-recursive, and can usefully
1168 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1169 for a non-overloaded function.
1170
1171 ************************************************************************
1172 * *
1173 tcMonoBinds
1174 * *
1175 ************************************************************************
1176
1177 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1178 The signatures have been dealt with already.
1179
1180 Note [Pattern bindings]
1181 ~~~~~~~~~~~~~~~~~~~~~~~
1182 The rule for typing pattern bindings is this:
1183
1184 ..sigs..
1185 p = e
1186
1187 where 'p' binds v1..vn, and 'e' may mention v1..vn,
1188 typechecks exactly like
1189
1190 ..sigs..
1191 x = e -- Inferred type
1192 v1 = case x of p -> v1
1193 ..
1194 vn = case x of p -> vn
1195
1196 Note that
1197 (f :: forall a. a -> a) = id
1198 should not typecheck because
1199 case id of { (f :: forall a. a->a) -> f }
1200 will not typecheck.
1201
1202 Note [Instantiate when inferring a type]
1203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1204 Consider
1205 f = (*)
1206 As there is no incentive to instantiate the RHS, tcMonoBinds will
1207 produce a type of forall a. Num a => a -> a -> a for `f`. This will then go
1208 through simplifyInfer and such, remaining unchanged.
1209
1210 There are two problems with this:
1211 1) If the definition were `g _ = (*)`, we get a very unusual type of
1212 `forall {a}. a -> forall b. Num b => b -> b -> b` for `g`. This is
1213 surely confusing for users.
1214
1215 2) The monomorphism restriction can't work. The MR is dealt with in
1216 simplifyInfer, and simplifyInfer has no way of instantiating. This
1217 could perhaps be worked around, but it may be hard to know even
1218 when instantiation should happen.
1219
1220 There is an easy solution to both problems: instantiate (deeply) when
1221 inferring a type. So that's what we do. Note that this decision is
1222 user-facing.
1223
1224 We do this deep instantiation in tcMonoBinds, in the FunBind case
1225 only, and only when we do not have a type signature. Conveniently,
1226 the fun_co_fn field of FunBind gives a place to record the coercion.
1227
1228 We do not need to do this
1229 * for PatBinds, because we don't have a function type
1230 * for FunBinds where we have a signature, bucause we aren't doing inference
1231 -}
1232
1233 data MonoBindInfo = MBI { mbi_poly_name :: Name
1234 , mbi_sig :: Maybe TcIdSigInst
1235 , mbi_mono_id :: TcId }
1236
1237 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1238 -- i.e. the binders are mentioned in their RHSs, and
1239 -- we are not rescued by a type signature
1240 -> TcSigFun -> LetBndrSpec
1241 -> [LHsBind Name]
1242 -> TcM (LHsBinds TcId, [MonoBindInfo])
1243 tcMonoBinds is_rec sig_fn no_gen
1244 [ L b_loc (FunBind { fun_id = L nm_loc name,
1245 fun_matches = matches, bind_fvs = fvs })]
1246 -- Single function binding,
1247 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1248 , Nothing <- sig_fn name -- ...with no type signature
1249 = -- In this very special case we infer the type of the
1250 -- right hand side first (it may have a higher-rank type)
1251 -- and *then* make the monomorphic Id for the LHS
1252 -- e.g. f = \(x::forall a. a->a) -> <body>
1253 -- We want to infer a higher-rank type for f
1254 setSrcSpan b_loc $
1255 do { rhs_ty <- newOpenInferExpType
1256 ; (co_fn, matches')
1257 <- tcExtendIdBndrs [TcIdBndr_ExpType name rhs_ty NotTopLevel] $
1258 -- We extend the error context even for a non-recursive
1259 -- function so that in type error messages we show the
1260 -- type of the thing whose rhs we are type checking
1261 tcMatchesFun (L nm_loc name) matches rhs_ty
1262 ; rhs_ty <- readExpType rhs_ty
1263
1264 -- Deeply instantiate the inferred type
1265 -- See Note [Instantiate when inferring a type]
1266 ; let orig = matchesCtOrigin matches
1267 ; rhs_ty <- zonkTcType rhs_ty -- NB: zonk to uncover any foralls
1268 ; (inst_wrap, rhs_ty) <- addErrCtxtM (instErrCtxt name rhs_ty) $
1269 deeplyInstantiate orig rhs_ty
1270
1271 ; mono_id <- newLetBndr no_gen name rhs_ty
1272 ; return (unitBag $ L b_loc $
1273 FunBind { fun_id = L nm_loc mono_id,
1274 fun_matches = matches', bind_fvs = fvs,
1275 fun_co_fn = inst_wrap <.> co_fn, fun_tick = [] },
1276 [MBI { mbi_poly_name = name
1277 , mbi_sig = Nothing
1278 , mbi_mono_id = mono_id }]) }
1279
1280 tcMonoBinds _ sig_fn no_gen binds
1281 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1282
1283 -- Bring the monomorphic Ids, into scope for the RHSs
1284 ; let mono_infos = getMonoBindInfo tc_binds
1285 rhs_id_env = [ (name, mono_id)
1286 | MBI { mbi_poly_name = name
1287 , mbi_sig = mb_sig
1288 , mbi_mono_id = mono_id } <- mono_infos
1289 , case mb_sig of
1290 Just sig -> isPartialSig sig
1291 Nothing -> True ]
1292 -- A monomorphic binding for each term variable that lacks
1293 -- a complete type sig. (Ones with a sig are already in scope.)
1294
1295 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1296 | (n,id) <- rhs_id_env]
1297 ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
1298 mapM (wrapLocM tcRhs) tc_binds
1299
1300 ; return (listToBag binds', mono_infos) }
1301
1302
1303 ------------------------
1304 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1305 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1306 -- if there's a signature for it, use the instantiated signature type
1307 -- otherwise invent a type variable
1308 -- You see that quite directly in the FunBind case.
1309 --
1310 -- But there's a complication for pattern bindings:
1311 -- data T = MkT (forall a. a->a)
1312 -- MkT f = e
1313 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1314 -- but we want to get (f::forall a. a->a) as the RHS environment.
1315 -- The simplest way to do this is to typecheck the pattern, and then look up the
1316 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1317 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1318
1319 data TcMonoBind -- Half completed; LHS done, RHS not done
1320 = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
1321 | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1322
1323 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1324 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1325 = do { mono_info <- tcLhsId sig_fn no_gen name
1326 ; return (TcFunBind mono_info nm_loc matches) }
1327
1328 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1329 = do { let bndr_names = collectPatBinders pat
1330 ; mbis <- mapM (tcLhsId sig_fn no_gen) bndr_names
1331 -- See Note [Existentials in pattern bindings]
1332
1333 ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
1334 bndr_names `zip` map mbi_mono_id mbis
1335
1336 ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
1337 | mbi <- mbis, let id = mbi_mono_id mbi ]
1338 $$ ppr no_gen)
1339
1340 ; ((pat', _), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1341 tcInfer $ \ exp_ty ->
1342 tcLetPat inst_sig_fun pat exp_ty $
1343 return () -- mapM (lookup_info inst_sig_fun) bndr_names
1344
1345 ; return (TcPatBind mbis pat' grhss pat_ty) }
1346
1347 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1348 -- AbsBind, VarBind impossible
1349
1350 -------------------
1351 data LetBndrSpec
1352 = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds
1353 -- so clone a fresh binder for the local monomorphic Id
1354
1355 | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going
1356 -- to be an AbsBinds; So we must bind the global version
1357 -- of the binder right away.
1358 -- And here is the inline-pragma information
1359
1360 instance Outputable LetBndrSpec where
1361 ppr LetLclBndr = text "LetLclBndr"
1362 ppr (LetGblBndr {}) = text "LetGblBndr"
1363
1364 tcLhsId :: TcSigFun -> LetBndrSpec -> Name -> TcM MonoBindInfo
1365 tcLhsId sig_fn no_gen name
1366 | Just (TcIdSig sig) <- sig_fn name
1367 = -- A partial type signature on a FunBind, in a mixed group
1368 -- e.g. f :: _ -> _
1369 -- f x = ...g...
1370 -- Just g = ...f...
1371 -- Hence always typechecked with InferGen; hence LetLclBndr
1372 --
1373 -- A compelete type sig on a FunBind is checked with CheckGen
1374 -- and does not go via tcLhsId
1375 do { inst_sig <- tcInstSig sig
1376 ; the_id <- newSigLetBndr no_gen name inst_sig
1377 ; return (MBI { mbi_poly_name = name
1378 , mbi_sig = Just inst_sig
1379 , mbi_mono_id = the_id }) }
1380
1381 | otherwise
1382 = -- No type signature, plan InferGen (LetLclBndr) or NoGen (LetGblBndr)
1383 do { mono_ty <- newOpenFlexiTyVarTy
1384 ; mono_id <- newLetBndr no_gen name mono_ty
1385 ; return (MBI { mbi_poly_name = name
1386 , mbi_sig = Nothing
1387 , mbi_mono_id = mono_id }) }
1388
1389 ------------
1390 newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
1391 newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
1392 | CompleteSig { sig_bndr = poly_id } <- id_sig
1393 = addInlinePrags poly_id (lookupPragEnv prags name)
1394 newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
1395 = newLetBndr no_gen name tau
1396
1397 newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
1398 -- In the polymorphic case when we are going to generalise
1399 -- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"
1400 -- of the Id; the original name will be bound to the polymorphic version
1401 -- by the AbsBinds
1402 -- In the monomorphic case when we are not going to generalise
1403 -- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,
1404 -- and we use the original name directly
1405 newLetBndr LetLclBndr name ty
1406 = do { mono_name <- cloneLocalName name
1407 ; return (mkLocalId mono_name ty) }
1408 newLetBndr (LetGblBndr prags) name ty
1409 = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)
1410
1411 -------------------
1412 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
1413 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1414 loc matches)
1415 = tcExtendIdBinderStackForRhs [info] $
1416 tcExtendTyVarEnvForRhs mb_sig $
1417 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1418 ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
1419 matches (mkCheckExpType $ idType mono_id)
1420 ; return ( FunBind { fun_id = L loc mono_id
1421 , fun_matches = matches'
1422 , fun_co_fn = co_fn
1423 , bind_fvs = placeHolderNamesTc
1424 , fun_tick = [] } ) }
1425
1426 tcRhs (TcPatBind infos pat' grhss pat_ty)
1427 = -- When we are doing pattern bindings we *don't* bring any scoped
1428 -- type variables into scope unlike function bindings
1429 -- Wny not? They are not completely rigid.
1430 -- That's why we have the special case for a single FunBind in tcMonoBinds
1431 tcExtendIdBinderStackForRhs infos $
1432 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1433 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1434 tcGRHSsPat grhss pat_ty
1435 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1436 , pat_rhs_ty = pat_ty
1437 , bind_fvs = placeHolderNamesTc
1438 , pat_ticks = ([],[]) } )}
1439
1440 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
1441 tcExtendTyVarEnvForRhs Nothing thing_inside
1442 = thing_inside
1443 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1444 = tcExtendTyVarEnvFromSig sig thing_inside
1445
1446 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
1447 tcExtendTyVarEnvFromSig sig_inst thing_inside
1448 | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
1449 = tcExtendTyVarEnv2 wcs $
1450 tcExtendTyVarEnv2 skol_prs $
1451 thing_inside
1452
1453 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1454 -- Extend the TcIdBinderStack for the RHS of the binding, with
1455 -- the monomorphic Id. That way, if we have, say
1456 -- f = \x -> blah
1457 -- and something goes wrong in 'blah', we get a "relevant binding"
1458 -- looking like f :: alpha -> beta
1459 -- This applies if 'f' has a type signature too:
1460 -- f :: forall a. [a] -> [a]
1461 -- f x = True
1462 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1463 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1464 -- would not be reported as relevant, because its type is closed
1465 tcExtendIdBinderStackForRhs infos thing_inside
1466 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
1467 | MBI { mbi_mono_id = mono_id } <- infos ]
1468 thing_inside
1469 -- NotTopLevel: it's a monomorphic binding
1470
1471 ---------------------
1472 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1473 getMonoBindInfo tc_binds
1474 = foldr (get_info . unLoc) [] tc_binds
1475 where
1476 get_info (TcFunBind info _ _) rest = info : rest
1477 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1478
1479 {- Note [Existentials in pattern bindings]
1480 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1481 Consider (typecheck/should_compile/ExPat):
1482 data T where
1483 MkT :: Integral a => a -> Int -> T
1484
1485 and suppose t :: T. Which of these pattern bindings are ok?
1486
1487 E1. let { MkT p _ = t } in <body>
1488
1489 E2. let { MkT _ q = t } in <body>
1490
1491 E3. let { MkT (toInteger -> r) _ = t } in <body>
1492
1493 Well (E1) is clearly wrong because the existential 'a' escapes.
1494 What type could 'p' possibly have?
1495
1496 But (E2) is fine, despite the existential pattern, because
1497 q::Int, and nothing escapes.
1498
1499 Even (E3) is fine. The existential pattern binds a dictionary
1500 for (Integral a) which the view pattern can use to convert the
1501 a-valued field to an Integer, so r :: Integer.
1502
1503 An easy way to see all three is to imagine the desugaring.
1504 For (2) it would look like
1505 let q = case t of MkT _ q' -> q'
1506 in <body>
1507
1508 We typecheck pattern bindings as follows:
1509 1. In tcLhs we bind q'::alpha, for each variable q bound by the
1510 pattern, where q' is a fresh name, and alpha is a fresh
1511 unification variable; it will be the monomorphic verion of q that
1512 we later generalise
1513
1514 It's very important that these fresh unification variables
1515 alpha are born here, not deep under implications as would happen
1516 if we allocated them when we encountered q during tcPat.
1517
1518 2. Still in tcLhs, we build a little environment mappting "q" ->
1519 q':alpha, and pass that to tcLetPet.
1520
1521 3. Then tcLhs invokes tcLetPat to typecheck the patter as usual:
1522 - When tcLetPat finds an existential constructor, it binds fresh
1523 type variables and dictionaries as usual, and emits an
1524 implication constraint.
1525
1526 - When tcLetPat finds a variable (TcPat.tcPatBndr) it looks it up
1527 in the little environment, which should always succeed. And
1528 uses tcSubTypeET to connect the type of that variable with the
1529 expected type of the pattern.
1530
1531 And that's it! The implication constraints check for the skolem
1532 escape. It's quite simple and neat, and more exressive than before
1533 e.g. GHC 8.0 rejects (E2) and (E3).
1534
1535
1536 ************************************************************************
1537 * *
1538 Generalisation
1539 * *
1540 ********************************************************************* -}
1541
1542 data GeneralisationPlan
1543 = NoGen -- No generalisation, no AbsBinds
1544
1545 | InferGen -- Implicit generalisation; there is an AbsBinds
1546 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1547
1548 | CheckGen (LHsBind Name) TcIdSigInfo
1549 -- One FunBind with a signature
1550 -- Explicit generalisation; there is an AbsBindsSig
1551
1552 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1553 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1554
1555 instance Outputable GeneralisationPlan where
1556 ppr NoGen = text "NoGen"
1557 ppr (InferGen b) = text "InferGen" <+> ppr b
1558 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1559
1560 decideGeneralisationPlan
1561 :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun
1562 -> GeneralisationPlan
1563 decideGeneralisationPlan dflags lbinds closed sig_fn
1564 | unlifted_pat_binds = NoGen
1565 | has_partial_sigs = InferGen (and partial_sig_mrs)
1566 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1567 | mono_local_binds closed = NoGen
1568 | otherwise = InferGen mono_restriction
1569 where
1570 binds = map unLoc lbinds
1571
1572 partial_sig_mrs :: [Bool]
1573 -- One for each parital signature (so empty => no partial sigs)
1574 -- The Bool is True if the signature has no constraint context
1575 -- so we should apply the MR
1576 -- See Note [Partial type signatures and generalisation]
1577 partial_sig_mrs
1578 = [ null theta
1579 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1580 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1581 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1582
1583 has_partial_sigs = not (null partial_sig_mrs)
1584 unlifted_pat_binds = any isUnliftedHsBind binds
1585 -- Unlifted patterns (unboxed tuple) must not
1586 -- be polymorphic, because we are going to force them
1587 -- See Trac #4498, #8762
1588
1589 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1590 && any restricted binds
1591
1592 mono_local_binds ClosedGroup = False
1593 mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags
1594
1595 -- With OutsideIn, all nested bindings are monomorphic
1596 -- except a single function binding with a signature
1597 one_funbind_with_sig
1598 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1599 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1600 = Just (lbind, sig)
1601 | otherwise
1602 = Nothing
1603
1604 -- The Haskell 98 monomorphism restriction
1605 restricted (PatBind {}) = True
1606 restricted (VarBind { var_id = v }) = no_sig v
1607 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1608 && no_sig (unLoc v)
1609 restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
1610 restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
1611 restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
1612
1613 restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
1614 restricted_match _ = False
1615 -- No args => like a pattern binding
1616 -- Some args => a function binding
1617
1618 no_sig n = noCompleteSig (sig_fn n)
1619
1620 isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed
1621 isClosedBndrGroup binds = do
1622 type_env <- getLclTypeEnv
1623 if foldUFM (is_closed_ns type_env) True fv_env
1624 then return ClosedGroup
1625 else return $ NonClosedGroup fv_env
1626 where
1627 fv_env :: NameEnv NameSet
1628 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1629
1630 bindFvs :: HsBindLR Name idR -> [(Name, NameSet)]
1631 bindFvs (FunBind { fun_id = f, bind_fvs = fvs })
1632 = [(unLoc f, fvs)]
1633 bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
1634 = [(b, fvs) | b <- collectPatBinders pat]
1635 bindFvs _
1636 = []
1637
1638 is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
1639 is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
1640 -- ns are the Names referred to from the RHS of this bind
1641
1642 is_closed_id :: TcTypeEnv -> Name -> Bool
1643 -- See Note [Bindings with closed types] in TcRnTypes
1644 is_closed_id type_env name
1645 | Just thing <- lookupNameEnv type_env name
1646 = case thing of
1647 ATcId { tct_info = ClosedLet } -> True -- This is the key line
1648 ATcId {} -> False
1649 ATyVar {} -> False -- In-scope type variables
1650 AGlobal {} -> True -- are not closed!
1651 _ -> pprPanic "is_closed_id" (ppr name)
1652 | otherwise
1653 = True
1654 -- The free-var set for a top level binding mentions
1655 -- imported things too, so that we can report unused imports
1656 -- These won't be in the local type env.
1657 -- Ditto class method etc from the current module
1658
1659 -------------------
1660 checkStrictBinds :: TopLevelFlag -> RecFlag
1661 -> [LHsBind Name]
1662 -> LHsBinds TcId -> [Id]
1663 -> TcM ()
1664 -- Check that non-overloaded unlifted bindings are
1665 -- a) non-recursive,
1666 -- b) not top level,
1667 -- c) not a multiple-binding group (more or less implied by (a))
1668
1669 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
1670 | any_unlifted_bndr || any_strict_pat -- This binding group must be matched strictly
1671 = do { check (isNotTopLevel top_lvl)
1672 (strictBindErr "Top-level" any_unlifted_bndr orig_binds)
1673 ; check (isNonRec rec_group)
1674 (strictBindErr "Recursive" any_unlifted_bndr orig_binds)
1675
1676 ; check (all is_monomorphic (bagToList tc_binds))
1677 (polyBindErr orig_binds)
1678 -- data Ptr a = Ptr Addr#
1679 -- f x = let p@(Ptr y) = ... in ...
1680 -- Here the binding for 'p' is polymorphic, but does
1681 -- not mix with an unlifted binding for 'y'. You should
1682 -- use a bang pattern. Trac #6078.
1683
1684 ; check (isSingleton orig_binds)
1685 (strictBindErr "Multiple" any_unlifted_bndr orig_binds)
1686
1687 -- Complain about a binding that looks lazy
1688 -- e.g. let I# y = x in ...
1689 -- Remember, in checkStrictBinds we are going to do strict
1690 -- matching, so (for software engineering reasons) we insist
1691 -- that the strictness is manifest on each binding
1692 -- However, lone (unboxed) variables are ok
1693 ; check (not any_pat_looks_lazy)
1694 (unliftedMustBeBang orig_binds) }
1695 | otherwise
1696 = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
1697 return ()
1698 where
1699 any_unlifted_bndr = any is_unlifted poly_ids
1700 any_strict_pat = any (isUnliftedHsBind . unLoc) orig_binds
1701 any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
1702
1703 is_unlifted id = case tcSplitSigmaTy (idType id) of
1704 (_, _, rho) -> isUnliftedType rho
1705 -- For the is_unlifted check, we need to look inside polymorphism
1706 -- and overloading. E.g. x = (# 1, True #)
1707 -- would get type forall a. Num a => (# a, Bool #)
1708 -- and we want to reject that. See Trac #9140
1709
1710 is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
1711 = null tvs && null evs
1712 is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
1713 = null tvs && null evs
1714 is_monomorphic _ = True
1715
1716 check :: Bool -> MsgDoc -> TcM ()
1717 -- Just like checkTc, but with a special case for module GHC.Prim:
1718 -- see Note [Compiling GHC.Prim]
1719 check True _ = return ()
1720 check False err = do { mod <- getModule
1721 ; checkTc (mod == gHC_PRIM) err }
1722
1723 unliftedMustBeBang :: [LHsBind Name] -> SDoc
1724 unliftedMustBeBang binds
1725 = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
1726 2 (vcat (map ppr binds))
1727
1728 polyBindErr :: [LHsBind Name] -> SDoc
1729 polyBindErr binds
1730 = hang (text "You can't mix polymorphic and unlifted bindings")
1731 2 (vcat [vcat (map ppr binds),
1732 text "Probable fix: add a type signature"])
1733
1734 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
1735 strictBindErr flavour any_unlifted_bndr binds
1736 = hang (text flavour <+> msg <+> text "aren't allowed:")
1737 2 (vcat (map ppr binds))
1738 where
1739 msg | any_unlifted_bndr = text "bindings for unlifted types"
1740 | otherwise = text "bang-pattern or unboxed-tuple bindings"
1741
1742
1743 {- Note [Compiling GHC.Prim]
1744 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1745 Module GHC.Prim has no source code: it is the host module for
1746 primitive, built-in functions and types. However, for Haddock-ing
1747 purposes we generate (via utils/genprimopcode) a fake source file
1748 GHC/Prim.hs, and give it to Haddock, so that it can generate
1749 documentation. It contains definitions like
1750 nullAddr# :: NullAddr#
1751 which would normally be rejected as a top-level unlifted binding. But
1752 we don't want to complain, because we are only "compiling" this fake
1753 mdule for documentation purposes. Hence this hacky test for gHC_PRIM
1754 in checkStrictBinds.
1755
1756 (We only make the test if things look wrong, so there is no cost in
1757 the common case.) -}
1758
1759
1760 {- *********************************************************************
1761 * *
1762 Error contexts and messages
1763 * *
1764 ********************************************************************* -}
1765
1766 -- This one is called on LHS, when pat and grhss are both Name
1767 -- and on RHS, when pat is TcId and grhss is still Name
1768 patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
1769 => LPat id -> GRHSs Name body -> SDoc
1770 patMonoBindsCtxt pat grhss
1771 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
1772
1773 instErrCtxt :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
1774 instErrCtxt name ty env
1775 = do { let (env', ty') = tidyOpenType env ty
1776 ; return (env', hang (text "When instantiating" <+> quotes (ppr name) <>
1777 text ", initially inferred to have" $$
1778 text "this overly-general type:")
1779 2 (ppr ty') $$
1780 extra) }
1781 where
1782 extra = sdocWithDynFlags $ \dflags ->
1783 ppWhen (xopt LangExt.MonomorphismRestriction dflags) $
1784 text "NB: This instantiation can be caused by the" <+>
1785 text "monomorphism restriction."