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