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