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         newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
  16         tcOverloadedLit, newIPDict,
  17         newMethod, newMethodFromName, newMethodWithGivenTy,
  18         tcInstClassOp, tcInstCall, tcInstStupidTheta,
  19         tcSyntaxName,
  20
  21         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  22         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  23         instLoc, getDictClassTys, dictPred,
  24
  25         lookupInst, LookupInstResult(..), lookupPred,
  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, tcSyntaxOp )
  42 import {-# SOURCE #-}   TcUnify ( unifyTauTy )  -- Used in checkKind (sigh)
  43
  44 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
  45                   nlHsLit, nlHsVar )
  46 import TcHsSyn  ( TcId, TcIdSet,
  47                   mkHsTyApp, mkHsDictApp, zonkId,
  48                   mkCoercion, ExprCoFn
  49                 )
  50 import TcRnMonad
  51 import TcEnv    ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
  52 import InstEnv  ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
  53 import TcIface  ( loadImportedInsts )
  54 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
  55                   tcInstTyVar, tcInstType, tcSkolType
  56                 )
  57 import TcType   ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
  58                   PredType(..), SkolemInfo(..), Expected(..), typeKind, mkSigmaTy,
  59                   tcSplitForAllTys, tcSplitForAllTys, mkFunTy,
  60                   tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
  61                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  62                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  63                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  64                   isClassPred, isTyVarClassPred, isLinearPred,
  65                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  66                   isInheritablePred, isIPPred,
  67                   tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
  68                   pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
  69                 )
  70 import Type     ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
  71                   notElemTvSubst, extendTvSubstList )
  72 import Unify    ( tcMatchTys )
  73 import Kind     ( isSubKind )
  74 import Packages ( isHomeModule )
  75 import HscTypes ( ExternalPackageState(..) )
  76 import CoreFVs  ( idFreeTyVars )
  77 import DataCon  ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
  78 import Id       ( Id, idName, idType, mkUserLocal, mkLocalId )
  79 import PrelInfo ( isStandardClass, isNoDictClass )
  80 import Name     ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
  81                   isInternalName, setNameUnique, mkSystemVarNameEncoded )
  82 import NameSet  ( addOneToNameSet )
  83 import Literal  ( inIntRange )
  84 import Var      ( TyVar, tyVarKind, setIdType )
  85 import VarEnv   ( TidyEnv, emptyTidyEnv )
  86 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
  87 import TysWiredIn ( floatDataCon, doubleDataCon )
  88 import PrelNames        ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
  89 import BasicTypes( IPName(..), mapIPName, ipNameName )
  90 import UniqSupply( uniqsFromSupply )
  91 import SrcLoc   ( mkSrcSpan, noLoc, unLoc, Located(..) )
  92 import DynFlags( DynFlags )
  93 import Maybes   ( isJust )
  94 import Outputable
  95 \end{code}
  96
  97
  98 Selection
  99 ~~~~~~~~~
 100 \begin{code}
 101 instName :: Inst -> Name
 102 instName inst = idName (instToId inst)
 103
 104 instToId :: Inst -> TcId
 105 instToId (LitInst nm _ ty _)   = mkLocalId nm ty
 106 instToId (Dict nm pred _)      = mkLocalId nm (mkPredTy pred)
 107 instToId (Method id _ _ _ _ _) = id
 108
 109 instLoc (Dict _ _         loc) = loc
 110 instLoc (Method _ _ _ _ _ loc) = loc
 111 instLoc (LitInst _ _ _    loc) = loc
 112
 113 dictPred (Dict _ pred _ ) = pred
 114 dictPred inst             = pprPanic "dictPred" (ppr inst)
 115
 116 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 117
 118 -- fdPredsOfInst is used to get predicates that contain functional
 119 -- dependencies *or* might do so.  The "might do" part is because
 120 -- a constraint (C a b) might have a superclass with FDs
 121 -- Leaving these in is really important for the call to fdPredsOfInsts
 122 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 123 -- which is supposed to be conservative
 124 fdPredsOfInst (Dict _ pred _)          = [pred]
 125 fdPredsOfInst (Method _ _ _ theta _ _) = theta
 126 fdPredsOfInst other                    = []     -- LitInsts etc
 127
 128 fdPredsOfInsts :: [Inst] -> [PredType]
 129 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 130
 131 isInheritableInst (Dict _ pred _)          = isInheritablePred pred
 132 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
 133 isInheritableInst other                    = True
 134
 135
 136 ipNamesOfInsts :: [Inst] -> [Name]
 137 ipNamesOfInst  :: Inst   -> [Name]
 138 -- Get the implicit parameters mentioned by these Insts
 139 -- NB: ?x and %x get different Names
 140 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 141
 142 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 143 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 144 ipNamesOfInst other                    = []
 145
 146 tyVarsOfInst :: Inst -> TcTyVarSet
 147 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 148 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 149 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 150                                          -- The id might have free type variables; in the case of
 151                                          -- locally-overloaded class methods, for example
 152
 153
 154 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 155 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 156 \end{code}
 157
 158 Predicates
 159 ~~~~~~~~~~
 160 \begin{code}
 161 isDict :: Inst -> Bool
 162 isDict (Dict _ _ _) = True
 163 isDict other        = False
 164
 165 isClassDict :: Inst -> Bool
 166 isClassDict (Dict _ pred _) = isClassPred pred
 167 isClassDict other           = False
 168
 169 isTyVarDict :: Inst -> Bool
 170 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 171 isTyVarDict other           = False
 172
 173 isIPDict :: Inst -> Bool
 174 isIPDict (Dict _ pred _) = isIPPred pred
 175 isIPDict other           = False
 176
 177 isMethod :: Inst -> Bool
 178 isMethod (Method _ _ _ _ _ _) = True
 179 isMethod other                = False
 180
 181 isMethodFor :: TcIdSet -> Inst -> Bool
 182 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 183 isMethodFor ids inst                         = False
 184
 185 isLinearInst :: Inst -> Bool
 186 isLinearInst (Dict _ pred _) = isLinearPred pred
 187 isLinearInst other           = False
 188         -- We never build Method Insts that have
 189         -- linear implicit paramters in them.
 190         -- Hence no need to look for Methods
 191         -- See TcExpr.tcId
 192
 193 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 194 linearInstType (Dict _ (IParam _ ty) _) = ty
 195
 196
 197 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 198                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 199                                         other             -> False
 200 \end{code}
 201
 202 Two predicates which deal with the case where class constraints don't
 203 necessarily result in bindings.  The first tells whether an @Inst@
 204 must be witnessed by an actual binding; the second tells whether an
 205 @Inst@ can be generalised over.
 206
 207 \begin{code}
 208 instBindingRequired :: Inst -> Bool
 209 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 210 instBindingRequired other                      = True
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection{Building dictionaries}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 \begin{code}
 221 newDicts :: InstOrigin
 222          -> TcThetaType
 223          -> TcM [Inst]
 224 newDicts orig theta
 225   = getInstLoc orig             `thenM` \ loc ->
 226     newDictsAtLoc loc theta
 227
 228 cloneDict :: Inst -> TcM Inst
 229 cloneDict (Dict nm ty loc) = newUnique  `thenM` \ uniq ->
 230                              returnM (Dict (setNameUnique nm uniq) ty loc)
 231
 232 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
 233 newDictAtLoc inst_loc pred
 234   = do  { uniq <- newUnique
 235         ; return (mkDict inst_loc uniq pred) }
 236
 237 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
 238 newDictsAtLoc inst_loc theta
 239   = newUniqueSupply             `thenM` \ us ->
 240     returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
 241
 242 mkDict inst_loc uniq pred
 243   = Dict name pred inst_loc
 244   where
 245     name = mkPredName uniq (instLocSrcLoc inst_loc) pred
 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 tcOverloadedLit 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 tcOverloadedLit :: InstOrigin
 367                  -> HsOverLit Name
 368                  -> TcType
 369                  -> TcM (HsOverLit TcId)
 370 tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
 371   | not (fi `isHsVar` fromIntegerName)  -- Do not generate a LitInst for rebindable syntax.
 372         -- Reason: If we do, tcSimplify will call lookupInst, which
 373         --         will call tcSyntaxName, which does unification,
 374         --         which tcSimplify doesn't like
 375         -- ToDo: noLoc sadness
 376   = do  { integer_ty <- tcMetaTy integerTyConName
 377         ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
 378         ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
 379
 380   | Just expr <- shortCutIntLit i expected_ty
 381   = return (HsIntegral i expr)
 382
 383   | otherwise
 384   = do  { expr <- newLitInst orig lit expected_ty
 385         ; return (HsIntegral i expr) }
 386
 387 tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
 388   | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
 389   = do  { rat_ty <- tcMetaTy rationalTyConName
 390         ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
 391         ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
 392
 393   | Just expr <- shortCutFracLit r expected_ty
 394   = return (HsFractional r expr)
 395
 396   | otherwise
 397   = do  { expr <- newLitInst orig lit expected_ty
 398         ; return (HsFractional r expr) }
 399
 400 newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
 401 newLitInst orig lit expected_ty -- Make a LitInst
 402   = do  { loc <- getInstLoc orig
 403         ; new_uniq <- newUnique
 404         ; let
 405                 lit_nm   = mkSystemVarNameEncoded new_uniq FSLIT("lit")
 406                 -- The "encoded" bit means that we don't need to
 407                 -- z-encode the string every time we call this!
 408                 lit_inst = LitInst lit_nm lit expected_ty loc
 409         ; extendLIE lit_inst
 410         ; return (HsVar (instToId lit_inst)) }
 411
 412 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
 413 shortCutIntLit i ty
 414   | isIntTy ty && inIntRange i          -- Short cut for Int
 415   = Just (HsLit (HsInt i))
 416   | isIntegerTy ty                      -- Short cut for Integer
 417   = Just (HsLit (HsInteger i ty))
 418   | otherwise = Nothing
 419
 420 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
 421 shortCutFracLit f ty
 422   | isFloatTy ty
 423   = Just (mk_lit floatDataCon (HsFloatPrim f))
 424   | isDoubleTy ty
 425   = Just (mk_lit doubleDataCon (HsDoublePrim f))
 426   | otherwise = Nothing
 427   where
 428     mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 429
 430 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 431 mkIntegerLit i
 432   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 433     getSrcSpanM                 `thenM` \ span ->
 434     returnM (L span $ HsLit (HsInteger i integer_ty))
 435
 436 mkRatLit :: Rational -> TcM (LHsExpr TcId)
 437 mkRatLit r
 438   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 439     getSrcSpanM                 `thenM` \ span ->
 440     returnM (L span $ HsLit (HsRat r rat_ty))
 441
 442 isHsVar :: HsExpr Name -> Name -> Bool
 443 isHsVar (HsVar f) g = f==g
 444 isHsVar other     g = False
 445 \end{code}
 446
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsection{Zonking}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 Zonking makes sure that the instance types are fully zonked.
 455
 456 \begin{code}
 457 zonkInst :: Inst -> TcM Inst
 458 zonkInst (Dict name pred loc)
 459   = zonkTcPredType pred                 `thenM` \ new_pred ->
 460     returnM (Dict name new_pred loc)
 461
 462 zonkInst (Method m id tys theta tau loc)
 463   = zonkId id                   `thenM` \ new_id ->
 464         -- Essential to zonk the id in case it's a local variable
 465         -- Can't use zonkIdOcc because the id might itself be
 466         -- an InstId, in which case it won't be in scope
 467
 468     zonkTcTypes tys             `thenM` \ new_tys ->
 469     zonkTcThetaType theta       `thenM` \ new_theta ->
 470     zonkTcType tau              `thenM` \ new_tau ->
 471     returnM (Method m new_id new_tys new_theta new_tau loc)
 472
 473 zonkInst (LitInst nm lit ty loc)
 474   = zonkTcType ty                       `thenM` \ new_ty ->
 475     returnM (LitInst nm lit new_ty loc)
 476
 477 zonkInsts insts = mappM zonkInst insts
 478 \end{code}
 479
 480
 481 %************************************************************************
 482 %*                                                                      *
 483 \subsection{Printing}
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 488 relevant in error messages.
 489
 490 \begin{code}
 491 instance Outputable Inst where
 492     ppr inst = pprInst inst
 493
 494 pprDictsTheta :: [Inst] -> SDoc
 495 -- Print in type-like fashion (Eq a, Show b)
 496 pprDictsTheta dicts = pprTheta (map dictPred dicts)
 497
 498 pprDictsInFull :: [Inst] -> SDoc
 499 -- Print in type-like fashion, but with source location
 500 pprDictsInFull dicts
 501   = vcat (map go dicts)
 502   where
 503     go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
 504
 505 pprInsts :: [Inst] -> SDoc
 506 -- Debugging: print the evidence :: type
 507 pprInsts insts  = brackets (interpp'SP insts)
 508
 509 pprInst, pprInstInFull :: Inst -> SDoc
 510 -- Debugging: print the evidence :: type
 511 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
 512 pprInst (Dict nm pred loc)      = ppr nm <+> dcolon <+> pprPred pred
 513
 514 pprInst m@(Method inst_id id tys theta tau loc)
 515   = ppr inst_id <+> dcolon <+>
 516         braces (sep [ppr id <+> ptext SLIT("at"),
 517                      brackets (sep (map pprParendType tys))])
 518
 519 pprInstInFull inst
 520   = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
 521
 522 pprDFuns :: [DFunId] -> SDoc
 523 -- Prints the dfun as an instance declaration
 524 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
 525                         2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
 526                                                            pprClassPred clas tys])
 527                       | dfun <- dfuns
 528                       , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
 529         -- Print without the for-all, which the programmer doesn't write
 530
 531 tidyInst :: TidyEnv -> Inst -> Inst
 532 tidyInst env (LitInst nm lit ty loc)         = LitInst nm lit (tidyType env ty) loc
 533 tidyInst env (Dict nm pred loc)              = Dict nm (tidyPred env pred) loc
 534 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 535
 536 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 537 -- This function doesn't assume that the tyvars are in scope
 538 -- so it works like tidyOpenType, returning a TidyEnv
 539 tidyMoreInsts env insts
 540   = (env', map (tidyInst env') insts)
 541   where
 542     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 543
 544 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 545 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 546
 547 showLIE :: SDoc -> TcM ()       -- Debugging
 548 showLIE str
 549   = do { lie_var <- getLIEVar ;
 550          lie <- readMutVar lie_var ;
 551          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 552 \end{code}
 553
 554
 555 %************************************************************************
 556 %*                                                                      *
 557         Extending the instance environment
 558 %*                                                                      *
 559 %************************************************************************
 560
 561 \begin{code}
 562 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
 563   -- Add new locally-defined instances
 564 tcExtendLocalInstEnv dfuns thing_inside
 565  = do { traceDFuns dfuns
 566       ; env <- getGblEnv
 567       ; dflags  <- getDOpts
 568       ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
 569       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 570                          tcg_inst_env = inst_env' }
 571       ; setGblEnv env' thing_inside }
 572
 573 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
 574 -- Check that the proposed new instance is OK,
 575 -- and then add it to the home inst env
 576 addInst dflags home_ie dfun
 577   = do  {       -- Instantiate the dfun type so that we extend the instance
 578                 -- envt with completely fresh template variables
 579                 -- This is important because the template variables must
 580                 -- not overlap with anything in the things being looked up
 581                 -- (since we do unification).
 582                 -- We use tcSkolType because we don't want to allocate fresh
 583                 --  *meta* type variables.
 584           (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
 585         ; let   (cls, tys') = tcSplitDFunHead tau'
 586                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 587
 588                 -- Load imported instances, so that we report
 589                 -- duplicates correctly
 590         ; pkg_ie  <- loadImportedInsts cls tys'
 591
 592                 -- Check functional dependencies
 593         ; case checkFunDeps (pkg_ie, home_ie) dfun' of
 594                 Just dfuns -> funDepErr dfun dfuns
 595                 Nothing    -> return ()
 596
 597                 -- Check for duplicate instance decls
 598         ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
 599               ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
 600                                         isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 601                 -- Find memebers of the match list which
 602                 -- dfun itself matches. If the match is 2-way, it's a duplicate
 603         ; case dup_dfuns of
 604             dup_dfun : _ -> dupInstErr dfun dup_dfun
 605             []           -> return ()
 606
 607                 -- OK, now extend the envt
 608         ; return (extendInstEnv home_ie dfun') }
 609
 610
 611 traceDFuns dfuns
 612   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 613   where
 614     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 615
 616 funDepErr dfun dfuns
 617   = addDictLoc dfun $
 618     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 619                2 (pprDFuns (dfun:dfuns)))
 620 dupInstErr dfun dup_dfun
 621   = addDictLoc dfun $
 622     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 623                2 (pprDFuns [dfun, dup_dfun]))
 624
 625 addDictLoc dfun thing_inside
 626   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 627   where
 628    loc = getSrcLoc dfun
 629 \end{code}
 630
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsection{Looking up Insts}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638 \begin{code}
 639 data LookupInstResult
 640   = NoInstance
 641   | SimpleInst (LHsExpr TcId)           -- Just a variable, type application, or literal
 642   | GenInst    [Inst] (LHsExpr TcId)    -- The expression and its needed insts
 643
 644 lookupInst :: Inst -> TcM LookupInstResult
 645 -- It's important that lookupInst does not put any new stuff into
 646 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 647 -- the LookupInstResult, where they can be further processed by tcSimplify
 648
 649
 650 -- Methods
 651
 652 lookupInst inst@(Method _ id tys theta _ loc)
 653   = newDictsAtLoc loc theta             `thenM` \ dicts ->
 654     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
 655   where
 656     span = instLocSrcSpan loc
 657
 658 -- Literals
 659
 660 -- Look for short cuts first: if the literal is *definitely* a
 661 -- int, integer, float or a double, generate the real thing here.
 662 -- This is essential (see nofib/spectral/nucleic).
 663 -- [Same shortcut as in newOverloadedLit, but we
 664 --  may have done some unification by now]
 665
 666 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
 667   | Just expr <- shortCutIntLit i ty
 668   = returnM (GenInst [] (noLoc expr))   -- GenInst, not SimpleInst, because
 669                                         -- expr may be a constructor application
 670   | otherwise
 671   = ASSERT( from_integer_name `isHsVar` fromIntegerName )       -- A LitInst invariant
 672     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 673     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 674     mkIntegerLit i                              `thenM` \ integer_lit ->
 675     returnM (GenInst [method_inst]
 676                      (mkHsApp (L (instLocSrcSpan loc)
 677                                  (HsVar (instToId method_inst))) integer_lit))
 678
 679 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
 680   | Just expr <- shortCutFracLit f ty
 681   = returnM (GenInst [] (noLoc expr))
 682
 683   | otherwise
 684   = ASSERT( from_rat_name `isHsVar` fromRationalName )  -- A LitInst invariant
 685     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 686     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 687     mkRatLit f                                  `thenM` \ rat_lit ->
 688     returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
 689                                                (HsVar (instToId method_inst))) rat_lit))
 690
 691 -- Dictionaries
 692 lookupInst (Dict _ pred loc)
 693   = do  { mb_result <- lookupPred pred
 694         ; case mb_result of {
 695             Nothing -> return NoInstance ;
 696             Just (tenv, dfun_id) -> do
 697
 698     -- tenv is a substitution that instantiates the dfun_id
 699     -- to match the requested result type.
 700     --
 701     -- We ASSUME that the dfun is quantified over the very same tyvars
 702     -- that are bound by the tenv.
 703     --
 704     -- 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     { use_stage <- getStage
 710     ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 711                       (topIdLvl dfun_id) use_stage
 712
 713         -- It's possible that not all the tyvars are in
 714         -- the substitution, tenv. For example:
 715         --      instance C X a => D X where ...
 716         -- (presumably there's a functional dependency in class C)
 717         -- Hence the open_tvs to instantiate any un-substituted tyvars.
 718     ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 719           open_tvs      = filter (`notElemTvSubst` tenv) tyvars
 720     ; open_tvs' <- mappM tcInstTyVar open_tvs
 721     ; let
 722         tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
 723                 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
 724                 -- any nested for-alls in rho.  So the in-scope set is unchanged
 725         dfun_rho   = substTy tenv' rho
 726         (theta, _) = tcSplitPhiTy dfun_rho
 727         ty_app     = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
 728                                (map (substTyVar tenv') tyvars)
 729     ; if null theta then
 730         returnM (SimpleInst ty_app)
 731       else do
 732     { dicts <- newDictsAtLoc loc theta
 733     ; let rhs = mkHsDictApp ty_app (map instToId dicts)
 734     ; returnM (GenInst dicts rhs)
 735     }}}}
 736
 737 ---------------
 738 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
 739 -- Look up a class constraint in the instance environment
 740 lookupPred pred@(ClassP clas tys)
 741   = do  { pkg_ie <- loadImportedInsts clas tys
 742                 -- Suck in any instance decls that may be relevant
 743         ; tcg_env <- getGblEnv
 744         ; dflags  <- getDOpts
 745         ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 746             ([(tenv, (_,_,dfun_id))], [])
 747                 -> do   { traceTc (text "lookupInst success" <+>
 748                                    vcat [text "dict" <+> ppr pred,
 749                                          text "witness" <+> ppr dfun_id
 750                                          <+> ppr (idType dfun_id) ])
 751                                 -- Record that this dfun is needed
 752                         ; record_dfun_usage dfun_id
 753                         ; return (Just (tenv, dfun_id)) } ;
 754
 755             (matches, unifs)
 756                 -> do   { traceTc (text "lookupInst fail" <+>
 757                                    vcat [text "dict" <+> ppr pred,
 758                                          text "matches" <+> ppr matches,
 759                                          text "unifs" <+> ppr unifs])
 760                 -- In the case of overlap (multiple matches) we report
 761                 -- NoInstance here.  That has the effect of making the
 762                 -- context-simplifier return the dict as an irreducible one.
 763                 -- Then it'll be given to addNoInstanceErrs, which will do another
 764                 -- lookupInstEnv to get the detailed info about what went wrong.
 765                         ; return Nothing }
 766         }}
 767
 768 lookupPred ip_pred = return Nothing
 769
 770 record_dfun_usage dfun_id
 771   = do  { dflags <- getDOpts
 772         ; let  dfun_name = idName dfun_id
 773                dfun_mod  = nameModule dfun_name
 774         ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
 775           then return () -- internal, or in another package
 776            else do { tcg_env <- getGblEnv
 777                    ; updMutVar (tcg_inst_uses tcg_env)
 778                                (`addOneToNameSet` idName dfun_id) }}
 779
 780
 781 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 782 -- Gets both the external-package inst-env
 783 -- and the home-pkg inst env (includes module being compiled)
 784 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 785                      return (eps_inst_env eps, tcg_inst_env env) }
 786 \end{code}
 787
 788
 789
 790 %************************************************************************
 791 %*                                                                      *
 792                 Re-mappable syntax
 793 %*                                                                      *
 794 %************************************************************************
 795
 796 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 797 a do-expression.  We have to find (>>) in the current environment, which is
 798 done by the rename. Then we have to check that it has the same type as
 799 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 800 this:
 801
 802   (>>) :: HB m n mn => m a -> n b -> mn b
 803
 804 So the idea is to generate a local binding for (>>), thus:
 805
 806         let then72 :: forall a b. m a -> m b -> m b
 807             then72 = ...something involving the user's (>>)...
 808         in
 809         ...the do-expression...
 810
 811 Now the do-expression can proceed using then72, which has exactly
 812 the expected type.
 813
 814 In fact tcSyntaxName just generates the RHS for then72, because we only
 815 want an actual binding in the do-expression case. For literals, we can
 816 just use the expression inline.
 817
 818 \begin{code}
 819 tcSyntaxName :: InstOrigin
 820              -> TcType                  -- Type to instantiate it at
 821              -> (Name, HsExpr Name)     -- (Standard name, user name)
 822              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 823 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 824 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 825 -- So we do not call it from lookupInst, which is called from tcSimplify
 826
 827 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 828   | std_nm == user_nm
 829   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 830     returnM (std_nm, HsVar id)
 831
 832 tcSyntaxName orig ty (std_nm, user_nm_expr)
 833   = tcLookupId std_nm           `thenM` \ std_id ->
 834     let
 835         -- C.f. newMethodAtLoc
 836         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 837         sigma1          = substTyWith [tv] [ty] tau
 838         -- Actually, the "tau-type" might be a sigma-type in the
 839         -- case of locally-polymorphic methods.
 840     in
 841     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)       $
 842
 843         -- Check that the user-supplied thing has the
 844         -- same type as the standard one.
 845         -- Tiresome jiggling because tcCheckSigma takes a located expression
 846     getSrcSpanM                                 `thenM` \ span ->
 847     tcCheckSigma (L span user_nm_expr) sigma1   `thenM` \ expr ->
 848     returnM (std_nm, unLoc expr)
 849
 850 syntaxNameCtxt name orig ty tidy_env
 851   = getInstLoc orig             `thenM` \ inst_loc ->
 852     let
 853         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 854                                 ptext SLIT("(needed by a syntactic construct)"),
 855                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 856                     nest 2 (pprInstLoc inst_loc)]
 857     in
 858     returnM (tidy_env, msg)
 859 \end{code}