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