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