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, pprDFuns, pprDictsTheta, pprDictsInFull,
  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, pprTheta, 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 pprDictsTheta :: [Inst] -> SDoc
 500 -- Print in type-like fashion (Eq a, Show b)
 501 pprDictsTheta dicts = pprTheta (map dictPred dicts)
 502
 503 pprDictsInFull :: [Inst] -> SDoc
 504 -- Print in type-like fashion, but with source location
 505 pprDictsInFull dicts
 506   = vcat (map go dicts)
 507   where
 508     go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
 509
 510 pprInsts :: [Inst] -> SDoc
 511 -- Debugging: print the evidence :: type
 512 pprInsts insts  = brackets (interpp'SP insts)
 513
 514 pprInst, pprInstInFull :: Inst -> SDoc
 515 -- Debugging: print the evidence :: type
 516 pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
 517 pprInst (Dict id pred loc)      = ppr id <+> dcolon <+> pprPred pred
 518
 519 pprInst m@(Method inst_id id tys theta tau loc)
 520   = ppr inst_id <+> dcolon <+>
 521         braces (sep [ppr id <+> ptext SLIT("at"),
 522                      brackets (sep (map pprParendType tys))])
 523
 524 pprInstInFull inst
 525   = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
 526
 527 pprDFuns :: [DFunId] -> SDoc
 528 -- Prints the dfun as an instance declaration
 529 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
 530                         2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
 531                                                            pprClassPred clas tys])
 532                       | dfun <- dfuns
 533                       , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
 534         -- Print without the for-all, which the programmer doesn't write
 535
 536 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 537
 538 tidyInst :: TidyEnv -> Inst -> Inst
 539 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 540 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 541 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 542
 543 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 544 -- This function doesn't assume that the tyvars are in scope
 545 -- so it works like tidyOpenType, returning a TidyEnv
 546 tidyMoreInsts env insts
 547   = (env', map (tidyInst env') insts)
 548   where
 549     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 550
 551 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 552 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 553
 554 showLIE :: SDoc -> TcM ()       -- Debugging
 555 showLIE str
 556   = do { lie_var <- getLIEVar ;
 557          lie <- readMutVar lie_var ;
 558          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 559 \end{code}
 560
 561
 562 %************************************************************************
 563 %*                                                                      *
 564         Extending the instance environment
 565 %*                                                                      *
 566 %************************************************************************
 567
 568 \begin{code}
 569 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
 570   -- Add new locally-defined instances
 571 tcExtendLocalInstEnv dfuns thing_inside
 572  = do { traceDFuns dfuns
 573       ; env <- getGblEnv
 574       ; dflags  <- getDOpts
 575       ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
 576       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 577                          tcg_inst_env = inst_env' }
 578       ; setGblEnv env' thing_inside }
 579
 580 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
 581 -- Check that the proposed new instance is OK,
 582 -- and then add it to the home inst env
 583 addInst dflags home_ie dfun
 584   = do  {       -- Load imported instances, so that we report
 585                 -- duplicates correctly
 586           pkg_ie  <- loadImportedInsts cls tys
 587
 588                 -- Check functional dependencies
 589         ; case checkFunDeps (pkg_ie, home_ie) dfun of
 590                 Just dfuns -> funDepErr dfun dfuns
 591                 Nothing    -> return ()
 592
 593                 -- Check for duplicate instance decls
 594         ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
 595               ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
 596                                         isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
 597                 -- Find memebers of the match list which
 598                 -- dfun itself matches. If the match is 2-way, it's a duplicate
 599         ; case dup_dfuns of
 600             dup_dfun : _ -> dupInstErr dfun dup_dfun
 601             []           -> return ()
 602
 603                 -- OK, now extend the envt
 604         ; return (extendInstEnv home_ie dfun) }
 605   where
 606     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 607
 608 traceDFuns dfuns
 609   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 610   where
 611     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 612
 613 funDepErr dfun dfuns
 614   = addDictLoc dfun $
 615     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 616                2 (pprDFuns (dfun:dfuns)))
 617 dupInstErr dfun dup_dfun
 618   = addDictLoc dfun $
 619     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 620                2 (pprDFuns [dfun, dup_dfun]))
 621
 622 addDictLoc dfun thing_inside
 623   = addSrcSpan (mkSrcSpan loc loc) thing_inside
 624   where
 625    loc = getSrcLoc dfun
 626 \end{code}
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsection{Looking up Insts}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 data LookupInstResult s
 636   = NoInstance
 637   | SimpleInst (LHsExpr TcId)           -- Just a variable, type application, or literal
 638   | GenInst    [Inst] (LHsExpr TcId)    -- The expression and its needed insts
 639
 640 lookupInst :: Inst -> TcM (LookupInstResult s)
 641 -- It's important that lookupInst does not put any new stuff into
 642 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 643 -- the LookupInstResult, where they can be further processed by tcSimplify
 644
 645
 646 -- Methods
 647
 648 lookupInst inst@(Method _ id tys theta _ loc)
 649   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 650     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
 651   where
 652     span = instLocSrcSpan loc
 653
 654 -- Literals
 655
 656 -- Look for short cuts first: if the literal is *definitely* a
 657 -- int, integer, float or a double, generate the real thing here.
 658 -- This is essential  (see nofib/spectral/nucleic).
 659 -- [Same shortcut as in newOverloadedLit, but we
 660 --  may have done some unification by now]
 661
 662
 663 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 664   | Just expr <- shortCutIntLit i ty
 665   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because
 666                                         -- expr may be a constructor application
 667   | otherwise
 668   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
 669     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 670     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 671     mkIntegerLit i                              `thenM` \ integer_lit ->
 672     returnM (GenInst [method_inst]
 673                      (mkHsApp (L (instLocSrcSpan loc)
 674                                  (HsVar (instToId method_inst))) integer_lit))
 675
 676 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 677   | Just expr <- shortCutFracLit f ty
 678   = returnM (GenInst [] expr)
 679
 680   | otherwise
 681   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
 682     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 683     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 684     mkRatLit f                                  `thenM` \ rat_lit ->
 685     returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
 686                                                (HsVar (instToId method_inst))) rat_lit))
 687
 688 -- Dictionaries
 689 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 690   = do  { dflags  <- getDOpts
 691         ; if all tcIsTyVarTy tys &&
 692              not (dopt Opt_AllowUndecidableInstances dflags)
 693                 -- Common special case; no lookup
 694                 -- NB: tcIsTyVarTy... don't look through newtypes!
 695                 -- Don't take this short cut if we allow undecidable instances
 696                 -- because we might have "instance T a where ...".
 697                 -- [That means we need -fallow-undecidable-instances in the
 698                 --  client module, as well as the module with the instance decl.]
 699           then return NoInstance
 700
 701           else do
 702         { pkg_ie  <- loadImportedInsts clas tys
 703                 -- Suck in any instance decls that may be relevant
 704         ; tcg_env <- getGblEnv
 705         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 706             ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
 707             (matches, unifs)              -> do
 708         { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
 709                                                text "unifs" <+> ppr unifs])
 710         ; return NoInstance } } } }
 711                 -- In the case of overlap (multiple matches) we report
 712                 -- NoInstance here.  That has the effect of making the
 713                 -- context-simplifier return the dict as an irreducible one.
 714                 -- Then it'll be given to addNoInstanceErrs, which will do another
 715                 -- lookupInstEnv to get the detailed info about what went wrong.
 716
 717 lookupInst (Dict _ _ _) = returnM NoInstance
 718
 719 -----------------
 720 instantiate_dfun tenv dfun_id pred loc
 721   =     -- Record that this dfun is needed
 722     record_dfun_usage dfun_id           `thenM_`
 723
 724         -- It's possible that not all the tyvars are in
 725         -- the substitution, tenv. For example:
 726         --      instance C X a => D X where ...
 727         -- (presumably there's a functional dependency in class C)
 728         -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 729     getStage                                            `thenM` \ use_stage ->
 730     checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 731                     (topIdLvl dfun_id) use_stage                `thenM_`
 732     let
 733         (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 734         mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 735                            Just (DoneTy ty) -> returnM ty
 736                            Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
 737                                                returnM (mkTyVarTy tc_tv)
 738     in
 739     mappM mk_ty_arg tyvars      `thenM` \ ty_args ->
 740     let
 741         dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 742         (theta, _) = tcSplitPhiTy dfun_rho
 743         ty_app     = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
 744     in
 745     if null theta then
 746         returnM (SimpleInst ty_app)
 747     else
 748     newDictsAtLoc loc theta     `thenM` \ dicts ->
 749     let
 750         rhs = mkHsDictApp ty_app (map instToId dicts)
 751     in
 752     returnM (GenInst dicts rhs)
 753
 754 record_dfun_usage dfun_id
 755   | isInternalName dfun_name = return ()                -- From this module
 756   | not (isHomePackageName dfun_name) = return ()       -- From another package package
 757   | otherwise = getGblEnv       `thenM` \ tcg_env ->
 758                 updMutVar (tcg_inst_uses tcg_env)
 759                           (`addOneToNameSet` idName dfun_id)
 760   where
 761     dfun_name = idName dfun_id
 762
 763 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 764 -- Gets both the home-pkg inst env (includes module being compiled)
 765 -- and the external-package inst-env
 766 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 767                      return (tcg_inst_env env, eps_inst_env eps) }
 768 \end{code}
 769
 770
 771
 772 %************************************************************************
 773 %*                                                                      *
 774                 Re-mappable syntax
 775 %*                                                                      *
 776 %************************************************************************
 777
 778
 779 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 780 a do-expression.  We have to find (>>) in the current environment, which is
 781 done by the rename. Then we have to check that it has the same type as
 782 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 783 this:
 784
 785   (>>) :: HB m n mn => m a -> n b -> mn b
 786
 787 So the idea is to generate a local binding for (>>), thus:
 788
 789         let then72 :: forall a b. m a -> m b -> m b
 790             then72 = ...something involving the user's (>>)...
 791         in
 792         ...the do-expression...
 793
 794 Now the do-expression can proceed using then72, which has exactly
 795 the expected type.
 796
 797 In fact tcSyntaxName just generates the RHS for then72, because we only
 798 want an actual binding in the do-expression case. For literals, we can
 799 just use the expression inline.
 800
 801 \begin{code}
 802 tcSyntaxName :: InstOrigin
 803              -> TcType                  -- Type to instantiate it at
 804              -> (Name, LHsExpr Name)    -- (Standard name, user name)
 805              -> TcM (Name, LHsExpr TcId)        -- (Standard name, suitable expression)
 806
 807 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 808 -- So we do not call it from lookupInst, which is called from tcSimplify
 809
 810 tcSyntaxName orig ty (std_nm, L span (HsVar user_nm))
 811   | std_nm == user_nm
 812   = addSrcSpan span (tcStdSyntaxName orig ty std_nm)
 813
 814 tcSyntaxName orig ty (std_nm, user_nm_expr)
 815   = tcLookupId std_nm           `thenM` \ std_id ->
 816     let
 817         -- C.f. newMethodAtLoc
 818         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 819         tau1            = substTyWith [tv] [ty] tau
 820         -- Actually, the "tau-type" might be a sigma-type in the
 821         -- case of locally-polymorphic methods.
 822     in
 823     addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
 824
 825         -- Check that the user-supplied thing has the
 826         -- same type as the standard one
 827     tcCheckSigma user_nm_expr tau1              `thenM` \ expr ->
 828     returnM (std_nm, expr)
 829
 830 tcStdSyntaxName :: InstOrigin
 831                 -> TcType                       -- Type to instantiate it at
 832                 -> Name                         -- Standard name
 833                 -> TcM (Name, LHsExpr TcId)     -- (Standard name, suitable expression)
 834
 835 tcStdSyntaxName orig ty std_nm
 836   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 837     getSrcSpanM                         `thenM` \ span ->
 838     returnM (std_nm, L span (HsVar id))
 839
 840 syntaxNameCtxt name orig ty tidy_env
 841   = getInstLoc orig             `thenM` \ inst_loc ->
 842     let
 843         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 844                                 ptext SLIT("(needed by a syntactic construct)"),
 845                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 846                     nest 2 (pprInstLoc inst_loc)]
 847     in
 848     returnM (tidy_env, msg)
 849 \end{code}