ghc/compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
   5
   6 \begin{code}
   7 module Inst (
   8         LIE, emptyLIE, unitLIE, plusLIE, consLIE,
   9         plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
  10         showLIE,
  11
  12         Inst,
  13         pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
  14
  15         newDictsFromOld, newDicts, cloneDict,
  16         newOverloadedLit, newIPDict,
  17         newMethod, newMethodFromName, newMethodWithGivenTy,
  18         tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
  19
  20         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  21         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  22         instLoc, getDictClassTys, dictPred,
  23
  24         lookupInst, LookupInstResult(..),
  25
  26         isDict, isClassDict, isMethod,
  27         isLinearInst, linearInstType, isIPDict, isInheritableInst,
  28         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  29         instBindingRequired, instCanBeGeneralised,
  30
  31         zonkInst, zonkInsts,
  32         instToId, instName,
  33
  34         InstOrigin(..), InstLoc(..), pprInstLoc
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39 import {-# SOURCE #-}   TcExpr( tcCheckSigma )
  40
  41 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  42 import TcHsSyn  ( TcExpr, TcId, TcIdSet,
  43                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
  44                   mkCoercion, ExprCoFn
  45                 )
  46 import TcRnMonad
  47 import TcEnv    ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
  48 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  49 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType,
  50                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
  51                 )
  52 import TcType   ( Type, TcType, TcThetaType, TcTyVarSet,
  53                   SourceType(..), PredType, TyVarDetails(VanillaTv),
  54                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
  55                   tcSplitPhiTy, mkGenTyConApp,
  56                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  57                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  58                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  59                   isClassPred, isTyVarClassPred, isLinearPred,
  60                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  61                   isInheritablePred, isIPPred,
  62                   tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
  63                 )
  64 import CoreFVs  ( idFreeTyVars )
  65 import DataCon  ( DataCon,dataConSig )
  66 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
  67 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  68 import Name     ( Name, mkMethodOcc, getOccName )
  69 import PprType  ( pprPred, pprParendType )
  70 import Subst    ( substTy, substTyWith, substTheta, mkTyVarSubst )
  71 import Literal  ( inIntRange )
  72 import Var      ( TyVar )
  73 import VarEnv   ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
  74 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  75 import TysWiredIn ( floatDataCon, doubleDataCon )
  76 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
  77 import BasicTypes( IPName(..), mapIPName, ipNameName )
  78 import UniqSupply( uniqsFromSupply )
  79 import Outputable
  80 \end{code}
  81
  82
  83 Selection
  84 ~~~~~~~~~
  85 \begin{code}
  86 instName :: Inst -> Name
  87 instName inst = idName (instToId inst)
  88
  89 instToId :: Inst -> TcId
  90 instToId (Dict id _ _)         = id
  91 instToId (Method id _ _ _ _ _) = id
  92 instToId (LitInst id _ _ _)    = id
  93
  94 instLoc (Dict _ _         loc) = loc
  95 instLoc (Method _ _ _ _ _ loc) = loc
  96 instLoc (LitInst _ _ _    loc) = loc
  97
  98 dictPred (Dict _ pred _ ) = pred
  99 dictPred inst             = pprPanic "dictPred" (ppr inst)
 100
 101 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 102
 103 -- fdPredsOfInst is used to get predicates that contain functional
 104 -- dependencies *or* might do so.  The "might do" part is because
 105 -- a constraint (C a b) might have a superclass with FDs
 106 -- Leaving these in is really important for the call to fdPredsOfInsts
 107 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 108 -- which is supposed to be conservative
 109 fdPredsOfInst (Dict _ pred _)          = [pred]
 110 fdPredsOfInst (Method _ _ _ theta _ _) = theta
 111 fdPredsOfInst other                    = []     -- LitInsts etc
 112
 113 fdPredsOfInsts :: [Inst] -> [PredType]
 114 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 115
 116 isInheritableInst (Dict _ pred _)          = isInheritablePred pred
 117 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
 118 isInheritableInst other                    = True
 119
 120
 121 ipNamesOfInsts :: [Inst] -> [Name]
 122 ipNamesOfInst  :: Inst   -> [Name]
 123 -- Get the implicit parameters mentioned by these Insts
 124 -- NB: ?x and %x get different Names
 125 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 126
 127 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 128 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 129 ipNamesOfInst other                    = []
 130
 131 tyVarsOfInst :: Inst -> TcTyVarSet
 132 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 133 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 134 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 135                                          -- The id might have free type variables; in the case of
 136                                          -- locally-overloaded class methods, for example
 137
 138
 139 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 140 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 141 \end{code}
 142
 143 Predicates
 144 ~~~~~~~~~~
 145 \begin{code}
 146 isDict :: Inst -> Bool
 147 isDict (Dict _ _ _) = True
 148 isDict other        = False
 149
 150 isClassDict :: Inst -> Bool
 151 isClassDict (Dict _ pred _) = isClassPred pred
 152 isClassDict other           = False
 153
 154 isTyVarDict :: Inst -> Bool
 155 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 156 isTyVarDict other           = False
 157
 158 isIPDict :: Inst -> Bool
 159 isIPDict (Dict _ pred _) = isIPPred pred
 160 isIPDict other           = False
 161
 162 isMethod :: Inst -> Bool
 163 isMethod (Method _ _ _ _ _ _) = True
 164 isMethod other                = False
 165
 166 isMethodFor :: TcIdSet -> Inst -> Bool
 167 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 168 isMethodFor ids inst                         = False
 169
 170 isLinearInst :: Inst -> Bool
 171 isLinearInst (Dict _ pred _) = isLinearPred pred
 172 isLinearInst other           = False
 173         -- We never build Method Insts that have
 174         -- linear implicit paramters in them.
 175         -- Hence no need to look for Methods
 176         -- See TcExpr.tcId
 177
 178 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 179 linearInstType (Dict _ (IParam _ ty) _) = ty
 180
 181
 182 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 183                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 184                                         other             -> False
 185 \end{code}
 186
 187 Two predicates which deal with the case where class constraints don't
 188 necessarily result in bindings.  The first tells whether an @Inst@
 189 must be witnessed by an actual binding; the second tells whether an
 190 @Inst@ can be generalised over.
 191
 192 \begin{code}
 193 instBindingRequired :: Inst -> Bool
 194 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 195 instBindingRequired other                      = True
 196
 197 instCanBeGeneralised :: Inst -> Bool
 198 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 199 instCanBeGeneralised other                      = True
 200 \end{code}
 201
 202
 203 %************************************************************************
 204 %*                                                                      *
 205 \subsection{Building dictionaries}
 206 %*                                                                      *
 207 %************************************************************************
 208
 209 \begin{code}
 210 newDicts :: InstOrigin
 211          -> TcThetaType
 212          -> TcM [Inst]
 213 newDicts orig theta
 214   = getInstLoc orig             `thenM` \ loc ->
 215     newDictsAtLoc loc theta
 216
 217 cloneDict :: Inst -> TcM Inst
 218 cloneDict (Dict id ty loc) = newUnique  `thenM` \ uniq ->
 219                              returnM (Dict (setIdUnique id uniq) ty loc)
 220
 221 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
 222 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 223
 224 -- Local function, similar to newDicts,
 225 -- but with slightly different interface
 226 newDictsAtLoc :: InstLoc
 227               -> TcThetaType
 228               -> TcM [Inst]
 229 newDictsAtLoc inst_loc theta
 230   = newUniqueSupply             `thenM` \ us ->
 231     returnM (zipWith mk_dict (uniqsFromSupply us) theta)
 232   where
 233     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
 234                              pred inst_loc
 235     loc = instLocSrcLoc inst_loc
 236
 237 -- For vanilla implicit parameters, there is only one in scope
 238 -- at any time, so we used to use the name of the implicit parameter itself
 239 -- But with splittable implicit parameters there may be many in
 240 -- scope, so we make up a new name.
 241 newIPDict :: InstOrigin -> IPName Name -> Type
 242           -> TcM (IPName Id, Inst)
 243 newIPDict orig ip_name ty
 244   = getInstLoc orig                     `thenM` \ inst_loc@(InstLoc _ loc _) ->
 245     newUnique                           `thenM` \ uniq ->
 246     let
 247         pred = IParam ip_name ty
 248         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
 249     in
 250     returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 251 \end{code}
 252
 253
 254
 255 %************************************************************************
 256 %*                                                                      *
 257 \subsection{Building methods (calls of overloaded functions)}
 258 %*                                                                      *
 259 %************************************************************************
 260
 261
 262 \begin{code}
 263 tcInstCall :: InstOrigin  -> TcType -> TcM (ExprCoFn, TcType)
 264 tcInstCall orig fun_ty  -- fun_ty is usually a sigma-type
 265   = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
 266     newDicts orig theta         `thenM` \ dicts ->
 267     extendLIEs dicts            `thenM_`
 268     let
 269         inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
 270     in
 271     returnM (mkCoercion inst_fn, tau)
 272
 273 tcInstDataCon :: InstOrigin -> DataCon
 274               -> TcM ([TcType], -- Types to instantiate at
 275                       [Inst],   -- Existential dictionaries to apply to
 276                       [TcType], -- Argument types of constructor
 277                       TcType,   -- Result type
 278                       [TyVar])  -- Existential tyvars
 279 tcInstDataCon orig data_con
 280   = let
 281         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 282              -- We generate constraints for the stupid theta even when
 283              -- pattern matching (as the Report requires)
 284     in
 285     tcInstTyVars VanillaTv (tvs ++ ex_tvs)      `thenM` \ (all_tvs', ty_args', tenv) ->
 286     let
 287         stupid_theta' = substTheta tenv stupid_theta
 288         ex_theta'     = substTheta tenv ex_theta
 289         arg_tys'      = map (substTy tenv) arg_tys
 290
 291         n_normal_tvs  = length tvs
 292         ex_tvs'       = drop n_normal_tvs all_tvs'
 293         result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
 294     in
 295     newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
 296     newDicts orig ex_theta'     `thenM` \ ex_dicts ->
 297
 298         -- Note that we return the stupid theta *only* in the LIE;
 299         -- we don't otherwise use it at all
 300     extendLIEs stupid_dicts     `thenM_`
 301
 302     returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
 303
 304 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
 305 newMethodFromName origin ty name
 306   = tcLookupId name             `thenM` \ id ->
 307         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 308         -- always a class op, but with -fno-implicit-prelude GHC is
 309         -- meant to find whatever thing is in scope, and that may
 310         -- be an ordinary function.
 311     getInstLoc origin           `thenM` \ loc ->
 312     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 313     extendLIE inst              `thenM_`
 314     returnM (instToId inst)
 315
 316 newMethodWithGivenTy orig id tys theta tau
 317   = getInstLoc orig                     `thenM` \ loc ->
 318     newMethod loc id tys theta tau      `thenM` \ inst ->
 319     extendLIE inst                      `thenM_`
 320     returnM (instToId inst)
 321
 322 --------------------------------------------
 323 -- tcInstClassOp, and newMethod do *not* drop the
 324 -- Inst into the LIE; they just returns the Inst
 325 -- This is important because they are used by TcSimplify
 326 -- to simplify Insts
 327
 328 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 329 tcInstClassOp inst_loc sel_id tys
 330   = let
 331         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 332         rho_ty       = ASSERT( length tyvars == length tys )
 333                        substTyWith tyvars tys rho
 334         (preds,tau)  = tcSplitPhiTy rho_ty
 335     in
 336     newMethod inst_loc sel_id tys preds tau
 337
 338 ---------------------------
 339 newMethod inst_loc id tys theta tau
 340   = newUnique           `thenM` \ new_uniq ->
 341     let
 342         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 343         inst    = Method meth_id id tys theta tau inst_loc
 344         loc     = instLocSrcLoc inst_loc
 345     in
 346     returnM inst
 347 \end{code}
 348
 349 In newOverloadedLit we convert directly to an Int or Integer if we
 350 know that's what we want.  This may save some time, by not
 351 temporarily generating overloaded literals, but it won't catch all
 352 cases (the rest are caught in lookupInst).
 353
 354 \begin{code}
 355 newOverloadedLit :: InstOrigin
 356                  -> HsOverLit
 357                  -> TcType
 358                  -> TcM TcExpr
 359 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 360   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable
 361                                 -- syntax.  Reason: tcSyntaxName does unification
 362                                 -- which is very inconvenient in tcSimplify
 363   = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi)   `thenM` \ (_,expr) ->
 364     returnM (HsApp expr (HsLit (HsInteger i)))
 365
 366   | Just expr <- shortCutIntLit i expected_ty
 367   = returnM expr
 368
 369   | otherwise
 370   = newLitInst orig lit expected_ty
 371
 372 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 373   | fr /= fromRationalName      -- c.f. HsIntegral case
 374   = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr)  `thenM` \ (_,expr) ->
 375     mkRatLit r                                                  `thenM` \ rat_lit ->
 376     returnM (HsApp expr rat_lit)
 377
 378   | Just expr <- shortCutFracLit r expected_ty
 379   = returnM expr
 380
 381   | otherwise
 382   = newLitInst orig lit expected_ty
 383
 384 newLitInst orig lit expected_ty
 385   = getInstLoc orig             `thenM` \ loc ->
 386     newUnique                   `thenM` \ new_uniq ->
 387     let
 388         lit_inst = LitInst lit_id lit expected_ty loc
 389         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 390     in
 391     extendLIE lit_inst          `thenM_`
 392     returnM (HsVar (instToId lit_inst))
 393
 394 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
 395 shortCutIntLit i ty
 396   | isIntTy ty && inIntRange i                  -- Short cut for Int
 397   = Just (HsLit (HsInt i))
 398   | isIntegerTy ty                              -- Short cut for Integer
 399   = Just (HsLit (HsInteger i))
 400   | otherwise = Nothing
 401
 402 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
 403 shortCutFracLit f ty
 404   | isFloatTy ty
 405   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 406   | isDoubleTy ty
 407   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 408   | otherwise = Nothing
 409
 410 mkRatLit :: Rational -> TcM TcExpr
 411 mkRatLit r
 412   = tcLookupTyCon rationalTyConName                     `thenM` \ rat_tc ->
 413     let
 414         rational_ty  = mkGenTyConApp rat_tc []
 415     in
 416     returnM (HsLit (HsRat r rational_ty))
 417 \end{code}
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection{Zonking}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 Zonking makes sure that the instance types are fully zonked,
 427 but doesn't do the same for any of the Ids in an Inst.  There's no
 428 need, and it's a lot of extra work.
 429
 430 \begin{code}
 431 zonkInst :: Inst -> TcM Inst
 432 zonkInst (Dict id pred loc)
 433   = zonkTcPredType pred                 `thenM` \ new_pred ->
 434     returnM (Dict id new_pred loc)
 435
 436 zonkInst (Method m id tys theta tau loc)
 437   = zonkId id                   `thenM` \ new_id ->
 438         -- Essential to zonk the id in case it's a local variable
 439         -- Can't use zonkIdOcc because the id might itself be
 440         -- an InstId, in which case it won't be in scope
 441
 442     zonkTcTypes tys             `thenM` \ new_tys ->
 443     zonkTcThetaType theta       `thenM` \ new_theta ->
 444     zonkTcType tau              `thenM` \ new_tau ->
 445     returnM (Method m new_id new_tys new_theta new_tau loc)
 446
 447 zonkInst (LitInst id lit ty loc)
 448   = zonkTcType ty                       `thenM` \ new_ty ->
 449     returnM (LitInst id lit new_ty loc)
 450
 451 zonkInsts insts = mappM zonkInst insts
 452 \end{code}
 453
 454
 455 %************************************************************************
 456 %*                                                                      *
 457 \subsection{Printing}
 458 %*                                                                      *
 459 %************************************************************************
 460
 461 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 462 relevant in error messages.
 463
 464 \begin{code}
 465 instance Outputable Inst where
 466     ppr inst = pprInst inst
 467
 468 pprInsts :: [Inst] -> SDoc
 469 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 470
 471 pprInstsInFull insts
 472   = vcat (map go insts)
 473   where
 474     go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
 475
 476 pprInst (LitInst u lit ty loc)
 477   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 478
 479 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 480
 481 pprInst m@(Method u id tys theta tau loc)
 482   = hsep [ppr id, ptext SLIT("at"),
 483           brackets (sep (map pprParendType tys)) {- ,
 484           ptext SLIT("theta"), ppr theta,
 485           ptext SLIT("tau"), ppr tau
 486           show_uniq u,
 487           ppr (instToId m) -}]
 488
 489 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 490
 491 tidyInst :: TidyEnv -> Inst -> Inst
 492 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 493 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 494 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 495
 496 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 497 -- This function doesn't assume that the tyvars are in scope
 498 -- so it works like tidyOpenType, returning a TidyEnv
 499 tidyMoreInsts env insts
 500   = (env', map (tidyInst env') insts)
 501   where
 502     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 503
 504 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 505 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 506
 507 showLIE :: SDoc -> TcM ()       -- Debugging
 508 showLIE str
 509   = do { lie_var <- getLIEVar ;
 510          lie <- readMutVar lie_var ;
 511          traceTc (str <+> pprInstsInFull (lieToList lie)) }
 512 \end{code}
 513
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsection{Looking up Insts}
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 \begin{code}
 522 data LookupInstResult s
 523   = NoInstance
 524   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 525   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 526
 527 lookupInst :: Inst -> TcM (LookupInstResult s)
 528 -- It's important that lookupInst does not put any new stuff into
 529 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 530 -- the LookupInstResult, where they can be further processed by tcSimplify
 531
 532
 533 -- Dictionaries
 534 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 535   = getDOpts                    `thenM` \ dflags ->
 536     tcGetInstEnv                `thenM` \ inst_env ->
 537     case lookupInstEnv dflags inst_env clas tys of
 538
 539       FoundInst tenv dfun_id
 540         ->      -- It's possible that not all the tyvars are in
 541                 -- the substitution, tenv. For example:
 542                 --      instance C X a => D X where ...
 543                 -- (presumably there's a functional dependency in class C)
 544                 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 545            getStage                                             `thenM` \ use_stage ->
 546            checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 547                            (topIdLvl dfun_id) use_stage         `thenM_`
 548            traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
 549            let
 550                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 551                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 552                                    Just (DoneTy ty) -> returnM ty
 553                                    Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 554                                                        returnM (mkTyVarTy tc_tv)
 555            in
 556            mappM mk_ty_arg tyvars       `thenM` \ ty_args ->
 557            let
 558                 dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 559                 (theta, _) = tcSplitPhiTy dfun_rho
 560                 ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 561            in
 562            if null theta then
 563                 returnM (SimpleInst ty_app)
 564            else
 565            newDictsAtLoc loc theta      `thenM` \ dicts ->
 566            let
 567                 rhs = mkHsDictApp ty_app (map instToId dicts)
 568            in
 569            returnM (GenInst dicts rhs)
 570
 571       other     -> returnM NoInstance
 572
 573 lookupInst (Dict _ _ _)         = returnM NoInstance
 574
 575 -- Methods
 576
 577 lookupInst inst@(Method _ id tys theta _ loc)
 578   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 579     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 580
 581 -- Literals
 582
 583 -- Look for short cuts first: if the literal is *definitely* a
 584 -- int, integer, float or a double, generate the real thing here.
 585 -- This is essential  (see nofib/spectral/nucleic).
 586 -- [Same shortcut as in newOverloadedLit, but we
 587 --  may have done some unification by now]
 588
 589
 590 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 591   | Just expr <- shortCutIntLit i ty
 592   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 593                                         -- expr may be a constructor application
 594   | otherwise
 595   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 596     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 597     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 598     returnM (GenInst [method_inst]
 599                      (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
 600
 601
 602 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 603   | Just expr <- shortCutFracLit f ty
 604   = returnM (GenInst [] expr)
 605
 606   | otherwise
 607   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 608     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 609     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 610     mkRatLit f                                  `thenM` \ rat_lit ->
 611     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
 612 \end{code}
 613
 614
 615
 616 %************************************************************************
 617 %*                                                                      *
 618                 Re-mappable syntax
 619 %*                                                                      *
 620 %************************************************************************
 621
 622
 623 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 624 a do-expression.  We have to find (>>) in the current environment, which is
 625 done by the rename. Then we have to check that it has the same type as
 626 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 627 this:
 628
 629   (>>) :: HB m n mn => m a -> n b -> mn b
 630
 631 So the idea is to generate a local binding for (>>), thus:
 632
 633         let then72 :: forall a b. m a -> m b -> m b
 634             then72 = ...something involving the user's (>>)...
 635         in
 636         ...the do-expression...
 637
 638 Now the do-expression can proceed using then72, which has exactly
 639 the expected type.
 640
 641 In fact tcSyntaxName just generates the RHS for then72, because we only
 642 want an actual binding in the do-expression case. For literals, we can
 643 just use the expression inline.
 644
 645 \begin{code}
 646 tcSyntaxName :: InstOrigin
 647              -> TcType                  -- Type to instantiate it at
 648              -> (Name, HsExpr Name)     -- (Standard name, user name)
 649              -> TcM (Name, TcExpr)      -- (Standard name, suitable expression)
 650
 651 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 652 -- So we do not call it from lookupInst, which is called from tcSimplify
 653
 654 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 655   | std_nm == user_nm
 656   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 657     returnM (std_nm, HsVar id)
 658
 659 tcSyntaxName orig ty (std_nm, user_nm_expr)
 660   = tcLookupId std_nm           `thenM` \ std_id ->
 661     let
 662         -- C.f. newMethodAtLoc
 663         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 664         tau1            = substTyWith [tv] [ty] tau
 665         -- Actually, the "tau-type" might be a sigma-type in the
 666         -- case of locally-polymorphic methods.
 667     in
 668     addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
 669     tcCheckSigma user_nm_expr tau1                      `thenM` \ expr ->
 670     returnM (std_nm, expr)
 671
 672 syntaxNameCtxt name orig ty tidy_env
 673   = getInstLoc orig             `thenM` \ inst_loc ->
 674     let
 675         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 676                                 ptext SLIT("(needed by a syntactic construct)"),
 677                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 678                     nest 2 (pprInstLoc inst_loc)]
 679     in
 680     returnM (tidy_env, msg)
 681 \end{code}