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