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