8e180b4cf4b827cfb8c97e9081e77112bb7f4472
[ghc.git] / compiler / typecheck / Inst.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 The @Inst@ type: dictionaries or method instances
7 -}
8
9 {-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
10 {-# LANGUAGE FlexibleContexts #-}
11
12 module Inst (
13 deeplySkolemise,
14 topInstantiate, topInstantiateInferred, deeplyInstantiate,
15 instCall, instDFunType, instStupidTheta, instTyVarsWith,
16 newWanted, newWanteds,
17
18 tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
19
20 newOverloadedLit, mkOverLit,
21
22 newClsInst,
23 tcGetInsts, tcGetInstEnvs, getOverlapFlag,
24 tcExtendLocalInstEnv,
25 instCallConstraints, newMethodFromName,
26 tcSyntaxName,
27
28 -- Simple functions over evidence variables
29 tyCoVarsOfWC,
30 tyCoVarsOfCt, tyCoVarsOfCts,
31 ) where
32
33 #include "HsVersions.h"
34
35 import GhcPrelude
36
37 import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp )
38 import {-# SOURCE #-} TcUnify( unifyType, unifyKind )
39
40 import BasicTypes ( IntegralLit(..), SourceText(..) )
41 import FastString
42 import GHC.Hs
43 import TcHsSyn
44 import TcRnMonad
45 import TcEnv
46 import TcEvidence
47 import InstEnv
48 import TysWiredIn ( heqDataCon, eqDataCon )
49 import CoreSyn ( isOrphan )
50 import FunDeps
51 import TcMType
52 import Type
53 import TyCoRep
54 import TcType
55 import HscTypes
56 import Class( Class )
57 import MkId( mkDictFunId )
58 import CoreSyn( Expr(..) ) -- For the Coercion constructor
59 import Id
60 import Name
61 import Var ( EvVar, tyVarName, VarBndr(..) )
62 import DataCon
63 import VarEnv
64 import PrelNames
65 import SrcLoc
66 import DynFlags
67 import Util
68 import Outputable
69 import qualified GHC.LanguageExtensions as LangExt
70
71 import Control.Monad( unless )
72
73 {-
74 ************************************************************************
75 * *
76 Creating and emittind constraints
77 * *
78 ************************************************************************
79 -}
80
81 newMethodFromName
82 :: CtOrigin -- ^ why do we need this?
83 -> Name -- ^ name of the method
84 -> [TcRhoType] -- ^ types with which to instantiate the class
85 -> TcM (HsExpr GhcTcId)
86 -- ^ Used when 'Name' is the wired-in name for a wired-in class method,
87 -- so the caller knows its type for sure, which should be of form
88 --
89 -- > forall a. C a => <blah>
90 --
91 -- 'newMethodFromName' is supposed to instantiate just the outer
92 -- type variable and constraint
93
94 newMethodFromName origin name ty_args
95 = do { id <- tcLookupId name
96 -- Use tcLookupId not tcLookupGlobalId; the method is almost
97 -- always a class op, but with -XRebindableSyntax GHC is
98 -- meant to find whatever thing is in scope, and that may
99 -- be an ordinary function.
100
101 ; let ty = piResultTys (idType id) ty_args
102 (theta, _caller_knows_this) = tcSplitPhiTy ty
103 ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
104 instCall origin ty_args theta
105
106 ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) }
107
108 {-
109 ************************************************************************
110 * *
111 Deep instantiation and skolemisation
112 * *
113 ************************************************************************
114
115 Note [Deep skolemisation]
116 ~~~~~~~~~~~~~~~~~~~~~~~~~
117 deeplySkolemise decomposes and skolemises a type, returning a type
118 with all its arrows visible (ie not buried under foralls)
119
120 Examples:
121
122 deeplySkolemise (Int -> forall a. Ord a => blah)
123 = ( wp, [a], [d:Ord a], Int -> blah )
124 where wp = \x:Int. /\a. \(d:Ord a). <hole> x
125
126 deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
127 = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
128 where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
129
130 In general,
131 if deeplySkolemise ty = (wrap, tvs, evs, rho)
132 and e :: rho
133 then wrap e :: ty
134 and 'wrap' binds tvs, evs
135
136 ToDo: this eta-abstraction plays fast and loose with termination,
137 because it can introduce extra lambdas. Maybe add a `seq` to
138 fix this
139 -}
140
141 deeplySkolemise :: TcSigmaType
142 -> TcM ( HsWrapper
143 , [(Name,TyVar)] -- All skolemised variables
144 , [EvVar] -- All "given"s
145 , TcRhoType )
146
147 deeplySkolemise ty
148 = go init_subst ty
149 where
150 init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
151
152 go subst ty
153 | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
154 = do { let arg_tys' = substTys subst arg_tys
155 ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys'
156 ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
157 ; ev_vars1 <- newEvVars (substTheta subst' theta)
158 ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
159 ; let tv_prs1 = map tyVarName tvs `zip` tvs1
160 ; return ( mkWpLams ids1
161 <.> mkWpTyLams tvs1
162 <.> mkWpLams ev_vars1
163 <.> wrap
164 <.> mkWpEvVarApps ids1
165 , tv_prs1 ++ tvs_prs2
166 , ev_vars1 ++ ev_vars2
167 , mkVisFunTys arg_tys' rho ) }
168
169 | otherwise
170 = return (idHsWrapper, [], [], substTy subst ty)
171 -- substTy is a quick no-op on an empty substitution
172
173 -- | Instantiate all outer type variables
174 -- and any context. Never looks through arrows.
175 topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
176 -- if topInstantiate ty = (wrap, rho)
177 -- and e :: ty
178 -- then wrap e :: rho (that is, wrap :: ty "->" rho)
179 topInstantiate = top_instantiate True
180
181 -- | Instantiate all outer 'Inferred' binders
182 -- and any context. Never looks through arrows or specified type variables.
183 -- Used for visible type application.
184 topInstantiateInferred :: CtOrigin -> TcSigmaType
185 -> TcM (HsWrapper, TcSigmaType)
186 -- if topInstantiate ty = (wrap, rho)
187 -- and e :: ty
188 -- then wrap e :: rho
189 topInstantiateInferred = top_instantiate False
190
191 top_instantiate :: Bool -- True <=> instantiate *all* variables
192 -- False <=> instantiate only the inferred ones
193 -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
194 top_instantiate inst_all orig ty
195 | not (null binders && null theta)
196 = do { let (inst_bndrs, leave_bndrs) = span should_inst binders
197 (inst_theta, leave_theta)
198 | null leave_bndrs = (theta, [])
199 | otherwise = ([], theta)
200 in_scope = mkInScopeSet (tyCoVarsOfType ty)
201 empty_subst = mkEmptyTCvSubst in_scope
202 inst_tvs = binderVars inst_bndrs
203 ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
204 ; let inst_theta' = substTheta subst inst_theta
205 sigma' = substTy subst (mkForAllTys leave_bndrs $
206 mkPhiTy leave_theta rho)
207 inst_tv_tys' = mkTyVarTys inst_tvs'
208
209 ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
210 ; traceTc "Instantiating"
211 (vcat [ text "all tyvars?" <+> ppr inst_all
212 , text "origin" <+> pprCtOrigin orig
213 , text "type" <+> debugPprType ty
214 , text "theta" <+> ppr theta
215 , text "leave_bndrs" <+> ppr leave_bndrs
216 , text "with" <+> vcat (map debugPprType inst_tv_tys')
217 , text "theta:" <+> ppr inst_theta' ])
218
219 ; (wrap2, rho2) <-
220 if null leave_bndrs
221
222 -- account for types like forall a. Num a => forall b. Ord b => ...
223 then top_instantiate inst_all orig sigma'
224
225 -- but don't loop if there were any un-inst'able tyvars
226 else return (idHsWrapper, sigma')
227
228 ; return (wrap2 <.> wrap1, rho2) }
229
230 | otherwise = return (idHsWrapper, ty)
231 where
232 (binders, phi) = tcSplitForAllVarBndrs ty
233 (theta, rho) = tcSplitPhiTy phi
234
235 should_inst bndr
236 | inst_all = True
237 | otherwise = binderArgFlag bndr == Inferred
238
239 deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
240 -- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha
241 -- In general if
242 -- if deeplyInstantiate ty = (wrap, rho)
243 -- and e :: ty
244 -- then wrap e :: rho
245 -- That is, wrap :: ty ~> rho
246 --
247 -- If you don't need the HsWrapper returned from this function, consider
248 -- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that
249 -- only computes the returned TcRhoType.
250
251 deeplyInstantiate orig ty =
252 deeply_instantiate orig
253 (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
254 ty
255
256 deeply_instantiate :: CtOrigin
257 -> TCvSubst
258 -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
259 -- Internal function to deeply instantiate that builds on an existing subst.
260 -- It extends the input substitution and applies the final subtitution to
261 -- the types on return. See #12549.
262
263 deeply_instantiate orig subst ty
264 | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
265 = do { (subst', tvs') <- newMetaTyVarsX subst tvs
266 ; let arg_tys' = substTys subst' arg_tys
267 theta' = substTheta subst' theta
268 ; ids1 <- newSysLocalIds (fsLit "di") arg_tys'
269 ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
270 ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
271 , text "type" <+> ppr ty
272 , text "with" <+> ppr tvs'
273 , text "args:" <+> ppr ids1
274 , text "theta:" <+> ppr theta'
275 , text "subst:" <+> ppr subst'])
276 ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
277 ; return (mkWpLams ids1
278 <.> wrap2
279 <.> wrap1
280 <.> mkWpEvVarApps ids1,
281 mkVisFunTys arg_tys' rho2) }
282
283 | otherwise
284 = do { let ty' = substTy subst ty
285 ; traceTc "deeply_instantiate final subst"
286 (vcat [ text "origin:" <+> pprCtOrigin orig
287 , text "type:" <+> ppr ty
288 , text "new type:" <+> ppr ty'
289 , text "subst:" <+> ppr subst ])
290 ; return (idHsWrapper, ty') }
291
292
293 instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
294 -- Use this when you want to instantiate (forall a b c. ty) with
295 -- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
296 -- not yet match (perhaps because there are unsolved constraints; #14154)
297 -- If they don't match, emit a kind-equality to promise that they will
298 -- eventually do so, and thus make a kind-homongeneous substitution.
299 instTyVarsWith orig tvs tys
300 = go emptyTCvSubst tvs tys
301 where
302 go subst [] []
303 = return subst
304 go subst (tv:tvs) (ty:tys)
305 | tv_kind `tcEqType` ty_kind
306 = go (extendTvSubstAndInScope subst tv ty) tvs tys
307 | otherwise
308 = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
309 ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys }
310 where
311 tv_kind = substTy subst (tyVarKind tv)
312 ty_kind = tcTypeKind ty
313
314 go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
315
316
317 {-
318 ************************************************************************
319 * *
320 Instantiating a call
321 * *
322 ************************************************************************
323
324 Note [Handling boxed equality]
325 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
326 The solver deals entirely in terms of unboxed (primitive) equality.
327 There should never be a boxed Wanted equality. Ever. But, what if
328 we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
329 is boxed, so naive treatment here would emit a boxed Wanted equality.
330
331 So we simply check for this case and make the right boxing of evidence.
332
333 -}
334
335 ----------------
336 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
337 -- Instantiate the constraints of a call
338 -- (instCall o tys theta)
339 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
340 -- (b) Throws these dictionaries into the LIE
341 -- (c) Returns an HsWrapper ([.] tys dicts)
342
343 instCall orig tys theta
344 = do { dict_app <- instCallConstraints orig theta
345 ; return (dict_app <.> mkWpTyApps tys) }
346
347 ----------------
348 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
349 -- Instantiates the TcTheta, puts all constraints thereby generated
350 -- into the LIE, and returns a HsWrapper to enclose the call site.
351
352 instCallConstraints orig preds
353 | null preds
354 = return idHsWrapper
355 | otherwise
356 = do { evs <- mapM go preds
357 ; traceTc "instCallConstraints" (ppr evs)
358 ; return (mkWpEvApps evs) }
359 where
360 go :: TcPredType -> TcM EvTerm
361 go pred
362 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
363 = do { co <- unifyType Nothing ty1 ty2
364 ; return (evCoercion co) }
365
366 -- Try short-cut #2
367 | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
368 , tc `hasKey` heqTyConKey
369 = do { co <- unifyType Nothing ty1 ty2
370 ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
371
372 | otherwise
373 = emitWanted orig pred
374
375 instDFunType :: DFunId -> [DFunInstType]
376 -> TcM ( [TcType] -- instantiated argument types
377 , TcThetaType ) -- instantiated constraint
378 -- See Note [DFunInstType: instantiating types] in InstEnv
379 instDFunType dfun_id dfun_inst_tys
380 = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
381 ; return (inst_tys, substTheta subst dfun_theta) }
382 where
383 dfun_ty = idType dfun_id
384 (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
385 empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
386 -- With quantified constraints, the
387 -- type of a dfun may not be closed
388
389 go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
390 go subst [] [] = return (subst, [])
391 go subst (tv:tvs) (Just ty : mb_tys)
392 = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
393 tvs
394 mb_tys
395 ; return (subst', ty : tys) }
396 go subst (tv:tvs) (Nothing : mb_tys)
397 = do { (subst', tv') <- newMetaTyVarX subst tv
398 ; (subst'', tys) <- go subst' tvs mb_tys
399 ; return (subst'', mkTyVarTy tv' : tys) }
400 go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
401
402 ----------------
403 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
404 -- Similar to instCall, but only emit the constraints in the LIE
405 -- Used exclusively for the 'stupid theta' of a data constructor
406 instStupidTheta orig theta
407 = do { _co <- instCallConstraints orig theta -- Discard the coercion
408 ; return () }
409
410
411 {- *********************************************************************
412 * *
413 Instantiating Kinds
414 * *
415 ********************************************************************* -}
416
417 -- | Instantiates up to n invisible binders
418 -- Returns the instantiating types, and body kind
419 tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)
420
421 tcInstInvisibleTyBinders 0 kind
422 = return ([], kind)
423 tcInstInvisibleTyBinders n ty
424 = go n empty_subst ty
425 where
426 empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
427
428 go n subst kind
429 | n > 0
430 , Just (bndr, body) <- tcSplitPiTy_maybe kind
431 , isInvisibleBinder bndr
432 = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
433 ; (args, inner_ty) <- go (n-1) subst' body
434 ; return (arg:args, inner_ty) }
435 | otherwise
436 = return ([], substTy subst kind)
437
438 -- | Used only in *types*
439 tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
440 tcInstInvisibleTyBinder subst (Named (Bndr tv _))
441 = do { (subst', tv') <- newMetaTyVarX subst tv
442 ; return (subst', mkTyVarTy tv') }
443
444 tcInstInvisibleTyBinder subst (Anon af ty)
445 | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)
446 -- Equality is the *only* constraint currently handled in types.
447 -- See Note [Constraints in kinds] in TyCoRep
448 = ASSERT( af == InvisArg )
449 do { co <- unifyKind Nothing k1 k2
450 ; arg' <- mk co
451 ; return (subst, arg') }
452
453 | otherwise -- This should never happen
454 -- See TyCoRep Note [Constraints in kinds]
455 = pprPanic "tcInvisibleTyBinder" (ppr ty)
456
457 -------------------------------
458 get_eq_tys_maybe :: Type
459 -> Maybe ( Coercion -> TcM Type
460 -- given a coercion proving t1 ~# t2, produce the
461 -- right instantiation for the TyBinder at hand
462 , Type -- t1
463 , Type -- t2
464 )
465 -- See Note [Constraints in kinds] in TyCoRep
466 get_eq_tys_maybe ty
467 -- Lifted heterogeneous equality (~~)
468 | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
469 , tc `hasKey` heqTyConKey
470 = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
471
472 -- Lifted homogeneous equality (~)
473 | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
474 , tc `hasKey` eqTyConKey
475 = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
476
477 | otherwise
478 = Nothing
479
480 -- | This takes @a ~# b@ and returns @a ~~ b@.
481 mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
482 -- monadic just for convenience with mkEqBoxTy
483 mkHEqBoxTy co ty1 ty2
484 = return $
485 mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
486 where k1 = tcTypeKind ty1
487 k2 = tcTypeKind ty2
488
489 -- | This takes @a ~# b@ and returns @a ~ b@.
490 mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
491 mkEqBoxTy co ty1 ty2
492 = return $
493 mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
494 where k = tcTypeKind ty1
495
496 {-
497 ************************************************************************
498 * *
499 Literals
500 * *
501 ************************************************************************
502
503 -}
504
505 {-
506 In newOverloadedLit we convert directly to an Int or Integer if we
507 know that's what we want. This may save some time, by not
508 temporarily generating overloaded literals, but it won't catch all
509 cases (the rest are caught in lookupInst).
510
511 -}
512
513 newOverloadedLit :: HsOverLit GhcRn
514 -> ExpRhoType
515 -> TcM (HsOverLit GhcTcId)
516 newOverloadedLit
517 lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
518 | not rebindable
519 -- all built-in overloaded lits are tau-types, so we can just
520 -- tauify the ExpType
521 = do { res_ty <- expTypeToType res_ty
522 ; dflags <- getDynFlags
523 ; case shortCutLit dflags val res_ty of
524 -- Do not generate a LitInst for rebindable syntax.
525 -- Reason: If we do, tcSimplify will call lookupInst, which
526 -- will call tcSyntaxName, which does unification,
527 -- which tcSimplify doesn't like
528 Just expr -> return (lit { ol_witness = expr
529 , ol_ext = OverLitTc False res_ty })
530 Nothing -> newNonTrivialOverloadedLit orig lit
531 (mkCheckExpType res_ty) }
532
533 | otherwise
534 = newNonTrivialOverloadedLit orig lit res_ty
535 where
536 orig = LiteralOrigin lit
537 newOverloadedLit (XOverLit nec) _ = noExtCon nec
538
539 -- Does not handle things that 'shortCutLit' can handle. See also
540 -- newOverloadedLit in TcUnify
541 newNonTrivialOverloadedLit :: CtOrigin
542 -> HsOverLit GhcRn
543 -> ExpRhoType
544 -> TcM (HsOverLit GhcTcId)
545 newNonTrivialOverloadedLit orig
546 lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
547 , ol_ext = rebindable }) res_ty
548 = do { hs_lit <- mkOverLit val
549 ; let lit_ty = hsLitType hs_lit
550 ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
551 [synKnownType lit_ty] res_ty $
552 \_ -> return ()
553 ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
554 ; res_ty <- readExpType res_ty
555 ; return (lit { ol_witness = witness
556 , ol_ext = OverLitTc rebindable res_ty }) }
557 newNonTrivialOverloadedLit _ lit _
558 = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
559
560 ------------
561 mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
562 mkOverLit (HsIntegral i)
563 = do { integer_ty <- tcMetaTy integerTyConName
564 ; return (HsInteger (il_text i)
565 (il_value i) integer_ty) }
566
567 mkOverLit (HsFractional r)
568 = do { rat_ty <- tcMetaTy rationalTyConName
569 ; return (HsRat noExtField r rat_ty) }
570
571 mkOverLit (HsIsString src s) = return (HsString src s)
572
573 {-
574 ************************************************************************
575 * *
576 Re-mappable syntax
577
578 Used only for arrow syntax -- find a way to nuke this
579 * *
580 ************************************************************************
581
582 Suppose we are doing the -XRebindableSyntax thing, and we encounter
583 a do-expression. We have to find (>>) in the current environment, which is
584 done by the rename. Then we have to check that it has the same type as
585 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
586 this:
587
588 (>>) :: HB m n mn => m a -> n b -> mn b
589
590 So the idea is to generate a local binding for (>>), thus:
591
592 let then72 :: forall a b. m a -> m b -> m b
593 then72 = ...something involving the user's (>>)...
594 in
595 ...the do-expression...
596
597 Now the do-expression can proceed using then72, which has exactly
598 the expected type.
599
600 In fact tcSyntaxName just generates the RHS for then72, because we only
601 want an actual binding in the do-expression case. For literals, we can
602 just use the expression inline.
603 -}
604
605 tcSyntaxName :: CtOrigin
606 -> TcType -- ^ Type to instantiate it at
607 -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name)
608 -> TcM (Name, HsExpr GhcTcId)
609 -- ^ (Standard name, suitable expression)
610 -- USED ONLY FOR CmdTop (sigh) ***
611 -- See Note [CmdSyntaxTable] in GHC.Hs.Expr
612
613 tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
614 | std_nm == user_nm
615 = do rhs <- newMethodFromName orig std_nm [ty]
616 return (std_nm, rhs)
617
618 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
619 std_id <- tcLookupId std_nm
620 let
621 -- C.f. newMethodAtLoc
622 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
623 sigma1 = substTyWith [tv] [ty] tau
624 -- Actually, the "tau-type" might be a sigma-type in the
625 -- case of locally-polymorphic methods.
626
627 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
628
629 -- Check that the user-supplied thing has the
630 -- same type as the standard one.
631 -- Tiresome jiggling because tcCheckSigma takes a located expression
632 span <- getSrcSpanM
633 expr <- tcPolyExpr (L span user_nm_expr) sigma1
634 return (std_nm, unLoc expr)
635
636 syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
637 -> TcRn (TidyEnv, SDoc)
638 syntaxNameCtxt name orig ty tidy_env
639 = do { inst_loc <- getCtLocM orig (Just TypeLevel)
640 ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
641 <+> text "(needed by a syntactic construct)"
642 , nest 2 (text "has the required type:"
643 <+> ppr (tidyType tidy_env ty))
644 , nest 2 (pprCtLoc inst_loc) ]
645 ; return (tidy_env, msg) }
646
647 {-
648 ************************************************************************
649 * *
650 Instances
651 * *
652 ************************************************************************
653 -}
654
655 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
656 -- Construct the OverlapFlag from the global module flags,
657 -- but if the overlap_mode argument is (Just m),
658 -- set the OverlapMode to 'm'
659 getOverlapFlag overlap_mode
660 = do { dflags <- getDynFlags
661 ; let overlap_ok = xopt LangExt.OverlappingInstances dflags
662 incoherent_ok = xopt LangExt.IncoherentInstances dflags
663 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
664 , overlapMode = x }
665 default_oflag | incoherent_ok = use (Incoherent NoSourceText)
666 | overlap_ok = use (Overlaps NoSourceText)
667 | otherwise = use (NoOverlap NoSourceText)
668
669 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
670 ; return final_oflag }
671
672 tcGetInsts :: TcM [ClsInst]
673 -- Gets the local class instances.
674 tcGetInsts = fmap tcg_insts getGblEnv
675
676 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
677 -> Class -> [Type] -> TcM ClsInst
678 newClsInst overlap_mode dfun_name tvs theta clas tys
679 = do { (subst, tvs') <- freshenTyVarBndrs tvs
680 -- Be sure to freshen those type variables,
681 -- so they are sure not to appear in any lookup
682 ; let tys' = substTys subst tys
683
684 dfun = mkDictFunId dfun_name tvs theta clas tys
685 -- The dfun uses the original 'tvs' because
686 -- (a) they don't need to be fresh
687 -- (b) they may be mentioned in the ib_binds field of
688 -- an InstInfo, and in TcEnv.pprInstInfoDetails it's
689 -- helpful to use the same names
690
691 ; oflag <- getOverlapFlag overlap_mode
692 ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
693 ; warnIfFlag Opt_WarnOrphans
694 (isOrphan (is_orphan inst))
695 (instOrphWarn inst)
696 ; return inst }
697
698 instOrphWarn :: ClsInst -> SDoc
699 instOrphWarn inst
700 = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
701 $$ text "To avoid this"
702 $$ nest 4 (vcat possibilities)
703 where
704 possibilities =
705 text "move the instance declaration to the module of the class or of the type, or" :
706 text "wrap the type with a newtype and declare the instance on the new type." :
707 []
708
709 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
710 -- Add new locally-defined instances
711 tcExtendLocalInstEnv dfuns thing_inside
712 = do { traceDFuns dfuns
713 ; env <- getGblEnv
714 ; (inst_env', cls_insts') <- foldlM addLocalInst
715 (tcg_inst_env env, tcg_insts env)
716 dfuns
717 ; let env' = env { tcg_insts = cls_insts'
718 , tcg_inst_env = inst_env' }
719 ; setGblEnv env' thing_inside }
720
721 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
722 -- Check that the proposed new instance is OK,
723 -- and then add it to the home inst env
724 -- If overwrite_inst, then we can overwrite a direct match
725 addLocalInst (home_ie, my_insts) ispec
726 = do {
727 -- Load imported instances, so that we report
728 -- duplicates correctly
729
730 -- 'matches' are existing instance declarations that are less
731 -- specific than the new one
732 -- 'dups' are those 'matches' that are equal to the new one
733 ; isGHCi <- getIsGHCi
734 ; eps <- getEps
735 ; tcg_env <- getGblEnv
736
737 -- In GHCi, we *override* any identical instances
738 -- that are also defined in the interactive context
739 -- See Note [Override identical instances in GHCi]
740 ; let home_ie'
741 | isGHCi = deleteFromInstEnv home_ie ispec
742 | otherwise = home_ie
743
744 global_ie = eps_inst_env eps
745 inst_envs = InstEnvs { ie_global = global_ie
746 , ie_local = home_ie'
747 , ie_visible = tcVisibleOrphanMods tcg_env }
748
749 -- Check for inconsistent functional dependencies
750 ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
751 ; unless (null inconsistent_ispecs) $
752 funDepErr ispec inconsistent_ispecs
753
754 -- Check for duplicate instance decls.
755 ; let (_tvs, cls, tys) = instanceHead ispec
756 (matches, _, _) = lookupInstEnv False inst_envs cls tys
757 dups = filter (identicalClsInstHead ispec) (map fst matches)
758 ; unless (null dups) $
759 dupInstErr ispec (head dups)
760
761 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
762
763 {-
764 Note [Signature files and type class instances]
765 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
766 Instances in signature files do not have an effect when compiling:
767 when you compile a signature against an implementation, you will
768 see the instances WHETHER OR NOT the instance is declared in
769 the file (this is because the signatures go in the EPS and we
770 can't filter them out easily.) This is also why we cannot
771 place the instance in the hi file: it would show up as a duplicate,
772 and we don't have instance reexports anyway.
773
774 However, you might find them useful when typechecking against
775 a signature: the instance is a way of indicating to GHC that
776 some instance exists, in case downstream code uses it.
777
778 Implementing this is a little tricky. Consider the following
779 situation (sigof03):
780
781 module A where
782 instance C T where ...
783
784 module ASig where
785 instance C T
786
787 When compiling ASig, A.hi is loaded, which brings its instances
788 into the EPS. When we process the instance declaration in ASig,
789 we should ignore it for the purpose of doing a duplicate check,
790 since it's not actually a duplicate. But don't skip the check
791 entirely, we still want this to fail (tcfail221):
792
793 module ASig where
794 instance C T
795 instance C T
796
797 Note that in some situations, the interface containing the type
798 class instances may not have been loaded yet at all. The usual
799 situation when A imports another module which provides the
800 instances (sigof02m):
801
802 module A(module B) where
803 import B
804
805 See also Note [Signature lazy interface loading]. We can't
806 rely on this, however, since sometimes we'll have spurious
807 type class instances in the EPS, see #9422 (sigof02dm)
808
809 ************************************************************************
810 * *
811 Errors and tracing
812 * *
813 ************************************************************************
814 -}
815
816 traceDFuns :: [ClsInst] -> TcRn ()
817 traceDFuns ispecs
818 = traceTc "Adding instances:" (vcat (map pp ispecs))
819 where
820 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
821 2 (ppr ispec)
822 -- Print the dfun name itself too
823
824 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
825 funDepErr ispec ispecs
826 = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
827 (ispec : ispecs)
828
829 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
830 dupInstErr ispec dup_ispec
831 = addClsInstsErr (text "Duplicate instance declarations:")
832 [ispec, dup_ispec]
833
834 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
835 addClsInstsErr herald ispecs
836 = setSrcSpan (getSrcSpan (head sorted)) $
837 addErr (hang herald 2 (pprInstances sorted))
838 where
839 sorted = sortWith getSrcLoc ispecs
840 -- The sortWith just arranges that instances are dislayed in order
841 -- of source location, which reduced wobbling in error messages,
842 -- and is better for users