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