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