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