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