Improve the desugaring of -XStrict
[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, 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 export = ABE { abe_wrap = idHsWrapper
721 , abe_poly = poly_id
722 , abe_mono = mono_id
723 , abe_prags = SpecPrags spec_prags }
724
725 abs_bind = L loc $
726 AbsBinds { abs_tvs = skol_tvs
727 , abs_ev_vars = ev_vars
728 , abs_ev_binds = [ev_binds]
729 , abs_exports = [export]
730 , abs_binds = unitBag (L loc bind')
731 , abs_sig = True }
732
733 ; return (unitBag abs_bind, [poly_id]) }
734
735 tcPolyCheck _prag_fn sig bind
736 = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
737
738 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
739 -> [Tickish TcId]
740 funBindTicks loc fun_id mod sigs
741 | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
742 -- this can only be a singleton list, as duplicate pragmas are rejected
743 -- by the renamer
744 , let cc_str
745 | Just cc_str <- mb_cc_str
746 = sl_fs $ unLoc cc_str
747 | otherwise
748 = getOccFS (Var.varName fun_id)
749 cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
750 cc = mkUserCC cc_name mod loc (getUnique fun_id)
751 = [ProfNote cc True True]
752 | otherwise
753 = []
754
755 {- Note [Instantiate sig with fresh variables]
756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
757 It's vital to instantiate a type signature with fresh variables.
758 For example:
759 type T = forall a. [a] -> [a]
760 f :: T;
761 f = g where { g :: T; g = <rhs> }
762
763 We must not use the same 'a' from the defn of T at both places!!
764 (Instantiation is only necessary because of type synonyms. Otherwise,
765 it's all cool; each signature has distinct type variables from the renamer.)
766 -}
767
768
769 {- *********************************************************************
770 * *
771 tcPolyInfer
772 * *
773 ********************************************************************* -}
774
775 tcPolyInfer
776 :: RecFlag -- Whether it's recursive after breaking
777 -- dependencies based on type signatures
778 -> TcPragEnv -> TcSigFun
779 -> Bool -- True <=> apply the monomorphism restriction
780 -> [LHsBind GhcRn]
781 -> TcM (LHsBinds GhcTcId, [TcId])
782 tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
783 = do { (tclvl, wanted, (binds', mono_infos))
784 <- pushLevelAndCaptureConstraints $
785 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
786
787 ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
788 | info <- mono_infos ]
789 sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
790 infer_mode = if mono then ApplyMR else NoRestrictions
791
792 ; mapM_ (checkOverloadedSig mono) sigs
793
794 ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
795 ; (qtvs, givens, ev_binds, insoluble)
796 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
797
798 ; let inferred_theta = map evVarPred givens
799 ; exports <- checkNoErrs $
800 mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
801
802 ; loc <- getSrcSpanM
803 ; let poly_ids = map abe_poly exports
804 abs_bind = L loc $
805 AbsBinds { abs_tvs = qtvs
806 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
807 , abs_exports = exports, abs_binds = binds'
808 , abs_sig = False }
809
810 ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
811 ; return (unitBag abs_bind, poly_ids) }
812 -- poly_ids are guaranteed zonked by mkExport
813
814 --------------
815 mkExport :: TcPragEnv
816 -> Bool -- True <=> there was an insoluble type error
817 -- when typechecking the bindings
818 -> [TyVar] -> TcThetaType -- Both already zonked
819 -> MonoBindInfo
820 -> TcM (ABExport GhcTc)
821 -- Only called for generalisation plan InferGen, not by CheckGen or NoGen
822 --
823 -- mkExport generates exports with
824 -- zonked type variables,
825 -- zonked poly_ids
826 -- The former is just because no further unifications will change
827 -- the quantified type variables, so we can fix their final form
828 -- right now.
829 -- The latter is needed because the poly_ids are used to extend the
830 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
831
832 -- Pre-condition: the qtvs and theta are already zonked
833
834 mkExport prag_fn insoluble qtvs theta
835 mono_info@(MBI { mbi_poly_name = poly_name
836 , mbi_sig = mb_sig
837 , mbi_mono_id = mono_id })
838 = do { mono_ty <- zonkTcType (idType mono_id)
839 ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
840
841 -- NB: poly_id has a zonked type
842 ; poly_id <- addInlinePrags poly_id prag_sigs
843 ; spec_prags <- tcSpecPrags poly_id prag_sigs
844 -- tcPrags requires a zonked poly_id
845
846 -- See Note [Impedance matching]
847 -- NB: we have already done checkValidType, including an ambiguity check,
848 -- on the type; either when we checked the sig or in mkInferredPolyId
849 ; let poly_ty = idType poly_id
850 sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
851 -- This type is just going into tcSubType,
852 -- so Inferred vs. Specified doesn't matter
853
854 ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility
855 then return idHsWrapper -- Fast path; also avoids complaint when we infer
856 -- an ambiguous type and have AllowAmbiguousType
857 -- e..g infer x :: forall a. F a -> Int
858 else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
859 tcSubType_NC sig_ctxt sel_poly_ty poly_ty
860
861 ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
862 ; when warn_missing_sigs $
863 localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
864
865 ; return (ABE { abe_wrap = wrap
866 -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
867 , abe_poly = poly_id
868 , abe_mono = mono_id
869 , abe_prags = SpecPrags spec_prags }) }
870 where
871 prag_sigs = lookupPragEnv prag_fn poly_name
872 sig_ctxt = InfSigCtxt poly_name
873
874 mkInferredPolyId :: Bool -- True <=> there was an insoluble error when
875 -- checking the binding group for this Id
876 -> [TyVar] -> TcThetaType
877 -> Name -> Maybe TcIdSigInst -> TcType
878 -> TcM TcId
879 mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
880 | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
881 , CompleteSig { sig_bndr = poly_id } <- sig
882 = return poly_id
883
884 | otherwise -- Either no type sig or partial type sig
885 = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous
886 -- we don't carry on to the impedance matching, and generate
887 -- a duplicate ambiguity error. There is a similar
888 -- checkNoErrs for complete type signatures too.
889 do { fam_envs <- tcGetFamInstEnvs
890 ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
891 -- Unification may not have normalised the type,
892 -- (see Note [Lazy flattening] in TcFlatten) so do it
893 -- here to make it as uncomplicated as possible.
894 -- Example: f :: [F Int] -> Bool
895 -- should be rewritten to f :: [Char] -> Bool, if possible
896 --
897 -- We can discard the coercion _co, because we'll reconstruct
898 -- it in the call to tcSubType below
899
900 ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
901 (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
902
903 ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
904
905 ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
906 , ppr inferred_poly_ty])
907 ; unless insoluble $
908 addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
909 checkValidType (InfSigCtxt poly_name) inferred_poly_ty
910 -- See Note [Validity of inferred types]
911 -- If we found an insoluble error in the function definition, don't
912 -- do this check; otherwise (Trac #14000) we may report an ambiguity
913 -- error for a rather bogus type.
914
915 ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
916
917
918 chooseInferredQuantifiers :: TcThetaType -- inferred
919 -> TcTyVarSet -- tvs free in tau type
920 -> [TcTyVar] -- inferred quantified tvs
921 -> Maybe TcIdSigInst
922 -> TcM ([TyVarBinder], TcThetaType)
923 chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
924 = -- No type signature (partial or complete) for this binder,
925 do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
926 -- Include kind variables! Trac #7916
927 my_theta = pickCapturedPreds free_tvs inferred_theta
928 binders = [ mkTyVarBinder Inferred tv
929 | tv <- qtvs
930 , tv `elemVarSet` free_tvs ]
931 ; return (binders, my_theta) }
932
933 chooseInferredQuantifiers inferred_theta tau_tvs qtvs
934 (Just (TISI { sig_inst_sig = sig -- Always PartialSig
935 , sig_inst_wcx = wcx
936 , sig_inst_theta = annotated_theta
937 , sig_inst_skols = annotated_tvs }))
938 | Nothing <- wcx
939 = do { annotated_theta <- zonkTcTypes annotated_theta
940 ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
941 `unionVarSet` tau_tvs)
942 ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs])
943 ; psig_qtvs <- mk_psig_qtvs annotated_tvs
944 ; return (mk_final_qtvs psig_qtvs free_tvs, annotated_theta) }
945
946 | Just wc_var <- wcx
947 = do { annotated_theta <- zonkTcTypes annotated_theta
948 ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
949 -- growThetaVars just like the no-type-sig case
950 -- Omitting this caused #12844
951 seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there
952 `unionVarSet` tau_tvs -- by the user
953
954 ; psig_qtvs <- mk_psig_qtvs annotated_tvs
955 ; let my_qtvs = mk_final_qtvs psig_qtvs free_tvs
956 keep_me = psig_qtvs `unionVarSet` free_tvs
957 my_theta = pickCapturedPreds keep_me inferred_theta
958
959 -- Report the inferred constraints for an extra-constraints wildcard/hole as
960 -- an error message, unless the PartialTypeSignatures flag is enabled. In this
961 -- case, the extra inferred constraints are accepted without complaining.
962 -- NB: inferred_theta already includes all the annotated constraints
963 inferred_diff = [ pred
964 | pred <- my_theta
965 , all (not . (`eqType` pred)) annotated_theta ]
966 ; ctuple <- mk_ctuple inferred_diff
967 ; writeMetaTyVar wc_var ctuple
968 ; traceTc "completeTheta" $
969 vcat [ ppr sig
970 , ppr annotated_theta, ppr inferred_theta
971 , ppr inferred_diff ]
972
973 ; return (my_qtvs, my_theta) }
974
975 | otherwise -- A complete type signature is dealt with in mkInferredPolyId
976 = pprPanic "chooseInferredQuantifiers" (ppr sig)
977
978 where
979 mk_final_qtvs psig_qtvs free_tvs
980 = [ mkTyVarBinder vis tv
981 | tv <- qtvs -- Pulling from qtvs maintains original order
982 , tv `elemVarSet` keep_me
983 , let vis | tv `elemVarSet` psig_qtvs = Specified
984 | otherwise = Inferred ]
985 where
986 keep_me = free_tvs `unionVarSet` psig_qtvs
987
988 mk_ctuple [pred] = return pred
989 mk_ctuple preds = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))
990 ; return (mkTyConApp tc preds) }
991
992 mk_psig_qtvs :: [(Name,TcTyVar)] -> TcM TcTyVarSet
993 mk_psig_qtvs annotated_tvs
994 = do { psig_qtvs <- mapM (zonkTcTyVarToTyVar . snd) annotated_tvs
995 ; return (mkVarSet psig_qtvs) }
996
997 mk_impedance_match_msg :: MonoBindInfo
998 -> TcType -> TcType
999 -> TidyEnv -> TcM (TidyEnv, SDoc)
1000 -- This is a rare but rather awkward error messages
1001 mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
1002 inf_ty sig_ty tidy_env
1003 = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
1004 ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
1005 ; let msg = vcat [ text "When checking that the inferred type"
1006 , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
1007 , text "is as general as its" <+> what <+> text "signature"
1008 , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
1009 ; return (tidy_env2, msg) }
1010 where
1011 what = case mb_sig of
1012 Nothing -> text "inferred"
1013 Just sig | isPartialSig sig -> text "(partial)"
1014 | otherwise -> empty
1015
1016
1017 mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
1018 mk_inf_msg poly_name poly_ty tidy_env
1019 = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
1020 ; let msg = vcat [ text "When checking the inferred type"
1021 , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
1022 ; return (tidy_env1, msg) }
1023
1024
1025 -- | Warn the user about polymorphic local binders that lack type signatures.
1026 localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
1027 localSigWarn flag id mb_sig
1028 | Just _ <- mb_sig = return ()
1029 | not (isSigmaTy (idType id)) = return ()
1030 | otherwise = warnMissingSignatures flag msg id
1031 where
1032 msg = text "Polymorphic local binding with no type signature:"
1033
1034 warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
1035 warnMissingSignatures flag msg id
1036 = do { env0 <- tcInitTidyEnv
1037 ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
1038 ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
1039 where
1040 mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
1041
1042 checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
1043 -- Example:
1044 -- f :: Eq a => a -> a
1045 -- K f = e
1046 -- The MR applies, but the signature is overloaded, and it's
1047 -- best to complain about this directly
1048 -- c.f Trac #11339
1049 checkOverloadedSig monomorphism_restriction_applies sig
1050 | not (null (sig_inst_theta sig))
1051 , monomorphism_restriction_applies
1052 , let orig_sig = sig_inst_sig sig
1053 = setSrcSpan (sig_loc orig_sig) $
1054 failWith $
1055 hang (text "Overloaded signature conflicts with monomorphism restriction")
1056 2 (ppr orig_sig)
1057 | otherwise
1058 = return ()
1059
1060 {- Note [Partial type signatures and generalisation]
1061 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1062 If /any/ of the signatures in the gropu is a partial type signature
1063 f :: _ -> Int
1064 then we *always* use the InferGen plan, and hence tcPolyInfer.
1065 We do this even for a local binding with -XMonoLocalBinds, when
1066 we normally use NoGen.
1067
1068 Reasons:
1069 * The TcSigInfo for 'f' has a unification variable for the '_',
1070 whose TcLevel is one level deeper than the current level.
1071 (See pushTcLevelM in tcTySig.) But NoGen doesn't increase
1072 the TcLevel like InferGen, so we lose the level invariant.
1073
1074 * The signature might be f :: forall a. _ -> a
1075 so it really is polymorphic. It's not clear what it would
1076 mean to use NoGen on this, and indeed the ASSERT in tcLhs,
1077 in the (Just sig) case, checks that if there is a signature
1078 then we are using LetLclBndr, and hence a nested AbsBinds with
1079 increased TcLevel
1080
1081 It might be possible to fix these difficulties somehow, but there
1082 doesn't seem much point. Indeed, adding a partial type signature is a
1083 way to get per-binding inferred generalisation.
1084
1085 We apply the MR if /all/ of the partial signatures lack a context.
1086 In particular (Trac #11016):
1087 f2 :: (?loc :: Int) => _
1088 f2 = ?loc
1089 It's stupid to apply the MR here. This test includes an extra-constraints
1090 wildcard; that is, we don't apply the MR if you write
1091 f3 :: _ => blah
1092
1093 Note [Validity of inferred types]
1094 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1095 We need to check inferred type for validity, in case it uses language
1096 extensions that are not turned on. The principle is that if the user
1097 simply adds the inferred type to the program source, it'll compile fine.
1098 See #8883.
1099
1100 Examples that might fail:
1101 - the type might be ambiguous
1102
1103 - an inferred theta that requires type equalities e.g. (F a ~ G b)
1104 or multi-parameter type classes
1105 - an inferred type that includes unboxed tuples
1106
1107
1108 Note [Impedance matching]
1109 ~~~~~~~~~~~~~~~~~~~~~~~~~
1110 Consider
1111 f 0 x = x
1112 f n x = g [] (not x)
1113
1114 g [] y = f 10 y
1115 g _ y = f 9 y
1116
1117 After typechecking we'll get
1118 f_mono_ty :: a -> Bool -> Bool
1119 g_mono_ty :: [b] -> Bool -> Bool
1120 with constraints
1121 (Eq a, Num a)
1122
1123 Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
1124 The types we really want for f and g are
1125 f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
1126 g :: forall b. [b] -> Bool -> Bool
1127
1128 We can get these by "impedance matching":
1129 tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
1130 tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
1131
1132 f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
1133 g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
1134
1135 Suppose the shared quantified tyvars are qtvs and constraints theta.
1136 Then we want to check that
1137 forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
1138 and the proof is the impedance matcher.
1139
1140 Notice that the impedance matcher may do defaulting. See Trac #7173.
1141
1142 It also cleverly does an ambiguity check; for example, rejecting
1143 f :: F a -> F a
1144 where F is a non-injective type function.
1145 -}
1146
1147 {- *********************************************************************
1148 * *
1149 Vectorisation
1150 * *
1151 ********************************************************************* -}
1152
1153 tcVectDecls :: [LVectDecl GhcRn] -> TcM ([LVectDecl GhcTcId])
1154 tcVectDecls decls
1155 = do { decls' <- mapM (wrapLocM tcVect) decls
1156 ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
1157 dups = findDupsEq (==) ids
1158 ; mapM_ reportVectDups dups
1159 ; traceTcConstraints "End of tcVectDecls"
1160 ; return decls'
1161 }
1162 where
1163 reportVectDups (first:_second:_more)
1164 = addErrAt (getSrcSpan first) $
1165 text "Duplicate vectorisation declarations for" <+> ppr first
1166 reportVectDups _ = return ()
1167
1168 --------------
1169 tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId)
1170 -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
1171 -- type of the original definition as this requires internals of the vectoriser not available
1172 -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
1173 -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
1174 -- from the vectoriser here.
1175 tcVect (HsVect s name rhs)
1176 = addErrCtxt (vectCtxt name) $
1177 do { var <- wrapLocM tcLookupId name
1178 ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
1179 ; rhs_id <- tcLookupId rhs_var_name
1180 ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
1181 }
1182
1183 tcVect (HsNoVect s name)
1184 = addErrCtxt (vectCtxt name) $
1185 do { var <- wrapLocM tcLookupId name
1186 ; return $ HsNoVect s var
1187 }
1188 tcVect (HsVectTypeIn _ isScalar lname rhs_name)
1189 = addErrCtxt (vectCtxt lname) $
1190 do { tycon <- tcLookupLocatedTyCon lname
1191 ; checkTc ( not isScalar -- either we have a non-SCALAR declaration
1192 || isJust rhs_name -- or we explicitly provide a vectorised type
1193 || tyConArity tycon == 0 -- otherwise the type constructor must be nullary
1194 )
1195 scalarTyConMustBeNullary
1196
1197 ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
1198 ; return $ HsVectTypeOut isScalar tycon rhs_tycon
1199 }
1200 tcVect (HsVectTypeOut _ _ _)
1201 = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
1202 tcVect (HsVectClassIn _ lname)
1203 = addErrCtxt (vectCtxt lname) $
1204 do { cls <- tcLookupLocatedClass lname
1205 ; return $ HsVectClassOut cls
1206 }
1207 tcVect (HsVectClassOut _)
1208 = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
1209 tcVect (HsVectInstIn linstTy)
1210 = addErrCtxt (vectCtxt linstTy) $
1211 do { (cls, tys) <- tcHsVectInst linstTy
1212 ; inst <- tcLookupInstance cls tys
1213 ; return $ HsVectInstOut inst
1214 }
1215 tcVect (HsVectInstOut _)
1216 = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
1217
1218 vectCtxt :: Outputable thing => thing -> SDoc
1219 vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
1220
1221 scalarTyConMustBeNullary :: MsgDoc
1222 scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
1223
1224 {-
1225 Note [SPECIALISE pragmas]
1226 ~~~~~~~~~~~~~~~~~~~~~~~~~
1227 There is no point in a SPECIALISE pragma for a non-overloaded function:
1228 reverse :: [a] -> [a]
1229 {-# SPECIALISE reverse :: [Int] -> [Int] #-}
1230
1231 But SPECIALISE INLINE *can* make sense for GADTS:
1232 data Arr e where
1233 ArrInt :: !Int -> ByteArray# -> Arr Int
1234 ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
1235
1236 (!:) :: Arr e -> Int -> e
1237 {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
1238 {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
1239 (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
1240 (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
1241
1242 When (!:) is specialised it becomes non-recursive, and can usefully
1243 be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
1244 for a non-overloaded function.
1245
1246 ************************************************************************
1247 * *
1248 tcMonoBinds
1249 * *
1250 ************************************************************************
1251
1252 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
1253 The signatures have been dealt with already.
1254 -}
1255
1256 data MonoBindInfo = MBI { mbi_poly_name :: Name
1257 , mbi_sig :: Maybe TcIdSigInst
1258 , mbi_mono_id :: TcId }
1259
1260 tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
1261 -- i.e. the binders are mentioned in their RHSs, and
1262 -- we are not rescued by a type signature
1263 -> TcSigFun -> LetBndrSpec
1264 -> [LHsBind GhcRn]
1265 -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
1266 tcMonoBinds is_rec sig_fn no_gen
1267 [ L b_loc (FunBind { fun_id = L nm_loc name,
1268 fun_matches = matches, bind_fvs = fvs })]
1269 -- Single function binding,
1270 | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
1271 , Nothing <- sig_fn name -- ...with no type signature
1272 = -- Note [Single function non-recursive binding special-case]
1273 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1274 -- In this very special case we infer the type of the
1275 -- right hand side first (it may have a higher-rank type)
1276 -- and *then* make the monomorphic Id for the LHS
1277 -- e.g. f = \(x::forall a. a->a) -> <body>
1278 -- We want to infer a higher-rank type for f
1279 setSrcSpan b_loc $
1280 do { ((co_fn, matches'), rhs_ty)
1281 <- tcInferInst $ \ exp_ty ->
1282 -- tcInferInst: see TcUnify,
1283 -- Note [Deep instantiation of InferResult]
1284 tcExtendIdBndrs [TcIdBndr_ExpType name exp_ty NotTopLevel] $
1285 -- We extend the error context even for a non-recursive
1286 -- function so that in type error messages we show the
1287 -- type of the thing whose rhs we are type checking
1288 tcMatchesFun (L nm_loc name) matches exp_ty
1289
1290 ; mono_id <- newLetBndr no_gen name rhs_ty
1291 ; return (unitBag $ L b_loc $
1292 FunBind { fun_id = L nm_loc mono_id,
1293 fun_matches = matches', bind_fvs = fvs,
1294 fun_co_fn = co_fn, fun_tick = [] },
1295 [MBI { mbi_poly_name = name
1296 , mbi_sig = Nothing
1297 , mbi_mono_id = mono_id }]) }
1298
1299 tcMonoBinds _ sig_fn no_gen binds
1300 = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
1301
1302 -- Bring the monomorphic Ids, into scope for the RHSs
1303 ; let mono_infos = getMonoBindInfo tc_binds
1304 rhs_id_env = [ (name, mono_id)
1305 | MBI { mbi_poly_name = name
1306 , mbi_sig = mb_sig
1307 , mbi_mono_id = mono_id } <- mono_infos
1308 , case mb_sig of
1309 Just sig -> isPartialSig sig
1310 Nothing -> True ]
1311 -- A monomorphic binding for each term variable that lacks
1312 -- a complete type sig. (Ones with a sig are already in scope.)
1313
1314 ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
1315 | (n,id) <- rhs_id_env]
1316 ; binds' <- tcExtendRecIds rhs_id_env $
1317 mapM (wrapLocM tcRhs) tc_binds
1318
1319 ; return (listToBag binds', mono_infos) }
1320
1321
1322 ------------------------
1323 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
1324 -- we typecheck the RHSs. Basically what we are doing is this: for each binder:
1325 -- if there's a signature for it, use the instantiated signature type
1326 -- otherwise invent a type variable
1327 -- You see that quite directly in the FunBind case.
1328 --
1329 -- But there's a complication for pattern bindings:
1330 -- data T = MkT (forall a. a->a)
1331 -- MkT f = e
1332 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
1333 -- but we want to get (f::forall a. a->a) as the RHS environment.
1334 -- The simplest way to do this is to typecheck the pattern, and then look up the
1335 -- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
1336 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
1337
1338 data TcMonoBind -- Half completed; LHS done, RHS not done
1339 = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
1340 | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))
1341 TcSigmaType
1342
1343 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
1344 -- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
1345 -- or NoGen (LetBndrSpec = LetGblBndr)
1346 -- CheckGen is used only for functions with a complete type signature,
1347 -- and tcPolyCheck doesn't use tcMonoBinds at all
1348
1349 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
1350 | Just (TcIdSig sig) <- sig_fn name
1351 = -- There is a type signature.
1352 -- It must be partial; if complete we'd be in tcPolyCheck!
1353 -- e.g. f :: _ -> _
1354 -- f x = ...g...
1355 -- Just g = ...f...
1356 -- Hence always typechecked with InferGen
1357 do { mono_info <- tcLhsSigId no_gen (name, sig)
1358 ; return (TcFunBind mono_info nm_loc matches) }
1359
1360 | otherwise -- No type signature
1361 = do { mono_ty <- newOpenFlexiTyVarTy
1362 ; mono_id <- newLetBndr no_gen name mono_ty
1363 ; let mono_info = MBI { mbi_poly_name = name
1364 , mbi_sig = Nothing
1365 , mbi_mono_id = mono_id }
1366 ; return (TcFunBind mono_info nm_loc matches) }
1367
1368 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
1369 = -- See Note [Typechecking pattern bindings]
1370 do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
1371
1372 ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
1373 [ (mbi_poly_name mbi, mbi_mono_id mbi)
1374 | mbi <- sig_mbis ]
1375
1376 -- See Note [Existentials in pattern bindings]
1377 ; ((pat', nosig_mbis), pat_ty)
1378 <- addErrCtxt (patMonoBindsCtxt pat grhss) $
1379 tcInferNoInst $ \ exp_ty ->
1380 tcLetPat inst_sig_fun no_gen pat exp_ty $
1381 mapM lookup_info nosig_names
1382
1383 ; let mbis = sig_mbis ++ nosig_mbis
1384
1385 ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
1386 | mbi <- mbis, let id = mbi_mono_id mbi ]
1387 $$ ppr no_gen)
1388
1389 ; return (TcPatBind mbis pat' grhss pat_ty) }
1390 where
1391 bndr_names = collectPatBinders pat
1392 (nosig_names, sig_names) = partitionWith find_sig bndr_names
1393
1394 find_sig :: Name -> Either Name (Name, TcIdSigInfo)
1395 find_sig name = case sig_fn name of
1396 Just (TcIdSig sig) -> Right (name, sig)
1397 _ -> Left name
1398
1399 -- After typechecking the pattern, look up the binder
1400 -- names that lack a signature, which the pattern has brought
1401 -- into scope.
1402 lookup_info :: Name -> TcM MonoBindInfo
1403 lookup_info name
1404 = do { mono_id <- tcLookupId name
1405 ; return (MBI { mbi_poly_name = name
1406 , mbi_sig = Nothing
1407 , mbi_mono_id = mono_id }) }
1408
1409 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
1410 -- AbsBind, VarBind impossible
1411
1412 -------------------
1413 tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
1414 tcLhsSigId no_gen (name, sig)
1415 = do { inst_sig <- tcInstSig sig
1416 ; mono_id <- newSigLetBndr no_gen name inst_sig
1417 ; return (MBI { mbi_poly_name = name
1418 , mbi_sig = Just inst_sig
1419 , mbi_mono_id = mono_id }) }
1420
1421 ------------
1422 newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
1423 newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
1424 | CompleteSig { sig_bndr = poly_id } <- id_sig
1425 = addInlinePrags poly_id (lookupPragEnv prags name)
1426 newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
1427 = newLetBndr no_gen name tau
1428
1429 -------------------
1430 tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)
1431 tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
1432 loc matches)
1433 = tcExtendIdBinderStackForRhs [info] $
1434 tcExtendTyVarEnvForRhs mb_sig $
1435 do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
1436 ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
1437 matches (mkCheckExpType $ idType mono_id)
1438 ; return ( FunBind { fun_id = L loc mono_id
1439 , fun_matches = matches'
1440 , fun_co_fn = co_fn
1441 , bind_fvs = placeHolderNamesTc
1442 , fun_tick = [] } ) }
1443
1444 tcRhs (TcPatBind infos pat' grhss pat_ty)
1445 = -- When we are doing pattern bindings we *don't* bring any scoped
1446 -- type variables into scope unlike function bindings
1447 -- Wny not? They are not completely rigid.
1448 -- That's why we have the special case for a single FunBind in tcMonoBinds
1449 tcExtendIdBinderStackForRhs infos $
1450 do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
1451 ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
1452 tcGRHSsPat grhss pat_ty
1453 ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
1454 , pat_rhs_ty = pat_ty
1455 , bind_fvs = placeHolderNamesTc
1456 , pat_ticks = ([],[]) } )}
1457
1458 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
1459 tcExtendTyVarEnvForRhs Nothing thing_inside
1460 = thing_inside
1461 tcExtendTyVarEnvForRhs (Just sig) thing_inside
1462 = tcExtendTyVarEnvFromSig sig thing_inside
1463
1464 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
1465 tcExtendTyVarEnvFromSig sig_inst thing_inside
1466 | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
1467 = tcExtendTyVarEnv2 wcs $
1468 tcExtendTyVarEnv2 skol_prs $
1469 thing_inside
1470
1471 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
1472 -- Extend the TcIdBinderStack for the RHS of the binding, with
1473 -- the monomorphic Id. That way, if we have, say
1474 -- f = \x -> blah
1475 -- and something goes wrong in 'blah', we get a "relevant binding"
1476 -- looking like f :: alpha -> beta
1477 -- This applies if 'f' has a type signature too:
1478 -- f :: forall a. [a] -> [a]
1479 -- f x = True
1480 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
1481 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
1482 -- would not be reported as relevant, because its type is closed
1483 tcExtendIdBinderStackForRhs infos thing_inside
1484 = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
1485 | MBI { mbi_mono_id = mono_id } <- infos ]
1486 thing_inside
1487 -- NotTopLevel: it's a monomorphic binding
1488
1489 ---------------------
1490 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
1491 getMonoBindInfo tc_binds
1492 = foldr (get_info . unLoc) [] tc_binds
1493 where
1494 get_info (TcFunBind info _ _) rest = info : rest
1495 get_info (TcPatBind infos _ _ _) rest = infos ++ rest
1496
1497
1498 {- Note [Typechecking pattern bindings]
1499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1500 Look at:
1501 - typecheck/should_compile/ExPat
1502 - Trac #12427, typecheck/should_compile/T12427{a,b}
1503
1504 data T where
1505 MkT :: Integral a => a -> Int -> T
1506
1507 and suppose t :: T. Which of these pattern bindings are ok?
1508
1509 E1. let { MkT p _ = t } in <body>
1510
1511 E2. let { MkT _ q = t } in <body>
1512
1513 E3. let { MkT (toInteger -> r) _ = t } in <body>
1514
1515 * (E1) is clearly wrong because the existential 'a' escapes.
1516 What type could 'p' possibly have?
1517
1518 * (E2) is fine, despite the existential pattern, because
1519 q::Int, and nothing escapes.
1520
1521 * Even (E3) is fine. The existential pattern binds a dictionary
1522 for (Integral a) which the view pattern can use to convert the
1523 a-valued field to an Integer, so r :: Integer.
1524
1525 An easy way to see all three is to imagine the desugaring.
1526 For (E2) it would look like
1527 let q = case t of MkT _ q' -> q'
1528 in <body>
1529
1530
1531 We typecheck pattern bindings as follows. First tcLhs does this:
1532
1533 1. Take each type signature q :: ty, partial or complete, and
1534 instantiate it (with tcLhsSigId) to get a MonoBindInfo. This
1535 gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
1536 a fresh name.
1537
1538 Any fresh unification variables in instantiate(ty) born here, not
1539 deep under implications as would happen if we allocated them when
1540 we encountered q during tcPat.
1541
1542 2. Build a little environment mapping "q" -> "qm" for those Ids
1543 with signatures (inst_sig_fun)
1544
1545 3. Invoke tcLetPat to typecheck the pattern.
1546
1547 - We pass in the current TcLevel. This is captured by
1548 TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
1549 PatEnv.
1550
1551 - When tcPat finds an existential constructor, it binds fresh
1552 type variables and dictionaries as usual, increments the TcLevel,
1553 and emits an implication constraint.
1554
1555 - When we come to a binder (TcPat.tcPatBndr), it looks it up
1556 in the little environment (the pc_sig_fn field of PatCtxt).
1557
1558 Success => There was a type signature, so just use it,
1559 checking compatibility with the expected type.
1560
1561 Failure => No type sigature.
1562 Infer case: (happens only outside any constructor pattern)
1563 use a unification variable
1564 at the outer level pc_lvl
1565
1566 Check case: use promoteTcType to promote the type
1567 to the outer level pc_lvl. This is the
1568 place where we emit a constraint that'll blow
1569 up if existential capture takes place
1570
1571 Result: the type of the binder is always at pc_lvl. This is
1572 crucial.
1573
1574 4. Throughout, when we are making up an Id for the pattern-bound variables
1575 (newLetBndr), we have two cases:
1576
1577 - If we are generalising (generalisation plan is InferGen or
1578 CheckGen), then the let_bndr_spec will be LetLclBndr. In that case
1579 we want to bind a cloned, local version of the variable, with the
1580 type given by the pattern context, *not* by the signature (even if
1581 there is one; see Trac #7268). The mkExport part of the
1582 generalisation step will do the checking and impedance matching
1583 against the signature.
1584
1585 - If for some some reason we are not generalising (plan = NoGen), the
1586 LetBndrSpec will be LetGblBndr. In that case we must bind the
1587 global version of the Id, and do so with precisely the type given
1588 in the signature. (Then we unify with the type from the pattern
1589 context type.)
1590
1591
1592 And that's it! The implication constraints check for the skolem
1593 escape. It's quite simple and neat, and more expressive than before
1594 e.g. GHC 8.0 rejects (E2) and (E3).
1595
1596 Example for (E1), starting at level 1. We generate
1597 p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
1598 The (a~beta) can't float (because of the 'a'), nor be solved (because
1599 beta is untouchable.)
1600
1601 Example for (E2), we generate
1602 q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
1603 The beta is untoucable, but floats out of the constraint and can
1604 be solved absolutely fine.
1605
1606 ************************************************************************
1607 * *
1608 Generalisation
1609 * *
1610 ********************************************************************* -}
1611
1612 data GeneralisationPlan
1613 = NoGen -- No generalisation, no AbsBinds
1614
1615 | InferGen -- Implicit generalisation; there is an AbsBinds
1616 Bool -- True <=> apply the MR; generalise only unconstrained type vars
1617
1618 | CheckGen (LHsBind GhcRn) TcIdSigInfo
1619 -- One FunBind with a signature
1620 -- Explicit generalisation
1621
1622 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
1623 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
1624
1625 instance Outputable GeneralisationPlan where
1626 ppr NoGen = text "NoGen"
1627 ppr (InferGen b) = text "InferGen" <+> ppr b
1628 ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
1629
1630 decideGeneralisationPlan
1631 :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
1632 -> GeneralisationPlan
1633 decideGeneralisationPlan dflags lbinds closed sig_fn
1634 | has_partial_sigs = InferGen (and partial_sig_mrs)
1635 | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
1636 | do_not_generalise closed = NoGen
1637 | otherwise = InferGen mono_restriction
1638 where
1639 binds = map unLoc lbinds
1640
1641 partial_sig_mrs :: [Bool]
1642 -- One for each partial signature (so empty => no partial sigs)
1643 -- The Bool is True if the signature has no constraint context
1644 -- so we should apply the MR
1645 -- See Note [Partial type signatures and generalisation]
1646 partial_sig_mrs
1647 = [ null theta
1648 | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
1649 <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
1650 , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
1651
1652 has_partial_sigs = not (null partial_sig_mrs)
1653
1654 mono_restriction = xopt LangExt.MonomorphismRestriction dflags
1655 && any restricted binds
1656
1657 do_not_generalise (IsGroupClosed _ True) = False
1658 -- The 'True' means that all of the group's
1659 -- free vars have ClosedTypeId=True; so we can ignore
1660 -- -XMonoLocalBinds, and generalise anyway
1661 do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
1662
1663 -- With OutsideIn, all nested bindings are monomorphic
1664 -- except a single function binding with a signature
1665 one_funbind_with_sig
1666 | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
1667 , Just (TcIdSig sig) <- sig_fn (unLoc v)
1668 = Just (lbind, sig)
1669 | otherwise
1670 = Nothing
1671
1672 -- The Haskell 98 monomorphism restriction
1673 restricted (PatBind {}) = True
1674 restricted (VarBind { var_id = v }) = no_sig v
1675 restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
1676 && no_sig (unLoc v)
1677 restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
1678
1679 restricted_match mg = matchGroupArity mg == 0
1680 -- No args => like a pattern binding
1681 -- Some args => a function binding
1682
1683 no_sig n = not (hasCompleteSig sig_fn n)
1684
1685 isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
1686 isClosedBndrGroup type_env binds
1687 = IsGroupClosed fv_env type_closed
1688 where
1689 type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
1690
1691 fv_env :: NameEnv NameSet
1692 fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
1693
1694 bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)]
1695 bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs })
1696 = let open_fvs = filterNameSet (not . is_closed) fvs
1697 in [(f, open_fvs)]
1698 bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
1699 = let open_fvs = filterNameSet (not . is_closed) fvs
1700 in [(b, open_fvs) | b <- collectPatBinders pat]
1701 bindFvs _
1702 = []
1703
1704 is_closed :: Name -> ClosedTypeId
1705 is_closed name
1706 | Just thing <- lookupNameEnv type_env name
1707 = case thing of
1708 AGlobal {} -> True
1709 ATcId { tct_info = ClosedLet } -> True
1710 _ -> False
1711
1712 | otherwise
1713 = True -- The free-var set for a top level binding mentions
1714
1715
1716 is_closed_type_id :: Name -> Bool
1717 -- We're already removed Global and ClosedLet Ids
1718 is_closed_type_id name
1719 | Just thing <- lookupNameEnv type_env name
1720 = case thing of
1721 ATcId { tct_info = NonClosedLet _ cl } -> cl
1722 ATcId { tct_info = NotLetBound } -> False
1723 ATyVar {} -> False
1724 -- In-scope type variables are not closed!
1725 _ -> pprPanic "is_closed_id" (ppr name)
1726
1727 | otherwise
1728 = True -- The free-var set for a top level binding mentions
1729 -- imported things too, so that we can report unused imports
1730 -- These won't be in the local type env.
1731 -- Ditto class method etc from the current module
1732
1733
1734 {- *********************************************************************
1735 * *
1736 Error contexts and messages
1737 * *
1738 ********************************************************************* -}
1739
1740 -- This one is called on LHS, when pat and grhss are both Name
1741 -- and on RHS, when pat is TcId and grhss is still Name
1742 patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body)
1743 => LPat p -> GRHSs GhcRn body -> SDoc
1744 patMonoBindsCtxt pat grhss
1745 = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)