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