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