Make better "fake tycons" in error recovery
[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
12 module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
13 tcHsBootSigs, tcPolyCheck,
14 addTypecheckedBinds,
15 chooseInferredQuantifiers,
16 badBootDeclErr ) where
17
18 import GhcPrelude
19
20 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
21 import {-# SOURCE #-} TcExpr ( tcMonoExpr )
22 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
23 , 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 (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 | L _ (IPBind _ (Left (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 (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 _ (XCIPBind _) = 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 { let patsyns = getPatSynBinds binds
396
397 -- Typecheck the signature
398 ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
399 tcTySigs sigs
400
401 ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
402
403 -- Extend the envt right away with all the Ids
404 -- declared with complete type signatures
405 -- Do not extend the TcBinderStack; instead
406 -- we extend it on a per-rhs basis in tcExtendForRhs
407 ; tcExtendSigIds top_lvl poly_ids $ do
408 { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
409 { thing <- thing_inside
410 -- See Note [Pattern synonym builders don't yield dependencies]
411 -- in RnBinds
412 ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
413 ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
414 ; return (extra_binds, thing) }
415 ; return (binds' ++ extra_binds', thing) }}
416
417 ------------------------
418 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
419 -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
420 -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
421 -- Typecheck a whole lot of value bindings,
422 -- one strongly-connected component at a time
423 -- Here a "strongly connected component" has the strightforward
424 -- meaning of a group of bindings that mention each other,
425 -- ignoring type signatures (that part comes later)
426
427 tcBindGroups _ _ _ [] thing_inside
428 = do { thing <- thing_inside
429 ; return ([], thing) }
430
431 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
432 = do { -- See Note [Closed binder groups]
433 type_env <- getLclTypeEnv
434 ; let closed = isClosedBndrGroup type_env (snd group)
435 ; (group', (groups', thing))
436 <- tc_group top_lvl sig_fn prag_fn group closed $
437 tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
438 ; return (group' ++ groups', thing) }
439
440 -- Note [Closed binder groups]
441 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 --
443 -- A mutually recursive group is "closed" if all of the free variables of
444 -- the bindings are closed. For example
445 --
446 -- > h = \x -> let f = ...g...
447 -- > g = ....f...x...
448 -- > in ...
449 --
450 -- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
451 -- closed.
452 --
453 -- So we need to compute closed-ness on each strongly connected components,
454 -- before we sub-divide it based on what type signatures it has.
455 --
456
457 ------------------------
458 tc_group :: forall thing.
459 TopLevelFlag -> TcSigFun -> TcPragEnv
460 -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
461 -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
462
463 -- Typecheck one strongly-connected component of the original program.
464 -- We get a list of groups back, because there may
465 -- be specialisations etc as well
466
467 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
468 -- A single non-recursive binding
469 -- We want to keep non-recursive things non-recursive
470 -- so that we desugar unlifted bindings correctly
471 = do { let bind = case bagToList binds of
472 [bind] -> bind
473 [] -> panic "tc_group: empty list of binds"
474 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
475 ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
476 thing_inside
477 ; return ( [(NonRecursive, bind')], thing) }
478
479 tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
480 = -- To maximise polymorphism, we do a new
481 -- strongly-connected-component analysis, this time omitting
482 -- any references to variables with type signatures.
483 -- (This used to be optional, but isn't now.)
484 -- See Note [Polymorphic recursion] in HsBinds.
485 do { traceTc "tc_group rec" (pprLHsBinds binds)
486 ; when hasPatSyn $ recursivePatSynErr binds
487 ; (binds1, thing) <- go sccs
488 ; return ([(Recursive, binds1)], thing) }
489 -- Rec them all together
490 where
491 hasPatSyn = anyBag (isPatSyn . unLoc) binds
492 isPatSyn PatSynBind{} = True
493 isPatSyn _ = False
494
495 sccs :: [SCC (LHsBind GhcRn)]
496 sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
497
498 go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)
499 go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
500 ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn
501 closed ids1 $
502 go sccs
503 ; return (binds1 `unionBags` binds2, thing) }
504 go [] = do { thing <- thing_inside; return (emptyBag, thing) }
505
506 tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
507 tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
508
509 tc_sub_group rec_tc binds =
510 tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
511
512 recursivePatSynErr :: OutputableBndrId name => LHsBinds name -> TcM a
513 recursivePatSynErr binds
514 = failWithTc $
515 hang (text "Recursive pattern synonym definition with following bindings:")
516 2 (vcat $ map pprLBind . bagToList $ binds)
517 where
518 pprLoc loc = parens (text "defined at" <+> ppr loc)
519 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
520 pprLoc loc
521
522 tc_single :: forall thing.
523 TopLevelFlag -> TcSigFun -> TcPragEnv
524 -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
525 -> TcM (LHsBinds GhcTcId, thing)
526 tc_single _top_lvl sig_fn _prag_fn
527 (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
528 _ thing_inside
529 = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
530 ; thing <- setGblEnv tcg_env thing_inside
531 ; return (aux_binds, thing)
532 }
533 where
534 tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv)
535 tc_pat_syn_decl = case sig_fn name of
536 Nothing -> tcInferPatSynDecl psb
537 Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
538 Just _ -> panic "tc_single"
539
540 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
541 = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
542 NonRecursive NonRecursive
543 closed
544 [lbind]
545 ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
546 ; return (binds1, thing) }
547
548 ------------------------
549 type BKey = Int -- Just number off the bindings
550
551 mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
552 -- See Note [Polymorphic recursion] in HsBinds.
553 mkEdges sig_fn binds
554 = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
555 Just key <- [lookupNameEnv key_map n], no_sig n ]
556 | (bind, key) <- keyd_binds
557 ]
558 -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
559 -- is still deterministic even if the edges are in nondeterministic order
560 -- as explained in Note [Deterministic SCC] in Digraph.
561 where
562 bind_fvs (FunBind { fun_ext = fvs }) = fvs
563 bind_fvs (PatBind { pat_ext = fvs }) = fvs
564 bind_fvs _ = emptyNameSet
565
566 no_sig :: Name -> Bool
567 no_sig n = not (hasCompleteSig sig_fn n)
568
569 keyd_binds = bagToList binds `zip` [0::BKey ..]
570
571 key_map :: NameEnv BKey -- Which binding it comes from
572 key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
573 , bndr <- collectHsBindBinders bind ]
574
575 ------------------------
576 tcPolyBinds :: TcSigFun -> TcPragEnv
577 -> RecFlag -- Whether the group is really recursive
578 -> RecFlag -- Whether it's recursive after breaking
579 -- dependencies based on type signatures
580 -> IsGroupClosed -- Whether the group is closed
581 -> [LHsBind GhcRn] -- None are PatSynBind
582 -> TcM (LHsBinds GhcTcId, [TcId])
583
584 -- Typechecks a single bunch of values bindings all together,
585 -- and generalises them. The bunch may be only part of a recursive
586 -- group, because we use type signatures to maximise polymorphism
587 --
588 -- Returns a list because the input may be a single non-recursive binding,
589 -- in which case the dependency order of the resulting bindings is
590 -- important.
591 --
592 -- Knows nothing about the scope of the bindings
593 -- None of the bindings are pattern synonyms
594
595 tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
596 = setSrcSpan loc $
597 recoverM (recoveryCode binder_names sig_fn) $ do
598 -- Set up main recover; take advantage of any type sigs
599
600 { traceTc "------------------------------------------------" Outputable.empty
601 ; traceTc "Bindings for {" (ppr binder_names)
602 ; dflags <- getDynFlags
603 ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
604 ; traceTc "Generalisation plan" (ppr plan)
605 ; result@(_, poly_ids) <- case plan of
606 NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
607 InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
608 CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
609
610 ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
611 , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
612 ])
613
614 ; return result }
615 where
616 binder_names = collectHsBindListBinders bind_list
617 loc = foldr1 combineSrcSpans (map getLoc bind_list)
618 -- The mbinds have been dependency analysed and
619 -- may no longer be adjacent; so find the narrowest
620 -- span that includes them all
621
622 --------------
623 -- If typechecking the binds fails, then return with each
624 -- signature-less binder given type (forall a.a), to minimise
625 -- subsequent error messages
626 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id])
627 recoveryCode binder_names sig_fn
628 = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
629 ; let poly_ids = map mk_dummy binder_names
630 ; return (emptyBag, poly_ids) }
631 where
632 mk_dummy name
633 | Just sig <- sig_fn name
634 , Just poly_id <- completeSigPolyId_maybe sig
635 = poly_id
636 | otherwise
637 = mkLocalId name forall_a_a
638
639 forall_a_a :: TcType
640 -- At one point I had (forall r (a :: TYPE r). a), but of course
641 -- that type is ill-formed: its mentions 'r' which escapes r's scope.
642 -- Another alternative would be (forall (a :: TYPE kappa). a), where
643 -- kappa is a unification variable. But I don't think we need that
644 -- complication here. I'm going to just use (forall (a::*). a).
645 -- See Trac #15276
646 forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
647
648 {- *********************************************************************
649 * *
650 tcPolyNoGen
651 * *
652 ********************************************************************* -}
653
654 tcPolyNoGen -- No generalisation whatsoever
655 :: RecFlag -- Whether it's recursive after breaking
656 -- dependencies based on type signatures
657 -> TcPragEnv -> TcSigFun
658 -> [LHsBind GhcRn]
659 -> TcM (LHsBinds GhcTcId, [TcId])
660
661 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
662 = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
663 (LetGblBndr prag_fn)
664 bind_list
665 ; mono_ids' <- mapM tc_mono_info mono_infos
666 ; return (binds', mono_ids') }
667 where
668 tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
669 = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
670 ; return mono_id }
671 -- NB: tcPrags generates error messages for
672 -- specialisation pragmas for non-overloaded sigs
673 -- Indeed that is why we call it here!
674 -- So we can safely ignore _specs
675
676
677 {- *********************************************************************
678 * *
679 tcPolyCheck
680 * *
681 ********************************************************************* -}
682
683 tcPolyCheck :: TcPragEnv
684 -> TcIdSigInfo -- Must be a complete signature
685 -> LHsBind GhcRn -- Must be a FunBind
686 -> TcM (LHsBinds GhcTcId, [TcId])
687 -- There is just one binding,
688 -- it is a Funbind
689 -- it has a complete type signature,
690 tcPolyCheck prag_fn
691 (CompleteSig { sig_bndr = poly_id
692 , sig_ctxt = ctxt
693 , sig_loc = sig_loc })
694 (L loc (FunBind { fun_id = L nm_loc name
695 , fun_matches = matches }))
696 = setSrcSpan sig_loc $
697 do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
698 ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
699 -- See Note [Instantiate sig with fresh variables]
700
701 ; mono_name <- newNameAt (nameOccName name) nm_loc
702 ; ev_vars <- newEvVars theta
703 ; let mono_id = mkLocalId mono_name tau
704 skol_info = SigSkol ctxt (idType poly_id) tv_prs
705 skol_tvs = map snd tv_prs
706
707 ; (ev_binds, (co_fn, matches'))
708 <- checkConstraints skol_info skol_tvs ev_vars $
709 tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
710 tcExtendNameTyVarEnv tv_prs $
711 setSrcSpan loc $
712 tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
713
714 ; let prag_sigs = lookupPragEnv prag_fn name
715 ; spec_prags <- tcSpecPrags poly_id prag_sigs
716 ; poly_id <- addInlinePrags poly_id prag_sigs
717
718 ; mod <- getModule
719 ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
720 ; let bind' = FunBind { fun_id = L nm_loc mono_id
721 , fun_matches = matches'
722 , fun_co_fn = co_fn
723 , fun_ext = placeHolderNamesTc
724 , fun_tick = tick }
725
726 export = ABE { abe_ext = noExt
727 , abe_wrap = idHsWrapper
728 , abe_poly = poly_id
729 , abe_mono = mono_id
730 , abe_prags = SpecPrags spec_prags }
731
732 abs_bind = L loc $
733 AbsBinds { abs_ext = noExt
734 , abs_tvs = skol_tvs
735 , abs_ev_vars = ev_vars
736 , abs_ev_binds = [ev_binds]
737 , abs_exports = [export]
738 , abs_binds = unitBag (L loc bind')
739 , abs_sig = True }
740
741 ; return (unitBag abs_bind, [poly_id]) }
742
743 tcPolyCheck _prag_fn sig bind
744 = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
745
746 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
747 -> TcM [Tickish TcId]
748 funBindTicks loc fun_id mod sigs
749 | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
750 -- this can only be a singleton list, as duplicate pragmas are rejected
751 -- by the renamer
752 , let cc_str
753 | Just cc_str <- mb_cc_str
754 = sl_fs $ unLoc cc_str
755 | otherwise
756 = getOccFS (Var.varName fun_id)
757 cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
758 = do
759 flavour <- DeclCC <$> getCCIndexM cc_name
760 let cc = mkUserCC cc_name mod loc flavour
761 return [ProfNote cc True True]
762 | otherwise
763 = return []
764
765 {- Note [Instantiate sig with fresh variables]
766 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
767 It's vital to instantiate a type signature with fresh variables.
768 For example:
769 type T = forall a. [a] -> [a]
770 f :: T;
771 f = g where { g :: T; g = <rhs> }
772
773 We must not use the same 'a' from the defn of T at both places!!
774 (Instantiation is only necessary because of type synonyms. Otherwise,
775 it's all cool; each signature has distinct type variables from the renamer.)
776 -}
777
778
779 {- *********************************************************************
780 * *
781 tcPolyInfer
782 * *
783 ********************************************************************* -}
784
785 tcPolyInfer
786 :: RecFlag -- Whether it's recursive after breaking
787 -- dependencies based on type signatures
788 -> TcPragEnv -> TcSigFun
789 -> Bool -- True <=> apply the monomorphism restriction
790 -> [LHsBind GhcRn]
791 -> TcM (LHsBinds GhcTcId, [TcId])
792 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
793 = do { (tclvl, wanted, (binds', mono_infos))
794 <- pushLevelAndCaptureConstraints $
795 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
796
797 ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
798 | info <- mono_infos ]
799 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
800 infer_mode = if mono then ApplyMR else NoRestrictions
801
802 ; mapM_ (checkOverloadedSig mono) sigs
803
804 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
805 ; (qtvs, givens, ev_binds, insoluble)
806 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
807
808 ; let inferred_theta = map evVarPred givens
809 ; exports <- checkNoErrs $
810 mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
811
812 ; loc <- getSrcSpanM
813 ; let poly_ids = map abe_poly exports
814 abs_bind = L loc $
815 AbsBinds { abs_ext = noExt
816 , abs_tvs = qtvs
817 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
818 , abs_exports = exports, abs_binds = binds'
819 , abs_sig = False }
820
821 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
822 ; return (unitBag abs_bind, poly_ids) }
823 -- poly_ids are guaranteed zonked by mkExport
824
825 --------------
826 mkExport :: TcPragEnv
827 -> Bool -- True <=> there was an insoluble type error
828 -- when typechecking the bindings
829 -> [TyVar] -> TcThetaType -- Both already zonked
830 -> MonoBindInfo
831 -> TcM (ABExport GhcTc)
832 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
833 --
834 -- mkExport generates exports with
835 -- zonked type variables,
836 -- zonked poly_ids
837 -- The former is just because no further unifications will change
838 -- the quantified type variables, so we can fix their final form
839 -- right now.
840 -- The latter is needed because the poly_ids are used to extend the
841 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
842
843 -- Pre-condition: the qtvs and theta are already zonked
844
845 mkExport prag_fn insoluble qtvs theta
846 mono_info@(MBI { mbi_poly_name = poly_name
847 , mbi_sig = mb_sig
848 , mbi_mono_id = mono_id })
849 = do { mono_ty <- zonkTcType (idType mono_id)
850 ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
851
852 -- NB: poly_id has a zonked type
853 ; poly_id <- addInlinePrags poly_id prag_sigs
854 ; spec_prags <- tcSpecPrags poly_id prag_sigs
855 -- tcPrags requires a zonked poly_id
856
857 -- See Note [Impedance matching]
858 -- NB: we have already done checkValidType, including an ambiguity check,
859 -- on the type; either when we checked the sig or in mkInferredPolyId
860 ; let poly_ty = idType poly_id
861 sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
862 -- This type is just going into tcSubType,
863 -- so Inferred vs. Specified doesn't matter
864
865 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
866 then return idHsWrapper -- Fast path; also avoids complaint when we infer
867 -- an ambiguous type and have AllowAmbiguousType
868 -- e..g infer x :: forall a. F a -> Int
869 else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
870 tcSubType_NC sig_ctxt sel_poly_ty poly_ty
871
872 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
873 ; when warn_missing_sigs $
874 localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
875
876 ; return (ABE { abe_ext = noExt
877 , abe_wrap = wrap
878 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
879 , abe_poly = poly_id
880 , abe_mono = mono_id
881 , abe_prags = SpecPrags spec_prags }) }
882 where
883 prag_sigs = lookupPragEnv prag_fn poly_name
884 sig_ctxt = InfSigCtxt poly_name
885
886 mkInferredPolyId :: Bool -- True <=> there was an insoluble error when
887 -- checking the binding group for this Id
888 -> [TyVar] -> TcThetaType
889 -> Name -> Maybe TcIdSigInst -> TcType
890 -> TcM TcId
891 mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
892 | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
893 , CompleteSig { sig_bndr = poly_id } <- sig
894 = return poly_id
895
896 | otherwise -- Either no type sig or partial type sig
897 = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous
898 -- we don't carry on to the impedance matching, and generate
899 -- a duplicate ambiguity error. There is a similar
900 -- checkNoErrs for complete type signatures too.
901 do { fam_envs <- tcGetFamInstEnvs
902 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
903 -- Unification may not have normalised the type,
904 -- (see Note [Lazy flattening] in TcFlatten) so do it
905 -- here to make it as uncomplicated as possible.
906 -- Example: f :: [F Int] -> Bool
907 -- should be rewritten to f :: [Char] -> Bool, if possible
908 --
909 -- We can discard the coercion _co, because we'll reconstruct
910 -- it in the call to tcSubType below
911
912 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
913 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
914
915 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
916
917 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
918 , ppr inferred_poly_ty])
919 ; unless insoluble $
920 addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
921 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
922 -- See Note [Validity of inferred types]
923 -- If we found an insoluble error in the function definition, don't
924 -- do this check; otherwise (Trac #14000) we may report an ambiguity
925 -- error for a rather bogus type.
926
927 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
928
929
930 chooseInferredQuantifiers :: TcThetaType -- inferred
931 -> TcTyVarSet -- tvs free in tau type
932 -> [TcTyVar] -- inferred quantified tvs
933 -> Maybe TcIdSigInst
934 -> TcM ([TyVarBinder], TcThetaType)
935 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
936 = -- No type signature (partial or complete) for this binder,
937 do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
938 -- Include kind variables! Trac #7916
939 my_theta = pickCapturedPreds free_tvs inferred_theta
940 binders = [ mkTyVarBinder Inferred tv
941 | tv <- qtvs
942 , tv `elemVarSet` free_tvs ]
943 ; return (binders, my_theta) }
944
945 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
946 (Just (TISI { sig_inst_sig = sig -- Always PartialSig
947 , sig_inst_wcx = wcx
948 , sig_inst_theta = annotated_theta
949 , sig_inst_skols = annotated_tvs }))
950 = -- Choose quantifiers for a partial type signature
951 do { psig_qtv_prs <- zonkSigTyVarPairs annotated_tvs
952
953 -- Check whether the quantified variables of the
954 -- partial signature have been unified together
955 -- See Note [Quantified variables in partial type signatures]
956 ; mapM_ report_dup_sig_tv_err (findDupSigTvs psig_qtv_prs)
957
958 -- Check whether a quantified variable of the partial type
959 -- signature is not actually quantified. How can that happen?
960 -- See Note [Quantification and partial signatures] Wrinkle 4
961 -- in TcSimplify
962 ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs
963 , not (tv `elem` qtvs) ]
964
965 ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)
966
967 ; annotated_theta <- zonkTcTypes annotated_theta
968 ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx
969
970 ; let keep_me = free_tvs `unionVarSet` psig_qtvs
971 final_qtvs = [ mkTyVarBinder vis tv
972 | tv <- qtvs -- Pulling from qtvs maintains original order
973 , tv `elemVarSet` keep_me
974 , let vis | tv `elemVarSet` psig_qtvs = Specified
975 | otherwise = Inferred ]
976
977 ; return (final_qtvs, my_theta) }
978 where
979 report_dup_sig_tv_err (n1,n2)
980 | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
981 = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
982 <+> text "with" <+> quotes (ppr n2))
983 2 (hang (text "both bound by the partial type signature:")
984 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
985
986 | otherwise -- Can't happen; by now we know it's a partial sig
987 = pprPanic "report_sig_tv_err" (ppr sig)
988
989 report_mono_sig_tv_err n
990 | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
991 = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))
992 2 (hang (text "bound by the partial type signature:")
993 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
994 | otherwise -- Can't happen; by now we know it's a partial sig
995 = pprPanic "report_sig_tv_err" (ppr sig)
996
997 choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
998 -> TcM (VarSet, TcThetaType)
999 choose_psig_context _ annotated_theta Nothing
1000 = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
1001 `unionVarSet` tau_tvs)
1002 ; return (free_tvs, annotated_theta) }
1003
1004 choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
1005 = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
1006 -- growThetaVars just like the no-type-sig case
1007 -- Omitting this caused #12844
1008 seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there
1009 `unionVarSet` tau_tvs -- by the user
1010
1011 ; let keep_me = psig_qtvs `unionVarSet` free_tvs
1012 my_theta = pickCapturedPreds keep_me inferred_theta
1013
1014 -- Fill in the extra-constraints wildcard hole with inferred_theta,
1015 -- so that the Hole constraint we have already emitted
1016 -- (in tcHsPartialSigType) can report what filled it in.
1017 -- NB: my_theta already includes all the annotated constraints
1018 ; let inferred_diff = [ pred
1019 | pred <- my_theta
1020 , all (not . (`eqType` pred)) annotated_theta ]
1021 ; ctuple <- mk_ctuple inferred_diff
1022
1023 ; case tcGetCastedTyVar_maybe wc_var_ty of
1024 -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
1025 -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
1026 -- make the kinds work out, we reverse the cast here.
1027 Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
1028 Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
1029
1030 ; traceTc "completeTheta" $
1031 vcat [ ppr sig
1032 , ppr annotated_theta, ppr inferred_theta
1033 , ppr inferred_diff ]
1034 ; return (free_tvs, my_theta) }
1035
1036 mk_ctuple preds = return (mkBoxedTupleTy preds)
1037 -- Hack alert! See TcHsType:
1038 -- Note [Extra-constraint holes in partial type signatures]
1039
1040
1041 mk_impedance_match_msg :: MonoBindInfo
1042 -> TcType -> TcType
1043 -> TidyEnv -> TcM (TidyEnv, SDoc)
1044 -- This is a rare but rather awkward error messages
1045 mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
1046 inf_ty sig_ty tidy_env
1047 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
1048 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
1049 ; let msg = vcat [ text "When checking that the inferred type"
1050 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
1051 , text "is as general as its" <+> what <+> text "signature"
1052 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
1053 ; return (tidy_env2, msg) }
1054 where
1055 what = case mb_sig of
1056 Nothing -> text "inferred"
1057 Just sig | isPartialSig sig -> text "(partial)"
1058 | otherwise -> empty
1059
1060
1061 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
1062 mk_inf_msg poly_name poly_ty tidy_env
1063 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
1064 ; let msg = vcat [ text "When checking the inferred type"
1065 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
1066 ; return (tidy_env1, msg) }
1067
1068
1069 -- | Warn the user about polymorphic local binders that lack type signatures.
1070 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
1071 localSigWarn flag id mb_sig
1072 | Just _ <- mb_sig = return ()
1073 | not (isSigmaTy (idType id)) = return ()
1074 | otherwise = warnMissingSignatures flag msg id
1075 where
1076 msg = text "Polymorphic local binding with no type signature:"
1077
1078 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
1079 warnMissingSignatures flag msg id
1080 = do { env0 <- tcInitTidyEnv
1081 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
1082 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
1083 where
1084 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
1085
1086 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
1087 -- Example:
1088 -- f :: Eq a => a -> a
1089 -- K f = e
1090 -- The MR applies, but the signature is overloaded, and it's
1091 -- best to complain about this directly
1092 -- c.f Trac #11339
1093 checkOverloadedSig monomorphism_restriction_applies sig
1094 | not (null (sig_inst_theta sig))
1095 , monomorphism_restriction_applies
1096 , let orig_sig = sig_inst_sig sig
1097 = setSrcSpan (sig_loc orig_sig) $
1098 failWith $
1099 hang (text "Overloaded signature conflicts with monomorphism restriction")
1100 2 (ppr orig_sig)
1101 | otherwise
1102 = return ()
1103
1104 {- Note [Partial type signatures and generalisation]
1105 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1106 If /any/ of the signatures in the gropu is a partial type signature
1107 f :: _ -> Int
1108 then we *always* use the InferGen plan, and hence tcPolyInfer.
1109 We do this even for a local binding with -XMonoLocalBinds, when
1110 we normally use NoGen.
1111
1112 Reasons:
1113 * The TcSigInfo for 'f' has a unification variable for the '_',
1114 whose TcLevel is one level deeper than the current level.
1115 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
1116 the TcLevel like InferGen, so we lose the level invariant.
1117
1118 * The signature might be f :: forall a. _ -> a
1119 so it really is polymorphic. It's not clear what it would
1120 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
1121 in the (Just sig) case, checks that if there is a signature
1122 then we are using LetLclBndr, and hence a nested AbsBinds with
1123 increased TcLevel
1124
1125 It might be possible to fix these difficulties somehow, but there
1126 doesn't seem much point. Indeed, adding a partial type signature is a
1127 way to get per-binding inferred generalisation.
1128
1129 We apply the MR if /all/ of the partial signatures lack a context.
1130 In particular (Trac #11016):
1131 f2 :: (?loc :: Int) => _
1132 f2 = ?loc
1133 It's stupid to apply the MR here. This test includes an extra-constraints
1134 wildcard; that is, we don't apply the MR if you write
1135 f3 :: _ => blah
1136
1137 Note [Quantified variables in partial type signatures]
1138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1139 Consider
1140 f :: forall a. a -> a -> _
1141 f x y = g x y
1142 g :: forall b. b -> b -> _
1143 g x y = [x, y]
1144
1145 Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
1146 together, which is fine. So we bind 'a' and 'b' to SigTvs, which can then
1147 unify with each other.
1148
1149 But now consider:
1150 f :: forall a b. a -> b -> _
1151 f x y = [x, y]
1152
1153 We want to get an error from this, because 'a' and 'b' get unified.
1154 So we make a test, one per parital signature, to check that the
1155 explicitly-quantified type variables have not been unified together.
1156 Trac #14449 showed this up.
1157
1158
1159 Note [Validity of inferred types]
1160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1161 We need to check inferred type for validity, in case it uses language
1162 extensions that are not turned on. The principle is that if the user
1163 simply adds the inferred type to the program source, it'll compile fine.
1164 See #8883.
1165
1166 Examples that might fail:
1167 - the type might be ambiguous
1168
1169 - an inferred theta that requires type equalities e.g. (F a ~ G b)
1170 or multi-parameter type classes
1171 - an inferred type that includes unboxed tuples
1172
1173
1174 Note [Impedance matching]
1175 ~~~~~~~~~~~~~~~~~~~~~~~~~
1176 Consider
1177 f 0 x = x
1178 f n x = g [] (not x)
1179
1180 g [] y = f 10 y
1181 g _ y = f 9 y
1182
1183 After typechecking we'll get
1184 f_mono_ty :: a -> Bool -> Bool
1185 g_mono_ty :: [b] -> Bool -> Bool
1186 with constraints
1187 (Eq a, Num a)
1188
1189 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
1190 The types we really want for f and g are
1191 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
1192 g :: forall b. [b] -> Bool -> Bool
1193
1194 We can get these by "impedance matching":
1195 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
1196 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
1197
1198 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
1199 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
1200
1201 Suppose the shared quantified tyvars are qtvs and constraints theta.
1202 Then we want to check that
1203 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1204 and the proof is the impedance matcher.
1205
1206 Notice that the impedance matcher may do defaulting. See Trac #7173.
1207
1208 It also cleverly does an ambiguity check; for example, rejecting
1209 f :: F a -> F a
1210 where F is a non-injective type function.
1211 -}
1212
1213
1214 {-
1215 Note [SPECIALISE pragmas]
1216 ~~~~~~~~~~~~~~~~~~~~~~~~~
1217 There is no point in a SPECIALISE pragma for a non-overloaded function:
1218 reverse :: [a] -> [a]
1219 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1220
1221 But SPECIALISE INLINE *can* make sense for GADTS:
1222 data Arr e where
1223 ArrInt :: !Int -> ByteArray# -> Arr Int
1224 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1225
1226 (!:) :: Arr e -> Int -> e
1227 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1228 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1229 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1230 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1231
1232 When (!:) is specialised it becomes non-recursive, and can usefully
1233 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1234 for a non-overloaded function.
1235
1236 ************************************************************************
1237 * *
1238 tcMonoBinds
1239 * *
1240 ************************************************************************
1241
1242 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1243 The signatures have been dealt with already.
1244 -}
1245
1246 data MonoBindInfo = MBI { mbi_poly_name :: Name
1247 , mbi_sig :: Maybe TcIdSigInst
1248 , mbi_mono_id :: TcId }
1249
1250 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1251 -- i.e. the binders are mentioned in their RHSs, and
1252 -- we are not rescued by a type signature
1253 -> TcSigFun -> LetBndrSpec
1254 -> [LHsBind GhcRn]
1255 -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
1256 tcMonoBinds is_rec sig_fn no_gen
1257 [ L b_loc (FunBind { fun_id = L nm_loc name,
1258 fun_matches = matches, fun_ext = fvs })]
1259 -- Single function binding,
1260 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1261 , Nothing <- sig_fn name -- ...with no type signature
1262 = -- Note [Single function non-recursive binding special-case]
1263 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1264 -- In this very special case we infer the type of the
1265 -- right hand side first (it may have a higher-rank type)
1266 -- and *then* make the monomorphic Id for the LHS
1267 -- e.g. f = \(x::forall a. a->a) -> <body>
1268 -- We want to infer a higher-rank type for f
1269 setSrcSpan b_loc $
1270 do { ((co_fn, matches'), rhs_ty)
1271 <- tcInferInst $ \ exp_ty ->
1272 -- tcInferInst: see TcUnify,
1273 -- Note [Deep instantiation of InferResult]
1274 tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
1275 -- We extend the error context even for a non-recursive
1276 -- function so that in type error messages we show the
1277 -- type of the thing whose rhs we are type checking
1278 tcMatchesFun (L nm_loc name) matches exp_ty
1279
1280 ; mono_id <- newLetBndr no_gen name rhs_ty
1281 ; return (unitBag $ L b_loc $
1282 FunBind { fun_id = L nm_loc mono_id,
1283 fun_matches = matches', fun_ext = fvs,
1284 fun_co_fn = co_fn, fun_tick = [] },
1285 [MBI { mbi_poly_name = name
1286 , mbi_sig = Nothing
1287 , mbi_mono_id = mono_id }]) }
1288
1289 tcMonoBinds _ sig_fn no_gen binds
1290 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1291
1292 -- Bring the monomorphic Ids, into scope for the RHSs
1293 ; let mono_infos = getMonoBindInfo tc_binds
1294 rhs_id_env = [ (name, mono_id)
1295 | MBI { mbi_poly_name = name
1296 , mbi_sig = mb_sig
1297 , mbi_mono_id = mono_id } <- mono_infos
1298 , case mb_sig of
1299 Just sig -> isPartialSig sig
1300 Nothing -> True ]
1301 -- A monomorphic binding for each term variable that lacks
1302 -- a complete type sig. (Ones with a sig are already in scope.)
1303
1304 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1305 | (n,id) <- rhs_id_env]
1306 ; binds' <- tcExtendRecIds rhs_id_env $
1307 mapM (wrapLocM tcRhs) tc_binds
1308
1309 ; return (listToBag binds', mono_infos) }
1310
1311
1312 ------------------------
1313 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1314 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1315 -- if there's a signature for it, use the instantiated signature type
1316 -- otherwise invent a type variable
1317 -- You see that quite directly in the FunBind case.
1318 --
1319 -- But there's a complication for pattern bindings:
1320 -- data T = MkT (forall a. a->a)
1321 -- MkT f = e
1322 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1323 -- but we want to get (f::forall a. a->a) as the RHS environment.
1324 -- The simplest way to do this is to typecheck the pattern, and then look up the
1325 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1326 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1327
1328 data TcMonoBind -- Half completed; LHS done, RHS not done
1329 = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
1330 | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))
1331 TcSigmaType
1332
1333 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
1334 -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
1335 -- or NoGen (LetBndrSpec = LetGblBndr)
1336 -- CheckGen is used only for functions with a complete type signature,
1337 -- and tcPolyCheck doesn't use tcMonoBinds at all
1338
1339 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, 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 (L loc (idName mono_id))
1427 matches (mkCheckExpType $ idType mono_id)
1428 ; return ( FunBind { fun_id = L 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 -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
1457 = tcExtendNameTyVarEnv wcs $
1458 tcExtendNameTyVarEnv skol_prs $
1459 thing_inside
1460
1461 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1462 -- Extend the TcBinderStack for the RHS of the binding, with
1463 -- the monomorphic Id. That way, if we have, say
1464 -- f = \x -> blah
1465 -- and something goes wrong in 'blah', we get a "relevant binding"
1466 -- looking like f :: alpha -> beta
1467 -- This applies if 'f' has a type signature too:
1468 -- f :: forall a. [a] -> [a]
1469 -- f x = True
1470 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1471 -- If we had the *polymorphic* version of f in the TcBinderStack, it
1472 -- would not be reported as relevant, because its type is closed
1473 tcExtendIdBinderStackForRhs infos thing_inside
1474 = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
1475 | MBI { mbi_mono_id = mono_id } <- infos ]
1476 thing_inside
1477 -- NotTopLevel: it's a monomorphic binding
1478
1479 ---------------------
1480 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1481 getMonoBindInfo tc_binds
1482 = foldr (get_info . unLoc) [] tc_binds
1483 where
1484 get_info (TcFunBind info _ _) rest = info : rest
1485 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1486
1487
1488 {- Note [Typechecking pattern bindings]
1489 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1490 Look at:
1491 - typecheck/should_compile/ExPat
1492 - Trac #12427, typecheck/should_compile/T12427{a,b}
1493
1494 data T where
1495 MkT :: Integral a => a -> Int -> T
1496
1497 and suppose t :: T. Which of these pattern bindings are ok?
1498
1499 E1. let { MkT p _ = t } in <body>
1500
1501 E2. let { MkT _ q = t } in <body>
1502
1503 E3. let { MkT (toInteger -> r) _ = t } in <body>
1504
1505 * (E1) is clearly wrong because the existential 'a' escapes.
1506 What type could 'p' possibly have?
1507
1508 * (E2) is fine, despite the existential pattern, because
1509 q::Int, and nothing escapes.
1510
1511 * Even (E3) is fine. The existential pattern binds a dictionary
1512 for (Integral a) which the view pattern can use to convert the
1513 a-valued field to an Integer, so r :: Integer.
1514
1515 An easy way to see all three is to imagine the desugaring.
1516 For (E2) it would look like
1517 let q = case t of MkT _ q' -> q'
1518 in <body>
1519
1520
1521 We typecheck pattern bindings as follows. First tcLhs does this:
1522
1523 1. Take each type signature q :: ty, partial or complete, and
1524 instantiate it (with tcLhsSigId) to get a MonoBindInfo. This
1525 gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
1526 a fresh name.
1527
1528 Any fresh unification variables in instantiate(ty) born here, not
1529 deep under implications as would happen if we allocated them when
1530 we encountered q during tcPat.
1531
1532 2. Build a little environment mapping "q" -> "qm" for those Ids
1533 with signatures (inst_sig_fun)
1534
1535 3. Invoke tcLetPat to typecheck the pattern.
1536
1537 - We pass in the current TcLevel. This is captured by
1538 TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
1539 PatEnv.
1540
1541 - When tcPat finds an existential constructor, it binds fresh
1542 type variables and dictionaries as usual, increments the TcLevel,
1543 and emits an implication constraint.
1544
1545 - When we come to a binder (TcPat.tcPatBndr), it looks it up
1546 in the little environment (the pc_sig_fn field of PatCtxt).
1547
1548 Success => There was a type signature, so just use it,
1549 checking compatibility with the expected type.
1550
1551 Failure => No type sigature.
1552 Infer case: (happens only outside any constructor pattern)
1553 use a unification variable
1554 at the outer level pc_lvl
1555
1556 Check case: use promoteTcType to promote the type
1557 to the outer level pc_lvl. This is the
1558 place where we emit a constraint that'll blow
1559 up if existential capture takes place
1560
1561 Result: the type of the binder is always at pc_lvl. This is
1562 crucial.
1563
1564 4. Throughout, when we are making up an Id for the pattern-bound variables
1565 (newLetBndr), we have two cases:
1566
1567 - If we are generalising (generalisation plan is InferGen or
1568 CheckGen), then the let_bndr_spec will be LetLclBndr. In that case
1569 we want to bind a cloned, local version of the variable, with the
1570 type given by the pattern context, *not* by the signature (even if
1571 there is one; see Trac #7268). The mkExport part of the
1572 generalisation step will do the checking and impedance matching
1573 against the signature.
1574
1575 - If for some some reason we are not generalising (plan = NoGen), the
1576 LetBndrSpec will be LetGblBndr. In that case we must bind the
1577 global version of the Id, and do so with precisely the type given
1578 in the signature. (Then we unify with the type from the pattern
1579 context type.)
1580
1581
1582 And that's it! The implication constraints check for the skolem
1583 escape. It's quite simple and neat, and more expressive than before
1584 e.g. GHC 8.0 rejects (E2) and (E3).
1585
1586 Example for (E1), starting at level 1. We generate
1587 p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
1588 The (a~beta) can't float (because of the 'a'), nor be solved (because
1589 beta is untouchable.)
1590
1591 Example for (E2), we generate
1592 q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
1593 The beta is untoucable, but floats out of the constraint and can
1594 be solved absolutely fine.
1595
1596 Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
1597 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1598 Normally, any place that corresponds to Λ or ∀ in Core should be flagged
1599 with a call to scopeTyVars, which arranges for an implication constraint
1600 to be made, bumps the TcLevel, and (crucially) prevents a unification
1601 variable created outside the scope of a local skolem to unify with that
1602 skolem.
1603
1604 We do not need to do this here, however.
1605
1606 - Note that this happens only in the case of a partial signature.
1607 Complete signatures go via tcPolyCheck, not tcPolyInfer.
1608
1609 - The TcLevel is incremented in tcPolyInfer, right outside the call
1610 to tcMonoBinds. We thus don't have to worry about outer metatvs unifying
1611 with local skolems.
1612
1613 - The other potential concern is that we need SkolemInfo associated with
1614 the skolems. This, too, is OK, though: the constraints pass through
1615 simplifyInfer (which doesn't report errors), at the end of which
1616 the skolems will get quantified and put into an implication constraint.
1617 Thus, by the time any errors are reported, the SkolemInfo will be
1618 in place.
1619
1620 ************************************************************************
1621 * *
1622 Generalisation
1623 * *
1624 ********************************************************************* -}
1625
1626 data GeneralisationPlan
1627 = NoGen -- No generalisation, no AbsBinds
1628
1629 | InferGen -- Implicit generalisation; there is an AbsBinds
1630 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1631
1632 | CheckGen (LHsBind GhcRn) TcIdSigInfo
1633 -- One FunBind with a signature
1634 -- Explicit generalisation
1635
1636 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1637 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1638
1639 instance Outputable GeneralisationPlan where
1640 ppr NoGen = text "NoGen"
1641 ppr (InferGen b) = text "InferGen" <+> ppr b
1642 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1643
1644 decideGeneralisationPlan
1645 :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
1646 -> GeneralisationPlan
1647 decideGeneralisationPlan dflags lbinds closed sig_fn
1648 | has_partial_sigs = InferGen (and partial_sig_mrs)
1649 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1650 | do_not_generalise closed = NoGen
1651 | otherwise = InferGen mono_restriction
1652 where
1653 binds = map unLoc lbinds
1654
1655 partial_sig_mrs :: [Bool]
1656 -- One for each partial signature (so empty => no partial sigs)
1657 -- The Bool is True if the signature has no constraint context
1658 -- so we should apply the MR
1659 -- See Note [Partial type signatures and generalisation]
1660 partial_sig_mrs
1661 = [ null theta
1662 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1663 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1664 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1665
1666 has_partial_sigs = not (null partial_sig_mrs)
1667
1668 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1669 && any restricted binds
1670
1671 do_not_generalise (IsGroupClosed _ True) = False
1672 -- The 'True' means that all of the group's
1673 -- free vars have ClosedTypeId=True; so we can ignore
1674 -- -XMonoLocalBinds, and generalise anyway
1675 do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
1676
1677 -- With OutsideIn, all nested bindings are monomorphic
1678 -- except a single function binding with a signature
1679 one_funbind_with_sig
1680 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1681 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1682 = Just (lbind, sig)
1683 | otherwise
1684 = Nothing
1685
1686 -- The Haskell 98 monomorphism restriction
1687 restricted (PatBind {}) = True
1688 restricted (VarBind { var_id = v }) = no_sig v
1689 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1690 && no_sig (unLoc v)
1691 restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
1692
1693 restricted_match mg = matchGroupArity mg == 0
1694 -- No args => like a pattern binding
1695 -- Some args => a function binding
1696
1697 no_sig n = not (hasCompleteSig sig_fn n)
1698
1699 isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
1700 isClosedBndrGroup type_env binds
1701 = IsGroupClosed fv_env type_closed
1702 where
1703 type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
1704
1705 fv_env :: NameEnv NameSet
1706 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1707
1708 bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
1709 bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs })
1710 = let open_fvs = get_open_fvs fvs
1711 in [(f, open_fvs)]
1712 bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
1713 = let open_fvs = get_open_fvs fvs
1714 in [(b, open_fvs) | b <- collectPatBinders pat]
1715 bindFvs _
1716 = []
1717
1718 get_open_fvs fvs = filterNameSet (not . is_closed) fvs
1719
1720 is_closed :: Name -> ClosedTypeId
1721 is_closed name
1722 | Just thing <- lookupNameEnv type_env name
1723 = case thing of
1724 AGlobal {} -> True
1725 ATcId { tct_info = ClosedLet } -> True
1726 _ -> False
1727
1728 | otherwise
1729 = True -- The free-var set for a top level binding mentions
1730
1731
1732 is_closed_type_id :: Name -> Bool
1733 -- We're already removed Global and ClosedLet Ids
1734 is_closed_type_id name
1735 | Just thing <- lookupNameEnv type_env name
1736 = case thing of
1737 ATcId { tct_info = NonClosedLet _ cl } -> cl
1738 ATcId { tct_info = NotLetBound } -> False
1739 ATyVar {} -> False
1740 -- In-scope type variables are not closed!
1741 _ -> pprPanic "is_closed_id" (ppr name)
1742
1743 | otherwise
1744 = True -- The free-var set for a top level binding mentions
1745 -- imported things too, so that we can report unused imports
1746 -- These won't be in the local type env.
1747 -- Ditto class method etc from the current module
1748
1749
1750 {- *********************************************************************
1751 * *
1752 Error contexts and messages
1753 * *
1754 ********************************************************************* -}
1755
1756 -- This one is called on LHS, when pat and grhss are both Name
1757 -- and on RHS, when pat is TcId and grhss is still Name
1758 patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)
1759 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
1760 patMonoBindsCtxt pat grhss
1761 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)