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, pprDFuns,
  14         tidyInsts, tidyMoreInsts,
  15
  16         newDictsFromOld, newDicts, cloneDict,
  17         newOverloadedLit, newIPDict,
  18         newMethod, newMethodFromName, newMethodWithGivenTy,
  19         tcInstClassOp, tcInstCall, tcInstDataCon,
  20         tcSyntaxName, tcStdSyntaxName,
  21
  22         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  23         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  24         instLoc, getDictClassTys, dictPred,
  25
  26         lookupInst, LookupInstResult(..),
  27         tcExtendLocalInstEnv, tcGetInstEnvs,
  28
  29         isDict, isClassDict, isMethod,
  30         isLinearInst, linearInstType, isIPDict, isInheritableInst,
  31         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  32         instBindingRequired,
  33
  34         zonkInst, zonkInsts,
  35         instToId, instName,
  36
  37         InstOrigin(..), InstLoc(..), pprInstLoc
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42 import {-# SOURCE #-}   TcExpr( tcCheckSigma )
  43
  44 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  45 import TcHsSyn  ( TcExpr, TcId, TcIdSet,
  46                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
  47                   mkCoercion, ExprCoFn
  48                 )
  49 import TcRnMonad
  50 import TcEnv    ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
  51 import InstEnv  ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
  52 import TcIface  ( loadImportedInsts )
  53 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType,
  54                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
  55                 )
  56 import TcType   ( Type, TcType, TcThetaType, TcTyVarSet,
  57                   PredType(..), TyVarDetails(VanillaTv),
  58                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
  59                   tcSplitPhiTy, isTyVarTy, tcSplitDFunTy,
  60                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  61                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  62                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  63                   isClassPred, isTyVarClassPred, isLinearPred,
  64                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  65                   isInheritablePred, isIPPred,
  66                   tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
  67                 )
  68 import HscTypes ( ExternalPackageState(..) )
  69 import CoreFVs  ( idFreeTyVars )
  70 import DataCon  ( DataCon,dataConSig )
  71 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
  72 import PrelInfo ( isStandardClass, isNoDictClass )
  73 import Name     ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
  74 import NameSet  ( addOneToNameSet )
  75 import PprType  ( pprPred, pprParendType, pprThetaArrow, pprClassPred )
  76 import Subst    ( substTy, substTyWith, substTheta, mkTyVarSubst )
  77 import Literal  ( inIntRange )
  78 import Var      ( TyVar )
  79 import VarEnv   ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
  80 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  81 import TysWiredIn ( floatDataCon, doubleDataCon )
  82 import PrelNames        ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
  83 import BasicTypes( IPName(..), mapIPName, ipNameName )
  84 import UniqSupply( uniqsFromSupply )
  85 import Outputable
  86 \end{code}
  87
  88
  89 Selection
  90 ~~~~~~~~~
  91 \begin{code}
  92 instName :: Inst -> Name
  93 instName inst = idName (instToId inst)
  94
  95 instToId :: Inst -> TcId
  96 instToId (Dict id _ _)         = id
  97 instToId (Method id _ _ _ _ _) = id
  98 instToId (LitInst id _ _ _)    = id
  99
 100 instLoc (Dict _ _         loc) = loc
 101 instLoc (Method _ _ _ _ _ loc) = loc
 102 instLoc (LitInst _ _ _    loc) = loc
 103
 104 dictPred (Dict _ pred _ ) = pred
 105 dictPred inst             = pprPanic "dictPred" (ppr inst)
 106
 107 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 108
 109 -- fdPredsOfInst is used to get predicates that contain functional
 110 -- dependencies *or* might do so.  The "might do" part is because
 111 -- a constraint (C a b) might have a superclass with FDs
 112 -- Leaving these in is really important for the call to fdPredsOfInsts
 113 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 114 -- which is supposed to be conservative
 115 fdPredsOfInst (Dict _ pred _)          = [pred]
 116 fdPredsOfInst (Method _ _ _ theta _ _) = theta
 117 fdPredsOfInst other                    = []     -- LitInsts etc
 118
 119 fdPredsOfInsts :: [Inst] -> [PredType]
 120 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 121
 122 isInheritableInst (Dict _ pred _)          = isInheritablePred pred
 123 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
 124 isInheritableInst other                    = True
 125
 126
 127 ipNamesOfInsts :: [Inst] -> [Name]
 128 ipNamesOfInst  :: Inst   -> [Name]
 129 -- Get the implicit parameters mentioned by these Insts
 130 -- NB: ?x and %x get different Names
 131 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 132
 133 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 134 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 135 ipNamesOfInst other                    = []
 136
 137 tyVarsOfInst :: Inst -> TcTyVarSet
 138 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 139 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 140 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 141                                          -- The id might have free type variables; in the case of
 142                                          -- locally-overloaded class methods, for example
 143
 144
 145 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 146 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 147 \end{code}
 148
 149 Predicates
 150 ~~~~~~~~~~
 151 \begin{code}
 152 isDict :: Inst -> Bool
 153 isDict (Dict _ _ _) = True
 154 isDict other        = False
 155
 156 isClassDict :: Inst -> Bool
 157 isClassDict (Dict _ pred _) = isClassPred pred
 158 isClassDict other           = False
 159
 160 isTyVarDict :: Inst -> Bool
 161 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 162 isTyVarDict other           = False
 163
 164 isIPDict :: Inst -> Bool
 165 isIPDict (Dict _ pred _) = isIPPred pred
 166 isIPDict other           = False
 167
 168 isMethod :: Inst -> Bool
 169 isMethod (Method _ _ _ _ _ _) = True
 170 isMethod other                = False
 171
 172 isMethodFor :: TcIdSet -> Inst -> Bool
 173 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 174 isMethodFor ids inst                         = False
 175
 176 isLinearInst :: Inst -> Bool
 177 isLinearInst (Dict _ pred _) = isLinearPred pred
 178 isLinearInst other           = False
 179         -- We never build Method Insts that have
 180         -- linear implicit paramters in them.
 181         -- Hence no need to look for Methods
 182         -- See TcExpr.tcId
 183
 184 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 185 linearInstType (Dict _ (IParam _ ty) _) = ty
 186
 187
 188 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 189                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 190                                         other             -> False
 191 \end{code}
 192
 193 Two predicates which deal with the case where class constraints don't
 194 necessarily result in bindings.  The first tells whether an @Inst@
 195 must be witnessed by an actual binding; the second tells whether an
 196 @Inst@ can be generalised over.
 197
 198 \begin{code}
 199 instBindingRequired :: Inst -> Bool
 200 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 201 instBindingRequired 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 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))
 236                              pred inst_loc
 237     loc = instLocSrcLoc inst_loc
 238
 239 -- For vanilla implicit parameters, there is only one in scope
 240 -- at any time, so we used to use the name of the implicit parameter itself
 241 -- But with splittable implicit parameters there may be many in
 242 -- scope, so we make up a new name.
 243 newIPDict :: InstOrigin -> IPName Name -> Type
 244           -> TcM (IPName Id, Inst)
 245 newIPDict orig ip_name ty
 246   = getInstLoc orig                     `thenM` \ inst_loc@(InstLoc _ loc _) ->
 247     newUnique                           `thenM` \ uniq ->
 248     let
 249         pred = IParam ip_name ty
 250         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
 251     in
 252     returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 253 \end{code}
 254
 255
 256
 257 %************************************************************************
 258 %*                                                                      *
 259 \subsection{Building methods (calls of overloaded functions)}
 260 %*                                                                      *
 261 %************************************************************************
 262
 263
 264 \begin{code}
 265 tcInstCall :: InstOrigin  -> TcType -> TcM (ExprCoFn, TcType)
 266 tcInstCall orig fun_ty  -- fun_ty is usually a sigma-type
 267   = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
 268     newDicts orig theta         `thenM` \ dicts ->
 269     extendLIEs dicts            `thenM_`
 270     let
 271         inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
 272     in
 273     returnM (mkCoercion inst_fn, tau)
 274
 275 tcInstDataCon :: InstOrigin -> DataCon
 276               -> TcM ([TcType], -- Types to instantiate at
 277                       [Inst],   -- Existential dictionaries to apply to
 278                       [TcType], -- Argument types of constructor
 279                       TcType,   -- Result type
 280                       [TyVar])  -- Existential tyvars
 281 tcInstDataCon orig data_con
 282   = let
 283         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 284              -- We generate constraints for the stupid theta even when
 285              -- pattern matching (as the Report requires)
 286     in
 287     tcInstTyVars VanillaTv (tvs ++ ex_tvs)      `thenM` \ (all_tvs', ty_args', tenv) ->
 288     let
 289         stupid_theta' = substTheta tenv stupid_theta
 290         ex_theta'     = substTheta tenv ex_theta
 291         arg_tys'      = map (substTy tenv) arg_tys
 292
 293         n_normal_tvs  = length tvs
 294         ex_tvs'       = drop n_normal_tvs all_tvs'
 295         result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
 296     in
 297     newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
 298     newDicts orig ex_theta'     `thenM` \ ex_dicts ->
 299
 300         -- Note that we return the stupid theta *only* in the LIE;
 301         -- we don't otherwise use it at all
 302     extendLIEs stupid_dicts     `thenM_`
 303
 304     returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
 305
 306 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
 307 newMethodFromName origin ty name
 308   = tcLookupId name             `thenM` \ id ->
 309         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 310         -- always a class op, but with -fno-implicit-prelude GHC is
 311         -- meant to find whatever thing is in scope, and that may
 312         -- be an ordinary function.
 313     getInstLoc origin           `thenM` \ loc ->
 314     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 315     extendLIE inst              `thenM_`
 316     returnM (instToId inst)
 317
 318 newMethodWithGivenTy orig id tys theta tau
 319   = getInstLoc orig                     `thenM` \ loc ->
 320     newMethod loc id tys theta tau      `thenM` \ inst ->
 321     extendLIE inst                      `thenM_`
 322     returnM (instToId inst)
 323
 324 --------------------------------------------
 325 -- tcInstClassOp, and newMethod do *not* drop the
 326 -- Inst into the LIE; they just returns the Inst
 327 -- This is important because they are used by TcSimplify
 328 -- to simplify Insts
 329
 330 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 331 tcInstClassOp inst_loc sel_id tys
 332   = let
 333         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 334         rho_ty       = ASSERT( length tyvars == length tys )
 335                        substTyWith tyvars tys rho
 336         (preds,tau)  = tcSplitPhiTy rho_ty
 337     in
 338     newMethod inst_loc sel_id tys preds tau
 339
 340 ---------------------------
 341 newMethod inst_loc id tys theta tau
 342   = newUnique           `thenM` \ new_uniq ->
 343     let
 344         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 345         inst    = Method meth_id id tys theta tau inst_loc
 346         loc     = instLocSrcLoc inst_loc
 347     in
 348     returnM inst
 349 \end{code}
 350
 351 In newOverloadedLit we convert directly to an Int or Integer if we
 352 know that's what we want.  This may save some time, by not
 353 temporarily generating overloaded literals, but it won't catch all
 354 cases (the rest are caught in lookupInst).
 355
 356 \begin{code}
 357 newOverloadedLit :: InstOrigin
 358                  -> HsOverLit
 359                  -> TcType
 360                  -> TcM TcExpr
 361 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 362   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable
 363                                 -- syntax.  Reason: tcSyntaxName does unification
 364                                 -- which is very inconvenient in tcSimplify
 365   = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi)   `thenM` \ (_,expr) ->
 366     mkIntegerLit i                                              `thenM` \ integer_lit ->
 367     returnM (HsApp expr integer_lit)
 368
 369   | Just expr <- shortCutIntLit i expected_ty
 370   = returnM expr
 371
 372   | otherwise
 373   = newLitInst orig lit expected_ty
 374
 375 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
 376   | fr /= fromRationalName      -- c.f. HsIntegral case
 377   = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr)  `thenM` \ (_,expr) ->
 378     mkRatLit r                                                  `thenM` \ rat_lit ->
 379     returnM (HsApp expr rat_lit)
 380
 381   | Just expr <- shortCutFracLit r expected_ty
 382   = returnM expr
 383
 384   | otherwise
 385   = newLitInst orig lit expected_ty
 386
 387 newLitInst orig lit expected_ty
 388   = getInstLoc orig             `thenM` \ loc ->
 389     newUnique                   `thenM` \ new_uniq ->
 390     let
 391         lit_inst = LitInst lit_id lit expected_ty loc
 392         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 393     in
 394     extendLIE lit_inst          `thenM_`
 395     returnM (HsVar (instToId lit_inst))
 396
 397 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
 398 shortCutIntLit i ty
 399   | isIntTy ty && inIntRange i          -- Short cut for Int
 400   = Just (HsLit (HsInt i))
 401   | isIntegerTy ty                      -- Short cut for Integer
 402   = Just (HsLit (HsInteger i ty))
 403   | otherwise = Nothing
 404
 405 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
 406 shortCutFracLit f ty
 407   | isFloatTy ty
 408   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 409   | isDoubleTy ty
 410   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 411   | otherwise = Nothing
 412
 413 mkIntegerLit :: Integer -> TcM TcExpr
 414 mkIntegerLit i
 415   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 416     returnM (HsLit (HsInteger i integer_ty))
 417
 418 mkRatLit :: Rational -> TcM TcExpr
 419 mkRatLit r
 420   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 421     returnM (HsLit (HsRat r rat_ty))
 422 \end{code}
 423
 424
 425 %************************************************************************
 426 %*                                                                      *
 427 \subsection{Zonking}
 428 %*                                                                      *
 429 %************************************************************************
 430
 431 Zonking makes sure that the instance types are fully zonked,
 432 but doesn't do the same for any of the Ids in an Inst.  There's no
 433 need, and it's a lot of extra work.
 434
 435 \begin{code}
 436 zonkInst :: Inst -> TcM Inst
 437 zonkInst (Dict id pred loc)
 438   = zonkTcPredType pred                 `thenM` \ new_pred ->
 439     returnM (Dict id new_pred loc)
 440
 441 zonkInst (Method m id tys theta tau loc)
 442   = zonkId id                   `thenM` \ new_id ->
 443         -- Essential to zonk the id in case it's a local variable
 444         -- Can't use zonkIdOcc because the id might itself be
 445         -- an InstId, in which case it won't be in scope
 446
 447     zonkTcTypes tys             `thenM` \ new_tys ->
 448     zonkTcThetaType theta       `thenM` \ new_theta ->
 449     zonkTcType tau              `thenM` \ new_tau ->
 450     returnM (Method m new_id new_tys new_theta new_tau loc)
 451
 452 zonkInst (LitInst id lit ty loc)
 453   = zonkTcType ty                       `thenM` \ new_ty ->
 454     returnM (LitInst id lit new_ty loc)
 455
 456 zonkInsts insts = mappM zonkInst insts
 457 \end{code}
 458
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsection{Printing}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 467 relevant in error messages.
 468
 469 \begin{code}
 470 instance Outputable Inst where
 471     ppr inst = pprInst inst
 472
 473 pprInsts :: [Inst] -> SDoc
 474 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 475
 476 pprInstsInFull insts
 477   = vcat (map go insts)
 478   where
 479     go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
 480
 481 pprInst (LitInst u lit ty loc)
 482   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 483
 484 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 485
 486 pprInst m@(Method u id tys theta tau loc)
 487   = hsep [ppr id, ptext SLIT("at"),
 488           brackets (sep (map pprParendType tys)) {- ,
 489           ptext SLIT("theta"), ppr theta,
 490           ptext SLIT("tau"), ppr tau
 491           show_uniq u,
 492           ppr (instToId m) -}]
 493
 494
 495 pprDFuns :: [DFunId] -> SDoc
 496 -- Prints the dfun as an instance declaration
 497 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
 498                         2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
 499                                                            pprClassPred clas tys])
 500                       | dfun <- dfuns
 501                       , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
 502         -- Print without the for-all, which the programmer doesn't write
 503
 504 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 505
 506 tidyInst :: TidyEnv -> Inst -> Inst
 507 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 508 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 509 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 510
 511 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 512 -- This function doesn't assume that the tyvars are in scope
 513 -- so it works like tidyOpenType, returning a TidyEnv
 514 tidyMoreInsts env insts
 515   = (env', map (tidyInst env') insts)
 516   where
 517     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 518
 519 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 520 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 521
 522 showLIE :: SDoc -> TcM ()       -- Debugging
 523 showLIE str
 524   = do { lie_var <- getLIEVar ;
 525          lie <- readMutVar lie_var ;
 526          traceTc (str <+> pprInstsInFull (lieToList lie)) }
 527 \end{code}
 528
 529
 530 %************************************************************************
 531 %*                                                                      *
 532         Extending the instance environment
 533 %*                                                                      *
 534 %************************************************************************
 535
 536 \begin{code}
 537 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
 538   -- Add new locally-defined instances
 539 tcExtendLocalInstEnv dfuns thing_inside
 540  = do { traceDFuns dfuns
 541       ; eps <- getEps
 542       ; env <- getGblEnv
 543       ; inst_env' <- foldlM (extend (eps_inst_env eps))
 544                             (tcg_inst_env env)
 545                             dfuns
 546       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 547                          tcg_inst_env = inst_env' }
 548       ; setGblEnv env' thing_inside }
 549  where
 550   extend pkg_ie home_ie dfun
 551    = do { case checkFunDeps (home_ie, pkg_ie) dfun of
 552                 Just dfuns -> funDepErr dfun dfuns
 553                 Nothing    -> return ()
 554         ; return (extendInstEnv home_ie dfun) }
 555
 556 traceDFuns dfuns
 557   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 558   where
 559     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 560
 561 funDepErr dfun dfuns
 562   = addSrcLoc (getSrcLoc dfun) $
 563     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 564                2 (pprDFuns (dfun:dfuns)))
 565 \end{code}
 566
 567 %************************************************************************
 568 %*                                                                      *
 569 \subsection{Looking up Insts}
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 \begin{code}
 574 data LookupInstResult s
 575   = NoInstance
 576   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 577   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 578
 579 lookupInst :: Inst -> TcM (LookupInstResult s)
 580 -- It's important that lookupInst does not put any new stuff into
 581 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 582 -- the LookupInstResult, where they can be further processed by tcSimplify
 583
 584
 585 -- Methods
 586
 587 lookupInst inst@(Method _ id tys theta _ loc)
 588   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 589     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 590
 591 -- Literals
 592
 593 -- Look for short cuts first: if the literal is *definitely* a
 594 -- int, integer, float or a double, generate the real thing here.
 595 -- This is essential  (see nofib/spectral/nucleic).
 596 -- [Same shortcut as in newOverloadedLit, but we
 597 --  may have done some unification by now]
 598
 599
 600 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 601   | Just expr <- shortCutIntLit i ty
 602   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 603                                         -- expr may be a constructor application
 604   | otherwise
 605   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 606     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 607     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 608     mkIntegerLit i                              `thenM` \ integer_lit ->
 609     returnM (GenInst [method_inst]
 610                      (HsApp (HsVar (instToId method_inst)) integer_lit))
 611
 612 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 613   | Just expr <- shortCutFracLit f ty
 614   = returnM (GenInst [] expr)
 615
 616   | otherwise
 617   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 618     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 619     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 620     mkRatLit f                                  `thenM` \ rat_lit ->
 621     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
 622
 623 -- Dictionaries
 624 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 625   | all isTyVarTy tys    -- Common special case; no lookup
 626   = returnM NoInstance
 627
 628   | otherwise
 629   = do  { pkg_ie  <- loadImportedInsts clas tys
 630                 -- Suck in any instance decls that may be relevant
 631         ; tcg_env <- getGblEnv
 632         ; dflags  <- getDOpts
 633         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 634             ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
 635             other                         -> return NoInstance } }
 636                 -- In the case of overlap (multiple matches) we report
 637                 -- NoInstance here.  That has the effect of making the
 638                 -- context-simplifier return the dict as an irreducible one.
 639                 -- Then it'll be given to addNoInstanceErrs, which will do another
 640                 -- lookupInstEnv to get the detailed info about what went wrong.
 641
 642 lookupInst (Dict _ _ _) = returnM NoInstance
 643
 644 -----------------
 645 instantiate_dfun tenv dfun_id pred loc
 646   =     -- Record that this dfun is needed
 647     record_dfun_usage dfun_id           `thenM_`
 648
 649         -- It's possible that not all the tyvars are in
 650         -- the substitution, tenv. For example:
 651         --      instance C X a => D X where ...
 652         -- (presumably there's a functional dependency in class C)
 653         -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 654     getStage                                            `thenM` \ use_stage ->
 655     checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 656                     (topIdLvl dfun_id) use_stage                `thenM_`
 657     traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
 658     let
 659         (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 660         mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 661                            Just (DoneTy ty) -> returnM ty
 662                            Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 663                                                returnM (mkTyVarTy tc_tv)
 664     in
 665     mappM mk_ty_arg tyvars      `thenM` \ ty_args ->
 666     let
 667         dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 668         (theta, _) = tcSplitPhiTy dfun_rho
 669         ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 670     in
 671     if null theta then
 672         returnM (SimpleInst ty_app)
 673     else
 674     newDictsAtLoc loc theta     `thenM` \ dicts ->
 675     let
 676         rhs = mkHsDictApp ty_app (map instToId dicts)
 677     in
 678     returnM (GenInst dicts rhs)
 679
 680 record_dfun_usage dfun_id
 681   | isInternalName dfun_name = return ()                -- From this module
 682   | not (isHomePackageName dfun_name) = return ()       -- From another package package
 683   | otherwise = getGblEnv       `thenM` \ tcg_env ->
 684                 updMutVar (tcg_inst_uses tcg_env)
 685                           (`addOneToNameSet` idName dfun_id)
 686   where
 687     dfun_name = idName dfun_id
 688
 689 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 690 -- Gets both the home-pkg inst env (includes module being compiled)
 691 -- and the external-package inst-env
 692 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 693                      return (tcg_inst_env env, eps_inst_env eps) }
 694 \end{code}
 695
 696
 697
 698 %************************************************************************
 699 %*                                                                      *
 700                 Re-mappable syntax
 701 %*                                                                      *
 702 %************************************************************************
 703
 704
 705 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 706 a do-expression.  We have to find (>>) in the current environment, which is
 707 done by the rename. Then we have to check that it has the same type as
 708 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 709 this:
 710
 711   (>>) :: HB m n mn => m a -> n b -> mn b
 712
 713 So the idea is to generate a local binding for (>>), thus:
 714
 715         let then72 :: forall a b. m a -> m b -> m b
 716             then72 = ...something involving the user's (>>)...
 717         in
 718         ...the do-expression...
 719
 720 Now the do-expression can proceed using then72, which has exactly
 721 the expected type.
 722
 723 In fact tcSyntaxName just generates the RHS for then72, because we only
 724 want an actual binding in the do-expression case. For literals, we can
 725 just use the expression inline.
 726
 727 \begin{code}
 728 tcSyntaxName :: InstOrigin
 729              -> TcType                  -- Type to instantiate it at
 730              -> (Name, HsExpr Name)     -- (Standard name, user name)
 731              -> TcM (Name, TcExpr)      -- (Standard name, suitable expression)
 732
 733 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 734 -- So we do not call it from lookupInst, which is called from tcSimplify
 735
 736 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 737   | std_nm == user_nm
 738   = tcStdSyntaxName orig ty std_nm
 739
 740 tcSyntaxName orig ty (std_nm, user_nm_expr)
 741   = tcLookupId std_nm           `thenM` \ std_id ->
 742     let
 743         -- C.f. newMethodAtLoc
 744         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 745         tau1            = substTyWith [tv] [ty] tau
 746         -- Actually, the "tau-type" might be a sigma-type in the
 747         -- case of locally-polymorphic methods.
 748     in
 749     addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
 750
 751         -- Check that the user-supplied thing has the
 752         -- same type as the standard one
 753     tcCheckSigma user_nm_expr tau1                      `thenM` \ expr ->
 754     returnM (std_nm, expr)
 755
 756 tcStdSyntaxName :: InstOrigin
 757                 -> TcType               -- Type to instantiate it at
 758                 -> Name                 -- Standard name
 759                 -> TcM (Name, TcExpr)   -- (Standard name, suitable expression)
 760
 761 tcStdSyntaxName orig ty std_nm
 762   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 763     returnM (std_nm, HsVar id)
 764
 765 syntaxNameCtxt name orig ty tidy_env
 766   = getInstLoc orig             `thenM` \ inst_loc ->
 767     let
 768         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 769                                 ptext SLIT("(needed by a syntactic construct)"),
 770                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 771                     nest 2 (pprInstLoc inst_loc)]
 772     in
 773     returnM (tidy_env, msg)
 774 \end{code}