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         showLIE,
   9
  10         Inst,
  11         pprInst, pprInsts, pprInstsInFull, pprDFuns,
  12         tidyInsts, tidyMoreInsts,
  13
  14         newDictsFromOld, newDicts, cloneDict,
  15         newOverloadedLit, newIPDict,
  16         newMethod, newMethodFromName, newMethodWithGivenTy,
  17         tcInstClassOp, tcInstCall, tcInstDataCon,
  18         tcSyntaxName, tcStdSyntaxName,
  19
  20         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  21         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  22         instLoc, getDictClassTys, dictPred,
  23
  24         lookupInst, LookupInstResult(..),
  25         tcExtendLocalInstEnv, tcGetInstEnvs,
  26
  27         isDict, isClassDict, isMethod,
  28         isLinearInst, linearInstType, isIPDict, isInheritableInst,
  29         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  30         instBindingRequired,
  31
  32         zonkInst, zonkInsts,
  33         instToId, instName,
  34
  35         InstOrigin(..), InstLoc(..), pprInstLoc
  36     ) where
  37
  38 #include "HsVersions.h"
  39
  40 import {-# SOURCE #-}   TcExpr( tcCheckSigma )
  41
  42 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  43 import TcHsSyn  ( TcExpr, TcId, TcIdSet,
  44                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
  45                   mkCoercion, ExprCoFn
  46                 )
  47 import TcRnMonad
  48 import TcEnv    ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
  49 import InstEnv  ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
  50 import TcIface  ( loadImportedInsts )
  51 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType,
  52                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
  53                 )
  54 import TcType   ( Type, TcType, TcThetaType, TcTyVarSet,
  55                   PredType(..), TyVarDetails(VanillaTv),
  56                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
  57                   tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
  58                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  59                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  60                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  61                   isClassPred, isTyVarClassPred, isLinearPred,
  62                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  63                   isInheritablePred, isIPPred, matchTys,
  64                   tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
  65                   pprPred, pprParendType, pprThetaArrow, pprClassPred
  66                 )
  67 import HscTypes ( ExternalPackageState(..) )
  68 import CoreFVs  ( idFreeTyVars )
  69 import DataCon  ( DataCon,dataConSig )
  70 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
  71 import PrelInfo ( isStandardClass, isNoDictClass )
  72 import Name     ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
  73 import NameSet  ( addOneToNameSet )
  74 import Subst    ( substTy, substTyWith, substTheta, mkTyVarSubst )
  75 import Literal  ( inIntRange )
  76 import Var      ( TyVar )
  77 import VarEnv   ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
  78 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
  79 import TysWiredIn ( floatDataCon, doubleDataCon )
  80 import PrelNames        ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
  81 import BasicTypes( IPName(..), mapIPName, ipNameName )
  82 import UniqSupply( uniqsFromSupply )
  83 import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
  84 import Maybes   ( isJust )
  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       ; env <- getGblEnv
 542       ; dflags  <- getDOpts
 543       ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
 544       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 545                          tcg_inst_env = inst_env' }
 546       ; setGblEnv env' thing_inside }
 547
 548 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
 549 -- Check that the proposed new instance is OK,
 550 -- and then add it to the home inst env
 551 addInst dflags home_ie dfun
 552   = do  {       -- Load imported instances, so that we report
 553                 -- duplicates correctly
 554           pkg_ie  <- loadImportedInsts cls tys
 555
 556                 -- Check functional dependencies
 557         ; case checkFunDeps (pkg_ie, home_ie) dfun of
 558                 Just dfuns -> funDepErr dfun dfuns
 559                 Nothing    -> return ()
 560
 561                 -- Check for duplicate instance decls
 562         ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
 563               ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
 564                                         isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
 565                 -- Find memebers of the match list which
 566                 -- dfun itself matches. If the match is 2-way, it's a duplicate
 567         ; case dup_dfuns of
 568             dup_dfun : _ -> dupInstErr dfun dup_dfun
 569             []           -> return ()
 570
 571                 -- OK, now extend the envt
 572         ; return (extendInstEnv home_ie dfun) }
 573   where
 574     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 575
 576 traceDFuns dfuns
 577   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 578   where
 579     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 580
 581 funDepErr dfun dfuns
 582   = addSrcLoc (getSrcLoc dfun) $
 583     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 584                2 (pprDFuns (dfun:dfuns)))
 585 dupInstErr dfun dup_dfun
 586   = addSrcLoc (getSrcLoc dfun) $
 587     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 588                2 (pprDFuns [dfun, dup_dfun]))
 589 \end{code}
 590
 591 %************************************************************************
 592 %*                                                                      *
 593 \subsection{Looking up Insts}
 594 %*                                                                      *
 595 %************************************************************************
 596
 597 \begin{code}
 598 data LookupInstResult s
 599   = NoInstance
 600   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 601   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 602
 603 lookupInst :: Inst -> TcM (LookupInstResult s)
 604 -- It's important that lookupInst does not put any new stuff into
 605 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 606 -- the LookupInstResult, where they can be further processed by tcSimplify
 607
 608
 609 -- Methods
 610
 611 lookupInst inst@(Method _ id tys theta _ loc)
 612   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 613     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 614
 615 -- Literals
 616
 617 -- Look for short cuts first: if the literal is *definitely* a
 618 -- int, integer, float or a double, generate the real thing here.
 619 -- This is essential  (see nofib/spectral/nucleic).
 620 -- [Same shortcut as in newOverloadedLit, but we
 621 --  may have done some unification by now]
 622
 623
 624 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 625   | Just expr <- shortCutIntLit i ty
 626   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 627                                         -- expr may be a constructor application
 628   | otherwise
 629   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 630     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 631     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 632     mkIntegerLit i                              `thenM` \ integer_lit ->
 633     returnM (GenInst [method_inst]
 634                      (HsApp (HsVar (instToId method_inst)) integer_lit))
 635
 636 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 637   | Just expr <- shortCutFracLit f ty
 638   = returnM (GenInst [] expr)
 639
 640   | otherwise
 641   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 642     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 643     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 644     mkRatLit f                                  `thenM` \ rat_lit ->
 645     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
 646
 647 -- Dictionaries
 648 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 649   = do  { dflags  <- getDOpts
 650         ; if all tcIsTyVarTy tys &&
 651              not (dopt Opt_AllowUndecidableInstances dflags)
 652                 -- Common special case; no lookup
 653                 -- NB: tcIsTyVarTy... don't look through newtypes!
 654                 -- Don't take this short cut if we allow undecidable instances
 655                 -- because we might have "instance T a where ...".
 656                 -- [That means we need -fallow-undecidable-instances in the
 657                 --  client module, as well as the module with the instance decl.]
 658           then return NoInstance
 659
 660           else do
 661         { pkg_ie  <- loadImportedInsts clas tys
 662                 -- Suck in any instance decls that may be relevant
 663         ; tcg_env <- getGblEnv
 664         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 665             ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
 666             (matches, unifs)              -> do
 667         { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
 668                                                text "unifs" <+> ppr unifs])
 669         ; return NoInstance } } } }
 670                 -- In the case of overlap (multiple matches) we report
 671                 -- NoInstance here.  That has the effect of making the
 672                 -- context-simplifier return the dict as an irreducible one.
 673                 -- Then it'll be given to addNoInstanceErrs, which will do another
 674                 -- lookupInstEnv to get the detailed info about what went wrong.
 675
 676 lookupInst (Dict _ _ _) = returnM NoInstance
 677
 678 -----------------
 679 instantiate_dfun tenv dfun_id pred loc
 680   =     -- Record that this dfun is needed
 681     record_dfun_usage dfun_id           `thenM_`
 682
 683         -- It's possible that not all the tyvars are in
 684         -- the substitution, tenv. For example:
 685         --      instance C X a => D X where ...
 686         -- (presumably there's a functional dependency in class C)
 687         -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 688     getStage                                            `thenM` \ use_stage ->
 689     checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 690                     (topIdLvl dfun_id) use_stage                `thenM_`
 691     let
 692         (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 693         mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 694                            Just (DoneTy ty) -> returnM ty
 695                            Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 696                                                returnM (mkTyVarTy tc_tv)
 697     in
 698     mappM mk_ty_arg tyvars      `thenM` \ ty_args ->
 699     let
 700         dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 701         (theta, _) = tcSplitPhiTy dfun_rho
 702         ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 703     in
 704     if null theta then
 705         returnM (SimpleInst ty_app)
 706     else
 707     newDictsAtLoc loc theta     `thenM` \ dicts ->
 708     let
 709         rhs = mkHsDictApp ty_app (map instToId dicts)
 710     in
 711     returnM (GenInst dicts rhs)
 712
 713 record_dfun_usage dfun_id
 714   | isInternalName dfun_name = return ()                -- From this module
 715   | not (isHomePackageName dfun_name) = return ()       -- From another package package
 716   | otherwise = getGblEnv       `thenM` \ tcg_env ->
 717                 updMutVar (tcg_inst_uses tcg_env)
 718                           (`addOneToNameSet` idName dfun_id)
 719   where
 720     dfun_name = idName dfun_id
 721
 722 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 723 -- Gets both the home-pkg inst env (includes module being compiled)
 724 -- and the external-package inst-env
 725 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 726                      return (tcg_inst_env env, eps_inst_env eps) }
 727 \end{code}
 728
 729
 730
 731 %************************************************************************
 732 %*                                                                      *
 733                 Re-mappable syntax
 734 %*                                                                      *
 735 %************************************************************************
 736
 737
 738 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 739 a do-expression.  We have to find (>>) in the current environment, which is
 740 done by the rename. Then we have to check that it has the same type as
 741 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 742 this:
 743
 744   (>>) :: HB m n mn => m a -> n b -> mn b
 745
 746 So the idea is to generate a local binding for (>>), thus:
 747
 748         let then72 :: forall a b. m a -> m b -> m b
 749             then72 = ...something involving the user's (>>)...
 750         in
 751         ...the do-expression...
 752
 753 Now the do-expression can proceed using then72, which has exactly
 754 the expected type.
 755
 756 In fact tcSyntaxName just generates the RHS for then72, because we only
 757 want an actual binding in the do-expression case. For literals, we can
 758 just use the expression inline.
 759
 760 \begin{code}
 761 tcSyntaxName :: InstOrigin
 762              -> TcType                  -- Type to instantiate it at
 763              -> (Name, HsExpr Name)     -- (Standard name, user name)
 764              -> TcM (Name, TcExpr)      -- (Standard name, suitable expression)
 765
 766 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 767 -- So we do not call it from lookupInst, which is called from tcSimplify
 768
 769 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 770   | std_nm == user_nm
 771   = tcStdSyntaxName orig ty std_nm
 772
 773 tcSyntaxName orig ty (std_nm, user_nm_expr)
 774   = tcLookupId std_nm           `thenM` \ std_id ->
 775     let
 776         -- C.f. newMethodAtLoc
 777         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 778         tau1            = substTyWith [tv] [ty] tau
 779         -- Actually, the "tau-type" might be a sigma-type in the
 780         -- case of locally-polymorphic methods.
 781     in
 782     addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
 783
 784         -- Check that the user-supplied thing has the
 785         -- same type as the standard one
 786     tcCheckSigma user_nm_expr tau1                      `thenM` \ expr ->
 787     returnM (std_nm, expr)
 788
 789 tcStdSyntaxName :: InstOrigin
 790                 -> TcType               -- Type to instantiate it at
 791                 -> Name                 -- Standard name
 792                 -> TcM (Name, TcExpr)   -- (Standard name, suitable expression)
 793
 794 tcStdSyntaxName orig ty std_nm
 795   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 796     returnM (std_nm, HsVar id)
 797
 798 syntaxNameCtxt name orig ty tidy_env
 799   = getInstLoc orig             `thenM` \ inst_loc ->
 800     let
 801         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 802                                 ptext SLIT("(needed by a syntactic construct)"),
 803                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 804                     nest 2 (pprInstLoc inst_loc)]
 805     in
 806     returnM (tidy_env, msg)
 807 \end{code}