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