27382c5f98fe24fcec3cb74c7790dafbde81d380
[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 -- False <=> instantiate only the invisible 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 = map (binderVar "top_inst") 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) = tcSplitNamedPiTys ty
216 (theta, rho) = tcSplitPhiTy phi
217
218 should_inst bndr
219 | inst_all = True
220 | otherwise = binderVisibility bndr == Invisible
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 binder
371 | Just tv <- binderVar_maybe binder
372 = case lookup_tv tv of
373 Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
374 Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
375 ; return (subst', mkTyVarTy tv') }
376
377 -- This is the *only* constraint currently handled in types.
378 | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
379 = do { let origin = TypeEqOrigin { uo_actual = k1
380 , uo_expected = mkCheckExpType k2
381 , uo_thing = Nothing }
382 ; co <- case role of
383 Nominal -> unifyKind noThing k1 k2
384 Representational -> emitWantedEq origin KindLevel role k1 k2
385 Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder)
386 ; arg' <- mk co k1 k2
387 ; return (subst, arg') }
388
389 | isPredTy substed_ty
390 = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty
391 ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty)
392
393 -- just invent a new variable so that we can continue
394 ; u <- newUnique
395 ; let name = mkSysTvName u (fsLit "dict")
396 ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }
397
398
399 | otherwise
400 = do { ty <- newFlexiTyVarTy substed_ty
401 ; return (subst, ty) }
402
403 where
404 substed_ty = substTy subst (binderType binder)
405
406 lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad
407 ; lookupVarEnv env tv }
408
409 -- handle boxed equality constraints, because it's so easy
410 get_pred_tys_maybe ty
411 | Just (r, k1, k2) <- getEqPredTys_maybe ty
412 = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2)
413 | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
414 = if | tc `hasKey` heqTyConKey
415 -> Just (mkHEqBoxTy, Nominal, k1, k2)
416 | otherwise
417 -> Nothing
418 | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
419 = if | tc `hasKey` eqTyConKey
420 -> Just (mkEqBoxTy, Nominal, k1, k2)
421 | tc `hasKey` coercibleTyConKey
422 -> Just (mkCoercibleBoxTy, Representational, k1, k2)
423 | otherwise
424 -> Nothing
425 | otherwise
426 = Nothing
427
428 -------------------------------
429 -- | This takes @a ~# b@ and returns @a ~~ b@.
430 mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
431 -- monadic just for convenience with mkEqBoxTy
432 mkHEqBoxTy co ty1 ty2
433 = return $
434 mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
435 where k1 = typeKind ty1
436 k2 = typeKind ty2
437
438 -- | This takes @a ~# b@ and returns @a ~ b@.
439 mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
440 mkEqBoxTy co ty1 ty2
441 = do { eq_tc <- tcLookupTyCon eqTyConName
442 ; let [datacon] = tyConDataCons eq_tc
443 ; hetero <- mkHEqBoxTy co ty1 ty2
444 ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] }
445 where k = typeKind ty1
446
447 -- | This takes @a ~R# b@ and returns @Coercible a b@.
448 mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type
449 -- monadic just for convenience with mkEqBoxTy
450 mkCoercibleBoxTy co ty1 ty2
451 = do { return $
452 mkTyConApp (promoteDataCon coercibleDataCon)
453 [k, ty1, ty2, mkCoercionTy co] }
454 where k = typeKind ty1
455
456 {-
457 ************************************************************************
458 * *
459 Literals
460 * *
461 ************************************************************************
462
463 -}
464
465 {-
466 In newOverloadedLit we convert directly to an Int or Integer if we
467 know that's what we want. This may save some time, by not
468 temporarily generating overloaded literals, but it won't catch all
469 cases (the rest are caught in lookupInst).
470
471 -}
472
473 newOverloadedLit :: HsOverLit Name
474 -> ExpRhoType
475 -> TcM (HsOverLit TcId)
476 newOverloadedLit
477 lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty
478 | not rebindable
479 -- all built-in overloaded lits are tau-types, so we can just
480 -- tauify the ExpType
481 = do { res_ty <- expTypeToType res_ty
482 ; dflags <- getDynFlags
483 ; case shortCutLit dflags val res_ty of
484 -- Do not generate a LitInst for rebindable syntax.
485 -- Reason: If we do, tcSimplify will call lookupInst, which
486 -- will call tcSyntaxName, which does unification,
487 -- which tcSimplify doesn't like
488 Just expr -> return (lit { ol_witness = expr, ol_type = res_ty
489 , ol_rebindable = False })
490 Nothing -> newNonTrivialOverloadedLit orig lit
491 (mkCheckExpType res_ty) }
492
493 | otherwise
494 = newNonTrivialOverloadedLit orig lit res_ty
495 where
496 orig = LiteralOrigin lit
497
498 -- Does not handle things that 'shortCutLit' can handle. See also
499 -- newOverloadedLit in TcUnify
500 newNonTrivialOverloadedLit :: CtOrigin
501 -> HsOverLit Name
502 -> ExpRhoType
503 -> TcM (HsOverLit TcId)
504 newNonTrivialOverloadedLit orig
505 lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name)
506 , ol_rebindable = rebindable }) res_ty
507 = do { hs_lit <- mkOverLit val
508 ; let lit_ty = hsLitType hs_lit
509 ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
510 [synKnownType lit_ty] res_ty $
511 \_ -> return ()
512 ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
513 ; res_ty <- readExpType res_ty
514 ; return (lit { ol_witness = witness
515 , ol_type = res_ty
516 , ol_rebindable = rebindable }) }
517 newNonTrivialOverloadedLit _ lit _
518 = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
519
520 ------------
521 mkOverLit :: OverLitVal -> TcM HsLit
522 mkOverLit (HsIntegral src i)
523 = do { integer_ty <- tcMetaTy integerTyConName
524 ; return (HsInteger src i integer_ty) }
525
526 mkOverLit (HsFractional r)
527 = do { rat_ty <- tcMetaTy rationalTyConName
528 ; return (HsRat r rat_ty) }
529
530 mkOverLit (HsIsString src s) = return (HsString src s)
531
532 {-
533 ************************************************************************
534 * *
535 Re-mappable syntax
536
537 Used only for arrow syntax -- find a way to nuke this
538 * *
539 ************************************************************************
540
541 Suppose we are doing the -XRebindableSyntax thing, and we encounter
542 a do-expression. We have to find (>>) in the current environment, which is
543 done by the rename. Then we have to check that it has the same type as
544 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
545 this:
546
547 (>>) :: HB m n mn => m a -> n b -> mn b
548
549 So the idea is to generate a local binding for (>>), thus:
550
551 let then72 :: forall a b. m a -> m b -> m b
552 then72 = ...something involving the user's (>>)...
553 in
554 ...the do-expression...
555
556 Now the do-expression can proceed using then72, which has exactly
557 the expected type.
558
559 In fact tcSyntaxName just generates the RHS for then72, because we only
560 want an actual binding in the do-expression case. For literals, we can
561 just use the expression inline.
562 -}
563
564 tcSyntaxName :: CtOrigin
565 -> TcType -- Type to instantiate it at
566 -> (Name, HsExpr Name) -- (Standard name, user name)
567 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
568 -- USED ONLY FOR CmdTop (sigh) ***
569 -- See Note [CmdSyntaxTable] in HsExpr
570
571 tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
572 | std_nm == user_nm
573 = do rhs <- newMethodFromName orig std_nm ty
574 return (std_nm, rhs)
575
576 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
577 std_id <- tcLookupId std_nm
578 let
579 -- C.f. newMethodAtLoc
580 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
581 sigma1 = substTyWith [tv] [ty] tau
582 -- Actually, the "tau-type" might be a sigma-type in the
583 -- case of locally-polymorphic methods.
584
585 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
586
587 -- Check that the user-supplied thing has the
588 -- same type as the standard one.
589 -- Tiresome jiggling because tcCheckSigma takes a located expression
590 span <- getSrcSpanM
591 expr <- tcPolyExpr (L span user_nm_expr) sigma1
592 return (std_nm, unLoc expr)
593
594 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
595 -> TcRn (TidyEnv, SDoc)
596 syntaxNameCtxt name orig ty tidy_env
597 = do { inst_loc <- getCtLocM orig (Just TypeLevel)
598 ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
599 <+> text "(needed by a syntactic construct)"
600 , nest 2 (text "has the required type:"
601 <+> ppr (tidyType tidy_env ty))
602 , nest 2 (pprCtLoc inst_loc) ]
603 ; return (tidy_env, msg) }
604
605 {-
606 ************************************************************************
607 * *
608 Instances
609 * *
610 ************************************************************************
611 -}
612
613 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
614 -- Construct the OverlapFlag from the global module flags,
615 -- but if the overlap_mode argument is (Just m),
616 -- set the OverlapMode to 'm'
617 getOverlapFlag overlap_mode
618 = do { dflags <- getDynFlags
619 ; let overlap_ok = xopt LangExt.OverlappingInstances dflags
620 incoherent_ok = xopt LangExt.IncoherentInstances dflags
621 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
622 , overlapMode = x }
623 default_oflag | incoherent_ok = use (Incoherent "")
624 | overlap_ok = use (Overlaps "")
625 | otherwise = use (NoOverlap "")
626
627 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
628 ; return final_oflag }
629
630 tcGetInsts :: TcM [ClsInst]
631 -- Gets the local class instances.
632 tcGetInsts = fmap tcg_insts getGblEnv
633
634 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
635 -> Class -> [Type] -> TcM ClsInst
636 newClsInst overlap_mode dfun_name tvs theta clas tys
637 = do { (subst, tvs') <- freshenTyVarBndrs tvs
638 -- Be sure to freshen those type variables,
639 -- so they are sure not to appear in any lookup
640 ; let tys' = substTys subst tys
641 theta' = substTheta subst theta
642 dfun = mkDictFunId dfun_name tvs' theta' clas tys'
643 -- Substituting in the DFun type just makes sure that
644 -- we are using TyVars rather than TcTyVars
645 -- Not sure if this is really the right place to do so,
646 -- but it'll do fine
647 ; oflag <- getOverlapFlag overlap_mode
648 ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
649 ; warnIf (Reason Opt_WarnOrphans)
650 (isOrphan (is_orphan inst))
651 (instOrphWarn inst)
652 ; return inst }
653
654 instOrphWarn :: ClsInst -> SDoc
655 instOrphWarn inst
656 = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
657 $$ text "To avoid this"
658 $$ nest 4 (vcat possibilities)
659 where
660 possibilities =
661 text "move the instance declaration to the module of the class or of the type, or" :
662 text "wrap the type with a newtype and declare the instance on the new type." :
663 []
664
665 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
666 -- Add new locally-defined instances
667 tcExtendLocalInstEnv dfuns thing_inside
668 = do { traceDFuns dfuns
669 ; env <- getGblEnv
670 ; (inst_env', cls_insts') <- foldlM addLocalInst
671 (tcg_inst_env env, tcg_insts env)
672 dfuns
673 ; let env' = env { tcg_insts = cls_insts'
674 , tcg_inst_env = inst_env' }
675 ; setGblEnv env' thing_inside }
676
677 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
678 -- Check that the proposed new instance is OK,
679 -- and then add it to the home inst env
680 -- If overwrite_inst, then we can overwrite a direct match
681 addLocalInst (home_ie, my_insts) ispec
682 = do {
683 -- Load imported instances, so that we report
684 -- duplicates correctly
685
686 -- 'matches' are existing instance declarations that are less
687 -- specific than the new one
688 -- 'dups' are those 'matches' that are equal to the new one
689 ; isGHCi <- getIsGHCi
690 ; eps <- getEps
691 ; tcg_env <- getGblEnv
692
693 -- In GHCi, we *override* any identical instances
694 -- that are also defined in the interactive context
695 -- See Note [Override identical instances in GHCi]
696 ; let home_ie'
697 | isGHCi = deleteFromInstEnv home_ie ispec
698 | otherwise = home_ie
699
700 -- If we're compiling sig-of and there's an external duplicate
701 -- instance, silently ignore it (that's the instance we're
702 -- implementing!) NB: we still count local duplicate instances
703 -- as errors.
704 -- See Note [Signature files and type class instances]
705 global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv
706 | otherwise = eps_inst_env eps
707 inst_envs = InstEnvs { ie_global = global_ie
708 , ie_local = home_ie'
709 , ie_visible = tcVisibleOrphanMods tcg_env }
710
711 -- Check for inconsistent functional dependencies
712 ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
713 ; unless (null inconsistent_ispecs) $
714 funDepErr ispec inconsistent_ispecs
715
716 -- Check for duplicate instance decls.
717 ; let (_tvs, cls, tys) = instanceHead ispec
718 (matches, _, _) = lookupInstEnv False inst_envs cls tys
719 dups = filter (identicalClsInstHead ispec) (map fst matches)
720 ; unless (null dups) $
721 dupInstErr ispec (head dups)
722
723 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
724
725 {-
726 Note [Signature files and type class instances]
727 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
728 Instances in signature files do not have an effect when compiling:
729 when you compile a signature against an implementation, you will
730 see the instances WHETHER OR NOT the instance is declared in
731 the file (this is because the signatures go in the EPS and we
732 can't filter them out easily.) This is also why we cannot
733 place the instance in the hi file: it would show up as a duplicate,
734 and we don't have instance reexports anyway.
735
736 However, you might find them useful when typechecking against
737 a signature: the instance is a way of indicating to GHC that
738 some instance exists, in case downstream code uses it.
739
740 Implementing this is a little tricky. Consider the following
741 situation (sigof03):
742
743 module A where
744 instance C T where ...
745
746 module ASig where
747 instance C T
748
749 When compiling ASig, A.hi is loaded, which brings its instances
750 into the EPS. When we process the instance declaration in ASig,
751 we should ignore it for the purpose of doing a duplicate check,
752 since it's not actually a duplicate. But don't skip the check
753 entirely, we still want this to fail (tcfail221):
754
755 module ASig where
756 instance C T
757 instance C T
758
759 Note that in some situations, the interface containing the type
760 class instances may not have been loaded yet at all. The usual
761 situation when A imports another module which provides the
762 instances (sigof02m):
763
764 module A(module B) where
765 import B
766
767 See also Note [Signature lazy interface loading]. We can't
768 rely on this, however, since sometimes we'll have spurious
769 type class instances in the EPS, see #9422 (sigof02dm)
770
771 ************************************************************************
772 * *
773 Errors and tracing
774 * *
775 ************************************************************************
776 -}
777
778 traceDFuns :: [ClsInst] -> TcRn ()
779 traceDFuns ispecs
780 = traceTc "Adding instances:" (vcat (map pp ispecs))
781 where
782 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
783 2 (ppr ispec)
784 -- Print the dfun name itself too
785
786 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
787 funDepErr ispec ispecs
788 = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
789 (ispec : ispecs)
790
791 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
792 dupInstErr ispec dup_ispec
793 = addClsInstsErr (text "Duplicate instance declarations:")
794 [ispec, dup_ispec]
795
796 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
797 addClsInstsErr herald ispecs
798 = setSrcSpan (getSrcSpan (head sorted)) $
799 addErr (hang herald 2 (pprInstances sorted))
800 where
801 sorted = sortWith getSrcLoc ispecs
802 -- The sortWith just arranges that instances are dislayed in order
803 -- of source location, which reduced wobbling in error messages,
804 -- and is better for users