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