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