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