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