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