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