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