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