TH: make `Lift` and `TExp` levity-polymorphic
[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 HsSyn
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 noExt (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 empty_subst tvs tys
301 where
302 empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))
303
304 go subst [] []
305 = return subst
306 go subst (tv:tvs) (ty:tys)
307 | tv_kind `tcEqType` ty_kind
308 = go (extendTCvSubst subst tv ty) tvs tys
309 | otherwise
310 = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
311 ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }
312 where
313 tv_kind = substTy subst (tyVarKind tv)
314 ty_kind = tcTypeKind ty
315
316 go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
317
318 {-
319 ************************************************************************
320 * *
321 Instantiating a call
322 * *
323 ************************************************************************
324
325 Note [Handling boxed equality]
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 The solver deals entirely in terms of unboxed (primitive) equality.
328 There should never be a boxed Wanted equality. Ever. But, what if
329 we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
330 is boxed, so naive treatment here would emit a boxed Wanted equality.
331
332 So we simply check for this case and make the right boxing of evidence.
333
334 -}
335
336 ----------------
337 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
338 -- Instantiate the constraints of a call
339 -- (instCall o tys theta)
340 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
341 -- (b) Throws these dictionaries into the LIE
342 -- (c) Returns an HsWrapper ([.] tys dicts)
343
344 instCall orig tys theta
345 = do { dict_app <- instCallConstraints orig theta
346 ; return (dict_app <.> mkWpTyApps tys) }
347
348 ----------------
349 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
350 -- Instantiates the TcTheta, puts all constraints thereby generated
351 -- into the LIE, and returns a HsWrapper to enclose the call site.
352
353 instCallConstraints orig preds
354 | null preds
355 = return idHsWrapper
356 | otherwise
357 = do { evs <- mapM go preds
358 ; traceTc "instCallConstraints" (ppr evs)
359 ; return (mkWpEvApps evs) }
360 where
361 go :: TcPredType -> TcM EvTerm
362 go pred
363 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
364 = do { co <- unifyType Nothing ty1 ty2
365 ; return (evCoercion co) }
366
367 -- Try short-cut #2
368 | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
369 , tc `hasKey` heqTyConKey
370 = do { co <- unifyType Nothing ty1 ty2
371 ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
372
373 | otherwise
374 = emitWanted orig pred
375
376 instDFunType :: DFunId -> [DFunInstType]
377 -> TcM ( [TcType] -- instantiated argument types
378 , TcThetaType ) -- instantiated constraint
379 -- See Note [DFunInstType: instantiating types] in InstEnv
380 instDFunType dfun_id dfun_inst_tys
381 = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
382 ; return (inst_tys, substTheta subst dfun_theta) }
383 where
384 dfun_ty = idType dfun_id
385 (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
386 empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
387 -- With quantified constraints, the
388 -- type of a dfun may not be closed
389
390 go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
391 go subst [] [] = return (subst, [])
392 go subst (tv:tvs) (Just ty : mb_tys)
393 = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
394 tvs
395 mb_tys
396 ; return (subst', ty : tys) }
397 go subst (tv:tvs) (Nothing : mb_tys)
398 = do { (subst', tv') <- newMetaTyVarX subst tv
399 ; (subst'', tys) <- go subst' tvs mb_tys
400 ; return (subst'', mkTyVarTy tv' : tys) }
401 go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
402
403 ----------------
404 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
405 -- Similar to instCall, but only emit the constraints in the LIE
406 -- Used exclusively for the 'stupid theta' of a data constructor
407 instStupidTheta orig theta
408 = do { _co <- instCallConstraints orig theta -- Discard the coercion
409 ; return () }
410
411
412 {- *********************************************************************
413 * *
414 Instantiating Kinds
415 * *
416 ********************************************************************* -}
417
418 -- | Instantiates up to n invisible binders
419 -- Returns the instantiating types, and body kind
420 tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)
421
422 tcInstInvisibleTyBinders 0 kind
423 = return ([], kind)
424 tcInstInvisibleTyBinders n ty
425 = go n empty_subst ty
426 where
427 empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
428
429 go n subst kind
430 | n > 0
431 , Just (bndr, body) <- tcSplitPiTy_maybe kind
432 , isInvisibleBinder bndr
433 = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
434 ; (args, inner_ty) <- go (n-1) subst' body
435 ; return (arg:args, inner_ty) }
436 | otherwise
437 = return ([], substTy subst kind)
438
439 -- | Used only in *types*
440 tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
441 tcInstInvisibleTyBinder subst (Named (Bndr tv _))
442 = do { (subst', tv') <- newMetaTyVarX subst tv
443 ; return (subst', mkTyVarTy tv') }
444
445 tcInstInvisibleTyBinder subst (Anon af ty)
446 | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)
447 -- Equality is the *only* constraint currently handled in types.
448 -- See Note [Constraints in kinds] in TyCoRep
449 = ASSERT( af == InvisArg )
450 do { co <- unifyKind Nothing k1 k2
451 ; arg' <- mk co
452 ; return (subst, arg') }
453
454 | otherwise -- This should never happen
455 -- See TyCoRep Note [Constraints in kinds]
456 = pprPanic "tcInvisibleTyBinder" (ppr ty)
457
458 -------------------------------
459 get_eq_tys_maybe :: Type
460 -> Maybe ( Coercion -> TcM Type
461 -- given a coercion proving t1 ~# t2, produce the
462 -- right instantiation for the TyBinder at hand
463 , Type -- t1
464 , Type -- t2
465 )
466 -- See Note [Constraints in kinds] in TyCoRep
467 get_eq_tys_maybe ty
468 -- Lifted heterogeneous equality (~~)
469 | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
470 , tc `hasKey` heqTyConKey
471 = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
472
473 -- Lifted homogeneous equality (~)
474 | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
475 , tc `hasKey` eqTyConKey
476 = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
477
478 | otherwise
479 = Nothing
480
481 -- | This takes @a ~# b@ and returns @a ~~ b@.
482 mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
483 -- monadic just for convenience with mkEqBoxTy
484 mkHEqBoxTy co ty1 ty2
485 = return $
486 mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
487 where k1 = tcTypeKind ty1
488 k2 = tcTypeKind ty2
489
490 -- | This takes @a ~# b@ and returns @a ~ b@.
491 mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
492 mkEqBoxTy co ty1 ty2
493 = return $
494 mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
495 where k = tcTypeKind ty1
496
497 {-
498 ************************************************************************
499 * *
500 Literals
501 * *
502 ************************************************************************
503
504 -}
505
506 {-
507 In newOverloadedLit we convert directly to an Int or Integer if we
508 know that's what we want. This may save some time, by not
509 temporarily generating overloaded literals, but it won't catch all
510 cases (the rest are caught in lookupInst).
511
512 -}
513
514 newOverloadedLit :: HsOverLit GhcRn
515 -> ExpRhoType
516 -> TcM (HsOverLit GhcTcId)
517 newOverloadedLit
518 lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
519 | not rebindable
520 -- all built-in overloaded lits are tau-types, so we can just
521 -- tauify the ExpType
522 = do { res_ty <- expTypeToType res_ty
523 ; dflags <- getDynFlags
524 ; case shortCutLit dflags val res_ty of
525 -- Do not generate a LitInst for rebindable syntax.
526 -- Reason: If we do, tcSimplify will call lookupInst, which
527 -- will call tcSyntaxName, which does unification,
528 -- which tcSimplify doesn't like
529 Just expr -> return (lit { ol_witness = expr
530 , ol_ext = OverLitTc False res_ty })
531 Nothing -> newNonTrivialOverloadedLit orig lit
532 (mkCheckExpType res_ty) }
533
534 | otherwise
535 = newNonTrivialOverloadedLit orig lit res_ty
536 where
537 orig = LiteralOrigin lit
538 newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"
539
540 -- Does not handle things that 'shortCutLit' can handle. See also
541 -- newOverloadedLit in TcUnify
542 newNonTrivialOverloadedLit :: CtOrigin
543 -> HsOverLit GhcRn
544 -> ExpRhoType
545 -> TcM (HsOverLit GhcTcId)
546 newNonTrivialOverloadedLit orig
547 lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
548 , ol_ext = rebindable }) res_ty
549 = do { hs_lit <- mkOverLit val
550 ; let lit_ty = hsLitType hs_lit
551 ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
552 [synKnownType lit_ty] res_ty $
553 \_ -> return ()
554 ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
555 ; res_ty <- readExpType res_ty
556 ; return (lit { ol_witness = witness
557 , ol_ext = OverLitTc rebindable res_ty }) }
558 newNonTrivialOverloadedLit _ lit _
559 = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
560
561 ------------
562 mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
563 mkOverLit (HsIntegral i)
564 = do { integer_ty <- tcMetaTy integerTyConName
565 ; return (HsInteger (il_text i)
566 (il_value i) integer_ty) }
567
568 mkOverLit (HsFractional r)
569 = do { rat_ty <- tcMetaTy rationalTyConName
570 ; return (HsRat noExt r rat_ty) }
571
572 mkOverLit (HsIsString src s) = return (HsString src s)
573
574 {-
575 ************************************************************************
576 * *
577 Re-mappable syntax
578
579 Used only for arrow syntax -- find a way to nuke this
580 * *
581 ************************************************************************
582
583 Suppose we are doing the -XRebindableSyntax thing, and we encounter
584 a do-expression. We have to find (>>) in the current environment, which is
585 done by the rename. Then we have to check that it has the same type as
586 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
587 this:
588
589 (>>) :: HB m n mn => m a -> n b -> mn b
590
591 So the idea is to generate a local binding for (>>), thus:
592
593 let then72 :: forall a b. m a -> m b -> m b
594 then72 = ...something involving the user's (>>)...
595 in
596 ...the do-expression...
597
598 Now the do-expression can proceed using then72, which has exactly
599 the expected type.
600
601 In fact tcSyntaxName just generates the RHS for then72, because we only
602 want an actual binding in the do-expression case. For literals, we can
603 just use the expression inline.
604 -}
605
606 tcSyntaxName :: CtOrigin
607 -> TcType -- ^ Type to instantiate it at
608 -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name)
609 -> TcM (Name, HsExpr GhcTcId)
610 -- ^ (Standard name, suitable expression)
611 -- USED ONLY FOR CmdTop (sigh) ***
612 -- See Note [CmdSyntaxTable] in HsExpr
613
614 tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
615 | std_nm == user_nm
616 = do rhs <- newMethodFromName orig std_nm [ty]
617 return (std_nm, rhs)
618
619 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
620 std_id <- tcLookupId std_nm
621 let
622 -- C.f. newMethodAtLoc
623 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
624 sigma1 = substTyWith [tv] [ty] tau
625 -- Actually, the "tau-type" might be a sigma-type in the
626 -- case of locally-polymorphic methods.
627
628 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
629
630 -- Check that the user-supplied thing has the
631 -- same type as the standard one.
632 -- Tiresome jiggling because tcCheckSigma takes a located expression
633 span <- getSrcSpanM
634 expr <- tcPolyExpr (L span user_nm_expr) sigma1
635 return (std_nm, unLoc expr)
636
637 syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
638 -> TcRn (TidyEnv, SDoc)
639 syntaxNameCtxt name orig ty tidy_env
640 = do { inst_loc <- getCtLocM orig (Just TypeLevel)
641 ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
642 <+> text "(needed by a syntactic construct)"
643 , nest 2 (text "has the required type:"
644 <+> ppr (tidyType tidy_env ty))
645 , nest 2 (pprCtLoc inst_loc) ]
646 ; return (tidy_env, msg) }
647
648 {-
649 ************************************************************************
650 * *
651 Instances
652 * *
653 ************************************************************************
654 -}
655
656 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
657 -- Construct the OverlapFlag from the global module flags,
658 -- but if the overlap_mode argument is (Just m),
659 -- set the OverlapMode to 'm'
660 getOverlapFlag overlap_mode
661 = do { dflags <- getDynFlags
662 ; let overlap_ok = xopt LangExt.OverlappingInstances dflags
663 incoherent_ok = xopt LangExt.IncoherentInstances dflags
664 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
665 , overlapMode = x }
666 default_oflag | incoherent_ok = use (Incoherent NoSourceText)
667 | overlap_ok = use (Overlaps NoSourceText)
668 | otherwise = use (NoOverlap NoSourceText)
669
670 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
671 ; return final_oflag }
672
673 tcGetInsts :: TcM [ClsInst]
674 -- Gets the local class instances.
675 tcGetInsts = fmap tcg_insts getGblEnv
676
677 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
678 -> Class -> [Type] -> TcM ClsInst
679 newClsInst overlap_mode dfun_name tvs theta clas tys
680 = do { (subst, tvs') <- freshenTyVarBndrs tvs
681 -- Be sure to freshen those type variables,
682 -- so they are sure not to appear in any lookup
683 ; let tys' = substTys subst tys
684
685 dfun = mkDictFunId dfun_name tvs theta clas tys
686 -- The dfun uses the original 'tvs' because
687 -- (a) they don't need to be fresh
688 -- (b) they may be mentioned in the ib_binds field of
689 -- an InstInfo, and in TcEnv.pprInstInfoDetails it's
690 -- helpful to use the same names
691
692 ; oflag <- getOverlapFlag overlap_mode
693 ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
694 ; warnIfFlag Opt_WarnOrphans
695 (isOrphan (is_orphan inst))
696 (instOrphWarn inst)
697 ; return inst }
698
699 instOrphWarn :: ClsInst -> SDoc
700 instOrphWarn inst
701 = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
702 $$ text "To avoid this"
703 $$ nest 4 (vcat possibilities)
704 where
705 possibilities =
706 text "move the instance declaration to the module of the class or of the type, or" :
707 text "wrap the type with a newtype and declare the instance on the new type." :
708 []
709
710 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
711 -- Add new locally-defined instances
712 tcExtendLocalInstEnv dfuns thing_inside
713 = do { traceDFuns dfuns
714 ; env <- getGblEnv
715 ; (inst_env', cls_insts') <- foldlM addLocalInst
716 (tcg_inst_env env, tcg_insts env)
717 dfuns
718 ; let env' = env { tcg_insts = cls_insts'
719 , tcg_inst_env = inst_env' }
720 ; setGblEnv env' thing_inside }
721
722 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
723 -- Check that the proposed new instance is OK,
724 -- and then add it to the home inst env
725 -- If overwrite_inst, then we can overwrite a direct match
726 addLocalInst (home_ie, my_insts) ispec
727 = do {
728 -- Load imported instances, so that we report
729 -- duplicates correctly
730
731 -- 'matches' are existing instance declarations that are less
732 -- specific than the new one
733 -- 'dups' are those 'matches' that are equal to the new one
734 ; isGHCi <- getIsGHCi
735 ; eps <- getEps
736 ; tcg_env <- getGblEnv
737
738 -- In GHCi, we *override* any identical instances
739 -- that are also defined in the interactive context
740 -- See Note [Override identical instances in GHCi]
741 ; let home_ie'
742 | isGHCi = deleteFromInstEnv home_ie ispec
743 | otherwise = home_ie
744
745 global_ie = eps_inst_env eps
746 inst_envs = InstEnvs { ie_global = global_ie
747 , ie_local = home_ie'
748 , ie_visible = tcVisibleOrphanMods tcg_env }
749
750 -- Check for inconsistent functional dependencies
751 ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
752 ; unless (null inconsistent_ispecs) $
753 funDepErr ispec inconsistent_ispecs
754
755 -- Check for duplicate instance decls.
756 ; let (_tvs, cls, tys) = instanceHead ispec
757 (matches, _, _) = lookupInstEnv False inst_envs cls tys
758 dups = filter (identicalClsInstHead ispec) (map fst matches)
759 ; unless (null dups) $
760 dupInstErr ispec (head dups)
761
762 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
763
764 {-
765 Note [Signature files and type class instances]
766 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
767 Instances in signature files do not have an effect when compiling:
768 when you compile a signature against an implementation, you will
769 see the instances WHETHER OR NOT the instance is declared in
770 the file (this is because the signatures go in the EPS and we
771 can't filter them out easily.) This is also why we cannot
772 place the instance in the hi file: it would show up as a duplicate,
773 and we don't have instance reexports anyway.
774
775 However, you might find them useful when typechecking against
776 a signature: the instance is a way of indicating to GHC that
777 some instance exists, in case downstream code uses it.
778
779 Implementing this is a little tricky. Consider the following
780 situation (sigof03):
781
782 module A where
783 instance C T where ...
784
785 module ASig where
786 instance C T
787
788 When compiling ASig, A.hi is loaded, which brings its instances
789 into the EPS. When we process the instance declaration in ASig,
790 we should ignore it for the purpose of doing a duplicate check,
791 since it's not actually a duplicate. But don't skip the check
792 entirely, we still want this to fail (tcfail221):
793
794 module ASig where
795 instance C T
796 instance C T
797
798 Note that in some situations, the interface containing the type
799 class instances may not have been loaded yet at all. The usual
800 situation when A imports another module which provides the
801 instances (sigof02m):
802
803 module A(module B) where
804 import B
805
806 See also Note [Signature lazy interface loading]. We can't
807 rely on this, however, since sometimes we'll have spurious
808 type class instances in the EPS, see #9422 (sigof02dm)
809
810 ************************************************************************
811 * *
812 Errors and tracing
813 * *
814 ************************************************************************
815 -}
816
817 traceDFuns :: [ClsInst] -> TcRn ()
818 traceDFuns ispecs
819 = traceTc "Adding instances:" (vcat (map pp ispecs))
820 where
821 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
822 2 (ppr ispec)
823 -- Print the dfun name itself too
824
825 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
826 funDepErr ispec ispecs
827 = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
828 (ispec : ispecs)
829
830 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
831 dupInstErr ispec dup_ispec
832 = addClsInstsErr (text "Duplicate instance declarations:")
833 [ispec, dup_ispec]
834
835 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
836 addClsInstsErr herald ispecs
837 = setSrcSpan (getSrcSpan (head sorted)) $
838 addErr (hang herald 2 (pprInstances sorted))
839 where
840 sorted = sortWith getSrcLoc ispecs
841 -- The sortWith just arranges that instances are dislayed in order
842 -- of source location, which reduced wobbling in error messages,
843 -- and is better for users