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