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