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