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