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