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, lookupSimpleInst, 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 )
  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, ThetaType, 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 Class    ( Class )
  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    ( emptyInScopeSet, mkSubst, 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 Util     ( equalLength )
  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; i.e. should participate in improvement
 106 fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
 107                               | otherwise       = []
 108 fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
 109 fdPredsOfInst other                    = []
 110
 111 fdPredsOfInsts :: [Inst] -> [PredType]
 112 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 113
 114 isInheritableInst (Dict _ pred _)          = isInheritablePred pred
 115 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
 116 isInheritableInst other                    = True
 117
 118
 119 ipNamesOfInsts :: [Inst] -> [Name]
 120 ipNamesOfInst  :: Inst   -> [Name]
 121 -- Get the implicit parameters mentioned by these Insts
 122 -- NB: ?x and %x get different Names
 123 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 124
 125 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 126 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 127 ipNamesOfInst other                    = []
 128
 129 tyVarsOfInst :: Inst -> TcTyVarSet
 130 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 131 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 132 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 133                                          -- The id might have free type variables; in the case of
 134                                          -- locally-overloaded class methods, for example
 135
 136
 137 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 138 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 139 \end{code}
 140
 141 Predicates
 142 ~~~~~~~~~~
 143 \begin{code}
 144 isDict :: Inst -> Bool
 145 isDict (Dict _ _ _) = True
 146 isDict other        = False
 147
 148 isClassDict :: Inst -> Bool
 149 isClassDict (Dict _ pred _) = isClassPred pred
 150 isClassDict other           = False
 151
 152 isTyVarDict :: Inst -> Bool
 153 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 154 isTyVarDict other           = False
 155
 156 isIPDict :: Inst -> Bool
 157 isIPDict (Dict _ pred _) = isIPPred pred
 158 isIPDict other           = False
 159
 160 isMethod :: Inst -> Bool
 161 isMethod (Method _ _ _ _ _ _) = True
 162 isMethod other                = False
 163
 164 isMethodFor :: TcIdSet -> Inst -> Bool
 165 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 166 isMethodFor ids inst                         = False
 167
 168 isLinearInst :: Inst -> Bool
 169 isLinearInst (Dict _ pred _) = isLinearPred pred
 170 isLinearInst other           = False
 171         -- We never build Method Insts that have
 172         -- linear implicit paramters in them.
 173         -- Hence no need to look for Methods
 174         -- See TcExpr.tcId
 175
 176 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 177 linearInstType (Dict _ (IParam _ ty) _) = ty
 178
 179
 180 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 181                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 182                                         other             -> False
 183 \end{code}
 184
 185 Two predicates which deal with the case where class constraints don't
 186 necessarily result in bindings.  The first tells whether an @Inst@
 187 must be witnessed by an actual binding; the second tells whether an
 188 @Inst@ can be generalised over.
 189
 190 \begin{code}
 191 instBindingRequired :: Inst -> Bool
 192 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 193 instBindingRequired other                      = True
 194
 195 instCanBeGeneralised :: Inst -> Bool
 196 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 197 instCanBeGeneralised other                      = True
 198 \end{code}
 199
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection{Building dictionaries}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 \begin{code}
 208 newDicts :: InstOrigin
 209          -> TcThetaType
 210          -> TcM [Inst]
 211 newDicts orig theta
 212   = getInstLoc orig             `thenM` \ loc ->
 213     newDictsAtLoc loc theta
 214
 215 cloneDict :: Inst -> TcM Inst
 216 cloneDict (Dict id ty loc) = newUnique  `thenM` \ uniq ->
 217                              returnM (Dict (setIdUnique id uniq) ty loc)
 218
 219 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
 220 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 221
 222 -- Local function, similar to newDicts,
 223 -- but with slightly different interface
 224 newDictsAtLoc :: InstLoc
 225               -> TcThetaType
 226               -> TcM [Inst]
 227 newDictsAtLoc inst_loc@(_,loc,_) theta
 228   = newUniqueSupply             `thenM` \ us ->
 229     returnM (zipWith mk_dict (uniqsFromSupply us) theta)
 230   where
 231     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred 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@(_,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   -- Instantiate the specified class op, but *only* with the main
 326   -- class dictionary. For example, given 'op' defined thus:
 327   --    class Foo a where
 328   --      op :: (?x :: String) => a -> a
 329   -- (tcInstClassOp op T) should return an Inst with type
 330   --    (?x :: String) => T -> T
 331   -- That is, the class-op's context is still there.
 332   -- This is really important in the use of tcInstClassOp in TcClassDcls.mkMethodBind
 333 tcInstClassOp inst_loc sel_id tys
 334   = let
 335         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 336         rho_ty       = substTyWith tyvars tys rho
 337         (pred,tau)   = tcSplitMethodTy rho_ty
 338                 -- Split off exactly one predicate (see the example above)
 339     in
 340     ASSERT( isClassPred pred )
 341     newMethod inst_loc sel_id tys [pred] tau
 342
 343 ---------------------------
 344 newMethod inst_loc@(_,loc,_) id tys theta tau
 345   = newUnique           `thenM` \ new_uniq ->
 346     let
 347         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 348         inst    = Method meth_id id tys theta tau inst_loc
 349     in
 350     returnM inst
 351 \end{code}
 352
 353 In newOverloadedLit we convert directly to an Int or Integer if we
 354 know that's what we want.  This may save some time, by not
 355 temporarily generating overloaded literals, but it won't catch all
 356 cases (the rest are caught in lookupInst).
 357
 358 \begin{code}
 359 newOverloadedLit :: InstOrigin
 360                  -> HsOverLit
 361                  -> TcType
 362                  -> TcM TcExpr
 363 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 364   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable
 365                                 -- syntax.  Reason: tcSyntaxName does unification
 366                                 -- which is very inconvenient in tcSimplify
 367   = tcSyntaxName orig expected_ty fromIntegerName fi    `thenM` \ (expr, _) ->
 368     returnM (HsApp expr (HsLit (HsInteger i)))
 369
 370   | Just expr <- shortCutIntLit i expected_ty
 371   = returnM expr
 372
 373   | otherwise
 374   = newLitInst orig lit expected_ty
 375
 376 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 377   | fr /= fromRationalName      -- c.f. HsIntegral case
 378   = tcSyntaxName orig expected_ty fromRationalName fr   `thenM` \ (expr, _) ->
 379     mkRatLit r                                          `thenM` \ rat_lit ->
 380     returnM (HsApp expr rat_lit)
 381
 382   | Just expr <- shortCutFracLit r expected_ty
 383   = returnM expr
 384
 385   | otherwise
 386   = newLitInst orig lit expected_ty
 387
 388 newLitInst orig lit expected_ty
 389   = getInstLoc orig             `thenM` \ loc ->
 390     newUnique                   `thenM` \ new_uniq ->
 391     zapToType expected_ty       `thenM_`
 392         -- The expected type might be a 'hole' type variable,
 393         -- in which case we must zap it to an ordinary type variable
 394     let
 395         lit_inst = LitInst lit_id lit expected_ty loc
 396         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 397     in
 398     extendLIE lit_inst          `thenM_`
 399     returnM (HsVar (instToId lit_inst))
 400
 401 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
 402 shortCutIntLit i ty
 403   | isIntTy ty && inIntRange i                  -- Short cut for Int
 404   = Just (HsLit (HsInt i))
 405   | isIntegerTy ty                              -- Short cut for Integer
 406   = Just (HsLit (HsInteger i))
 407   | otherwise = Nothing
 408
 409 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
 410 shortCutFracLit f ty
 411   | isFloatTy ty
 412   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 413   | isDoubleTy ty
 414   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 415   | otherwise = Nothing
 416
 417 mkRatLit :: Rational -> TcM TcExpr
 418 mkRatLit r
 419   = tcLookupTyCon rationalTyConName                     `thenM` \ rat_tc ->
 420     let
 421         rational_ty  = mkGenTyConApp rat_tc []
 422     in
 423     returnM (HsLit (HsRat r rational_ty))
 424 \end{code}
 425
 426
 427 %************************************************************************
 428 %*                                                                      *
 429 \subsection{Zonking}
 430 %*                                                                      *
 431 %************************************************************************
 432
 433 Zonking makes sure that the instance types are fully zonked,
 434 but doesn't do the same for any of the Ids in an Inst.  There's no
 435 need, and it's a lot of extra work.
 436
 437 \begin{code}
 438 zonkInst :: Inst -> TcM Inst
 439 zonkInst (Dict id pred loc)
 440   = zonkTcPredType pred                 `thenM` \ new_pred ->
 441     returnM (Dict id new_pred loc)
 442
 443 zonkInst (Method m id tys theta tau loc)
 444   = zonkId id                   `thenM` \ new_id ->
 445         -- Essential to zonk the id in case it's a local variable
 446         -- Can't use zonkIdOcc because the id might itself be
 447         -- an InstId, in which case it won't be in scope
 448
 449     zonkTcTypes tys             `thenM` \ new_tys ->
 450     zonkTcThetaType theta       `thenM` \ new_theta ->
 451     zonkTcType tau              `thenM` \ new_tau ->
 452     returnM (Method m new_id new_tys new_theta new_tau loc)
 453
 454 zonkInst (LitInst id lit ty loc)
 455   = zonkTcType ty                       `thenM` \ new_ty ->
 456     returnM (LitInst id lit new_ty loc)
 457
 458 zonkInsts insts = mappM zonkInst insts
 459 \end{code}
 460
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection{Printing}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 469 relevant in error messages.
 470
 471 \begin{code}
 472 instance Outputable Inst where
 473     ppr inst = pprInst inst
 474
 475 pprInsts :: [Inst] -> SDoc
 476 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 477
 478 pprInstsInFull insts
 479   = vcat (map go insts)
 480   where
 481     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 482
 483 pprInst (LitInst u lit ty loc)
 484   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 485
 486 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 487
 488 pprInst m@(Method u id tys theta tau loc)
 489   = hsep [ppr id, ptext SLIT("at"),
 490           brackets (sep (map pprParendType tys)) {- ,
 491           ptext SLIT("theta"), ppr theta,
 492           ptext SLIT("tau"), ppr tau
 493           show_uniq u,
 494           ppr (instToId m) -}]
 495
 496 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 497
 498 tidyInst :: TidyEnv -> Inst -> Inst
 499 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 500 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 501 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 502
 503 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 504 -- This function doesn't assume that the tyvars are in scope
 505 -- so it works like tidyOpenType, returning a TidyEnv
 506 tidyMoreInsts env insts
 507   = (env', map (tidyInst env') insts)
 508   where
 509     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 510
 511 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 512 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 513
 514 showLIE :: String -> TcM ()     -- Debugging
 515 showLIE str
 516   = do { lie_var <- getLIEVar ;
 517          lie <- readMutVar lie_var ;
 518          traceTc (text str <+> pprInstsInFull (lieToList lie)) }
 519 \end{code}
 520
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsection{Looking up Insts}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 \begin{code}
 529 data LookupInstResult s
 530   = NoInstance
 531   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 532   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 533
 534 lookupInst :: Inst -> TcM (LookupInstResult s)
 535 -- It's important that lookupInst does not put any new stuff into
 536 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 537 -- the LookupInstResult, where they can be further processed by tcSimplify
 538
 539
 540 -- Dictionaries
 541 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 542   = getDOpts                    `thenM` \ dflags ->
 543     tcGetInstEnv                `thenM` \ inst_env ->
 544     case lookupInstEnv dflags inst_env clas tys of
 545
 546       FoundInst tenv dfun_id
 547         ->      -- It's possible that not all the tyvars are in
 548                 -- the substitution, tenv. For example:
 549                 --      instance C X a => D X where ...
 550                 -- (presumably there's a functional dependency in class C)
 551                 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 552            let
 553                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 554                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 555                                    Just (DoneTy ty) -> returnM ty
 556                                    Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 557                                                        returnM (mkTyVarTy tc_tv)
 558            in
 559            mappM mk_ty_arg tyvars       `thenM` \ ty_args ->
 560            let
 561                 dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 562                 (theta, _) = tcSplitPhiTy dfun_rho
 563                 ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 564            in
 565            if null theta then
 566                 returnM (SimpleInst ty_app)
 567            else
 568            newDictsAtLoc loc theta      `thenM` \ dicts ->
 569            let
 570                 rhs = mkHsDictApp ty_app (map instToId dicts)
 571            in
 572            returnM (GenInst dicts rhs)
 573
 574       other     -> returnM NoInstance
 575
 576 lookupInst (Dict _ _ _)         = returnM NoInstance
 577
 578 -- Methods
 579
 580 lookupInst inst@(Method _ id tys theta _ loc)
 581   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 582     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 583
 584 -- Literals
 585
 586 -- Look for short cuts first: if the literal is *definitely* a
 587 -- int, integer, float or a double, generate the real thing here.
 588 -- This is essential  (see nofib/spectral/nucleic).
 589 -- [Same shortcut as in newOverloadedLit, but we
 590 --  may have done some unification by now]
 591
 592
 593 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 594   | Just expr <- shortCutIntLit i ty
 595   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 596                                         -- expr may be a constructor application
 597   | otherwise
 598   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 599     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 600     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 601     returnM (GenInst [method_inst]
 602                      (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
 603
 604
 605 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 606   | Just expr <- shortCutFracLit f ty
 607   = returnM (GenInst [] expr)
 608
 609   | otherwise
 610   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 611     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 612     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 613     mkRatLit f                                  `thenM` \ rat_lit ->
 614     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
 615 \end{code}
 616
 617 There is a second, simpler interface, when you want an instance of a
 618 class at a given nullary type constructor.  It just returns the
 619 appropriate dictionary if it exists.  It is used only when resolving
 620 ambiguous dictionaries.
 621
 622 \begin{code}
 623 lookupSimpleInst :: Class
 624                  -> [Type]                      -- Look up (c,t)
 625                  -> TcM (Maybe ThetaType)       -- Here are the needed (c,t)s
 626
 627 lookupSimpleInst clas tys
 628   = getDOpts                    `thenM` \ dflags ->
 629     tcGetInstEnv                `thenM` \ inst_env ->
 630     case lookupInstEnv dflags inst_env clas tys of
 631       FoundInst tenv dfun
 632         -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 633         where
 634            (_, rho)  = tcSplitForAllTys (idType dfun)
 635            (theta,_) = tcSplitPhiTy rho
 636
 637       other  -> returnM Nothing
 638 \end{code}
 639
 640
 641 %************************************************************************
 642 %*                                                                      *
 643                 Re-mappable syntax
 644 %*                                                                      *
 645 %************************************************************************
 646
 647
 648 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 649 a do-expression.  We have to find (>>) in the current environment, which is
 650 done by the rename. Then we have to check that it has the same type as
 651 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 652 this:
 653
 654   (>>) :: HB m n mn => m a -> n b -> mn b
 655
 656 So the idea is to generate a local binding for (>>), thus:
 657
 658         let then72 :: forall a b. m a -> m b -> m b
 659             then72 = ...something involving the user's (>>)...
 660         in
 661         ...the do-expression...
 662
 663 Now the do-expression can proceed using then72, which has exactly
 664 the expected type.
 665
 666 In fact tcSyntaxName just generates the RHS for then72, because we only
 667 want an actual binding in the do-expression case. For literals, we can
 668 just use the expression inline.
 669
 670 \begin{code}
 671 tcSyntaxName :: InstOrigin
 672              -> TcType                  -- Type to instantiate it at
 673              -> Name -> Name            -- (Standard name, user name)
 674              -> TcM (TcExpr, TcType)    -- Suitable expression with its type
 675
 676 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 677 -- So we do not call it from lookupInst, which is called from tcSimplify
 678
 679 tcSyntaxName orig ty std_nm user_nm
 680   | std_nm == user_nm
 681   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 682     returnM (HsVar id, idType id)
 683
 684   | otherwise
 685   = tcLookupId std_nm           `thenM` \ std_id ->
 686     let
 687         -- C.f. newMethodAtLoc
 688         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 689         tau1            = substTyWith [tv] [ty] tau
 690     in
 691     addErrCtxtM (syntaxNameCtxt user_nm orig tau1)      $
 692     tcExpr (HsVar user_nm) tau1                         `thenM` \ user_fn ->
 693     returnM (user_fn, tau1)
 694
 695 syntaxNameCtxt name orig ty tidy_env
 696   = getInstLoc orig             `thenM` \ inst_loc ->
 697     let
 698         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 699                                 ptext SLIT("(needed by a syntactic construct)"),
 700                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 701                     nest 2 (pprInstLoc inst_loc)]
 702     in
 703     returnM (tidy_env, msg)
 704 \end{code}