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