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