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