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