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         isLinearInst, linearInstType, 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                   ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
  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, isLinearPred,
  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
 193 isLinearInst :: Inst -> Bool
 194 isLinearInst (Dict _ pred _) = isLinearPred pred
 195 isLinearInst other           = False
 196         -- We never build Method Insts that have
 197         -- linear implicit paramters in them.
 198         -- Hence no need to look for Methods
 199         -- See TcExpr.tcId
 200
 201 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 202 linearInstType (Dict _ (IParam _ ty) _) = ty
 203 \end{code}
 204
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Building dictionaries}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 -- newDictBndrs makes a dictionary at a binding site
 214 -- instCall makes a dictionary at an occurrence site
 215 --      and throws it into the LIE
 216
 217 \begin{code}
 218 ----------------
 219 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
 220 newDictBndrsO orig theta = do { loc <- getInstLoc orig
 221                               ; newDictBndrs loc theta }
 222
 223 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
 224 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
 225
 226 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 227 newDictBndr inst_loc pred
 228   = do  { uniq <- newUnique
 229         ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
 230         ; return (Dict name pred inst_loc) }
 231
 232 ----------------
 233 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM ExprCoFn
 234 -- Instantiate the constraints of a call
 235 --      (instCall o tys theta)
 236 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 237 -- (b) Throws these dictionaries into the LIE
 238 -- (c) Eeturns an ExprCoFn ([.] tys dicts)
 239
 240 instCall orig tys theta
 241   = do  { loc <- getInstLoc orig
 242         ; (dicts, dict_app) <- instCallDicts loc theta
 243         ; extendLIEs dicts
 244         ; return (dict_app <.> mkCoTyApps tys) }
 245
 246 ----------------
 247 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
 248 -- Similar to instCall, but only emit the constraints in the LIE
 249 -- Used exclusively for the 'stupid theta' of a data constructor
 250 instStupidTheta orig theta
 251   = do  { loc <- getInstLoc orig
 252         ; (dicts, _) <- instCallDicts loc theta
 253         ; extendLIEs dicts }
 254
 255 ----------------
 256 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], ExprCoFn)
 257 -- This is the key place where equality predicates
 258 -- are unleashed into the world
 259 instCallDicts loc [] = return ([], idCoercion)
 260
 261 instCallDicts loc (EqPred ty1 ty2 : preds)
 262   = do  { unifyType ty1 ty2     -- For now, we insist that they unify right away
 263                                 -- Later on, when we do associated types,
 264                                 -- unifyType might return a coercion
 265         ; (dicts, co_fn) <- instCallDicts loc preds
 266         ; return (dicts, co_fn <.> CoTyApp ty1) }
 267         -- We use type application to apply the function to the
 268         -- coercion; here ty1 *is* the appropriate identity coercion
 269
 270 instCallDicts loc (pred : preds)
 271   = do  { uniq <- newUnique
 272         ; let name = mkPredName uniq (instLocSrcLoc loc) pred
 273               dict = Dict name pred loc
 274         ; (dicts, co_fn) <- instCallDicts loc preds
 275         ; return (dict:dicts, co_fn <.> CoApp (instToId dict)) }
 276
 277 -------------
 278 cloneDict :: Inst -> TcM Inst   -- Only used for linear implicit params
 279 cloneDict (Dict nm ty loc) = newUnique  `thenM` \ uniq ->
 280                              returnM (Dict (setNameUnique nm uniq) ty loc)
 281
 282 -- For vanilla implicit parameters, there is only one in scope
 283 -- at any time, so we used to use the name of the implicit parameter itself
 284 -- But with splittable implicit parameters there may be many in
 285 -- scope, so we make up a new namea.
 286 newIPDict :: InstOrigin -> IPName Name -> Type
 287           -> TcM (IPName Id, Inst)
 288 newIPDict orig ip_name ty
 289   = getInstLoc orig                     `thenM` \ inst_loc ->
 290     newUnique                           `thenM` \ uniq ->
 291     let
 292         pred = IParam ip_name ty
 293         name = mkPredName uniq (instLocSrcLoc inst_loc) pred
 294         dict = Dict name pred inst_loc
 295     in
 296     returnM (mapIPName (\n -> instToId dict) ip_name, dict)
 297 \end{code}
 298
 299
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection{Building methods (calls of overloaded functions)}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307
 308 \begin{code}
 309 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
 310 newMethodFromName origin ty name
 311   = tcLookupId name             `thenM` \ id ->
 312         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 313         -- always a class op, but with -fno-implicit-prelude GHC is
 314         -- meant to find whatever thing is in scope, and that may
 315         -- be an ordinary function.
 316     getInstLoc origin           `thenM` \ loc ->
 317     tcInstClassOp loc id [ty]   `thenM` \ inst ->
 318     extendLIE inst              `thenM_`
 319     returnM (instToId inst)
 320
 321 newMethodWithGivenTy orig id tys
 322   = getInstLoc orig             `thenM` \ loc ->
 323     newMethod loc id tys        `thenM` \ inst ->
 324     extendLIE inst              `thenM_`
 325     returnM (instToId inst)
 326
 327 --------------------------------------------
 328 -- tcInstClassOp, and newMethod do *not* drop the
 329 -- Inst into the LIE; they just returns the Inst
 330 -- This is important because they are used by TcSimplify
 331 -- to simplify Insts
 332
 333 -- NB: the kind of the type variable to be instantiated
 334 --     might be a sub-kind of the type to which it is applied,
 335 --     notably when the latter is a type variable of kind ??
 336 --     Hence the call to checkKind
 337 -- A worry: is this needed anywhere else?
 338 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 339 tcInstClassOp inst_loc sel_id tys
 340   = let
 341         (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
 342     in
 343     zipWithM_ checkKind tyvars tys      `thenM_`
 344     newMethod inst_loc sel_id tys
 345
 346 checkKind :: TyVar -> TcType -> TcM ()
 347 -- Ensure that the type has a sub-kind of the tyvar
 348 checkKind tv ty
 349   = do  { let ty1 = ty
 350                 -- ty1 <- zonkTcType ty
 351         ; if typeKind ty1 `isSubKind` tyVarKind tv
 352           then return ()
 353           else
 354
 355     pprPanic "checkKind: adding kind constraint"
 356              (vcat [ppr tv <+> ppr (tyVarKind tv),
 357                     ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
 358         }
 359 --    do        { tv1 <- tcInstTyVar tv
 360 --      ; unifyType ty1 (mkTyVarTy tv1) } }
 361
 362
 363 ---------------------------
 364 newMethod inst_loc id tys
 365   = newUnique           `thenM` \ new_uniq ->
 366     let
 367         (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
 368         meth_id     = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 369         inst        = Method meth_id id tys theta inst_loc
 370         loc         = instLocSrcLoc inst_loc
 371     in
 372     returnM inst
 373 \end{code}
 374
 375 \begin{code}
 376 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
 377 shortCutIntLit i ty
 378   | isIntTy ty && inIntRange i          -- Short cut for Int
 379   = Just (HsLit (HsInt i))
 380   | isIntegerTy ty                      -- Short cut for Integer
 381   = Just (HsLit (HsInteger i ty))
 382   | otherwise = Nothing
 383
 384 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
 385 shortCutFracLit f ty
 386   | isFloatTy ty
 387   = Just (mk_lit floatDataCon (HsFloatPrim f))
 388   | isDoubleTy ty
 389   = Just (mk_lit doubleDataCon (HsDoublePrim f))
 390   | otherwise = Nothing
 391   where
 392     mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 393
 394 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 395 mkIntegerLit i
 396   = tcMetaTy integerTyConName   `thenM` \ integer_ty ->
 397     getSrcSpanM                 `thenM` \ span ->
 398     returnM (L span $ HsLit (HsInteger i integer_ty))
 399
 400 mkRatLit :: Rational -> TcM (LHsExpr TcId)
 401 mkRatLit r
 402   = tcMetaTy rationalTyConName  `thenM` \ rat_ty ->
 403     getSrcSpanM                 `thenM` \ span ->
 404     returnM (L span $ HsLit (HsRat r rat_ty))
 405
 406 isHsVar :: HsExpr Name -> Name -> Bool
 407 isHsVar (HsVar f) g = f==g
 408 isHsVar other     g = False
 409 \end{code}
 410
 411
 412 %************************************************************************
 413 %*                                                                      *
 414 \subsection{Zonking}
 415 %*                                                                      *
 416 %************************************************************************
 417
 418 Zonking makes sure that the instance types are fully zonked.
 419
 420 \begin{code}
 421 zonkInst :: Inst -> TcM Inst
 422 zonkInst (Dict name pred loc)
 423   = zonkTcPredType pred                 `thenM` \ new_pred ->
 424     returnM (Dict name new_pred loc)
 425
 426 zonkInst (Method m id tys theta loc)
 427   = zonkId id                   `thenM` \ new_id ->
 428         -- Essential to zonk the id in case it's a local variable
 429         -- Can't use zonkIdOcc because the id might itself be
 430         -- an InstId, in which case it won't be in scope
 431
 432     zonkTcTypes tys             `thenM` \ new_tys ->
 433     zonkTcThetaType theta       `thenM` \ new_theta ->
 434     returnM (Method m new_id new_tys new_theta loc)
 435
 436 zonkInst (LitInst nm lit ty loc)
 437   = zonkTcType ty                       `thenM` \ new_ty ->
 438     returnM (LitInst nm lit new_ty loc)
 439
 440 zonkInsts insts = mappM zonkInst insts
 441 \end{code}
 442
 443
 444 %************************************************************************
 445 %*                                                                      *
 446 \subsection{Printing}
 447 %*                                                                      *
 448 %************************************************************************
 449
 450 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 451 relevant in error messages.
 452
 453 \begin{code}
 454 instance Outputable Inst where
 455     ppr inst = pprInst inst
 456
 457 pprDictsTheta :: [Inst] -> SDoc
 458 -- Print in type-like fashion (Eq a, Show b)
 459 pprDictsTheta dicts = pprTheta (map dictPred dicts)
 460
 461 pprDictsInFull :: [Inst] -> SDoc
 462 -- Print in type-like fashion, but with source location
 463 pprDictsInFull dicts
 464   = vcat (map go dicts)
 465   where
 466     go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
 467
 468 pprInsts :: [Inst] -> SDoc
 469 -- Debugging: print the evidence :: type
 470 pprInsts insts  = brackets (interpp'SP insts)
 471
 472 pprInst, pprInstInFull :: Inst -> SDoc
 473 -- Debugging: print the evidence :: type
 474 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
 475 pprInst (Dict nm pred loc)      = ppr nm <+> dcolon <+> pprPred pred
 476
 477 pprInst m@(Method inst_id id tys theta loc)
 478   = ppr inst_id <+> dcolon <+>
 479         braces (sep [ppr id <+> ptext SLIT("at"),
 480                      brackets (sep (map pprParendType tys))])
 481
 482 pprInstInFull inst
 483   = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
 484
 485 tidyInst :: TidyEnv -> Inst -> Inst
 486 tidyInst env (LitInst nm lit ty loc)     = LitInst nm lit (tidyType env ty) loc
 487 tidyInst env (Dict nm pred loc)          = Dict nm (tidyPred env pred) loc
 488 tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
 489
 490 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 491 -- This function doesn't assume that the tyvars are in scope
 492 -- so it works like tidyOpenType, returning a TidyEnv
 493 tidyMoreInsts env insts
 494   = (env', map (tidyInst env') insts)
 495   where
 496     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 497
 498 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 499 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 500
 501 showLIE :: SDoc -> TcM ()       -- Debugging
 502 showLIE str
 503   = do { lie_var <- getLIEVar ;
 504          lie <- readMutVar lie_var ;
 505          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 506 \end{code}
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511         Extending the instance environment
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 \begin{code}
 516 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
 517   -- Add new locally-defined instances
 518 tcExtendLocalInstEnv dfuns thing_inside
 519  = do { traceDFuns dfuns
 520       ; env <- getGblEnv
 521       ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
 522       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 523                          tcg_inst_env = inst_env' }
 524       ; setGblEnv env' thing_inside }
 525
 526 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
 527 -- Check that the proposed new instance is OK,
 528 -- and then add it to the home inst env
 529 addLocalInst home_ie ispec
 530   = do  {       -- Instantiate the dfun type so that we extend the instance
 531                 -- envt with completely fresh template variables
 532                 -- This is important because the template variables must
 533                 -- not overlap with anything in the things being looked up
 534                 -- (since we do unification).
 535                 -- We use tcInstSkolType because we don't want to allocate fresh
 536                 --  *meta* type variables.
 537           let dfun = instanceDFunId ispec
 538         ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
 539         ; let   (cls, tys') = tcSplitDFunHead tau'
 540                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 541                 ispec'      = setInstanceDFunId ispec dfun'
 542
 543                 -- Load imported instances, so that we report
 544                 -- duplicates correctly
 545         ; eps <- getEps
 546         ; let inst_envs = (eps_inst_env eps, home_ie)
 547
 548                 -- Check functional dependencies
 549         ; case checkFunDeps inst_envs ispec' of
 550                 Just specs -> funDepErr ispec' specs
 551                 Nothing    -> return ()
 552
 553                 -- Check for duplicate instance decls
 554         ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
 555               ; dup_ispecs = [ dup_ispec
 556                              | (_, dup_ispec) <- matches
 557                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
 558                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 559                 -- Find memebers of the match list which ispec itself matches.
 560                 -- If the match is 2-way, it's a duplicate
 561         ; case dup_ispecs of
 562             dup_ispec : _ -> dupInstErr ispec' dup_ispec
 563             []            -> return ()
 564
 565                 -- OK, now extend the envt
 566         ; return (extendInstEnv home_ie ispec') }
 567
 568 getOverlapFlag :: TcM OverlapFlag
 569 getOverlapFlag
 570   = do  { dflags <- getDOpts
 571         ; let overlap_ok    = dopt Opt_AllowOverlappingInstances dflags
 572               incoherent_ok = dopt Opt_AllowIncoherentInstances  dflags
 573               overlap_flag | incoherent_ok = Incoherent
 574                            | overlap_ok    = OverlapOk
 575                            | otherwise     = NoOverlap
 576
 577         ; return overlap_flag }
 578
 579 traceDFuns ispecs
 580   = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
 581   where
 582     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 583         -- Print the dfun name itself too
 584
 585 funDepErr ispec ispecs
 586   = addDictLoc ispec $
 587     addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
 588                2 (pprInstances (ispec:ispecs)))
 589 dupInstErr ispec dup_ispec
 590   = addDictLoc ispec $
 591     addErr (hang (ptext SLIT("Duplicate instance declarations:"))
 592                2 (pprInstances [ispec, dup_ispec]))
 593
 594 addDictLoc ispec thing_inside
 595   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 596   where
 597    loc = getSrcLoc ispec
 598 \end{code}
 599
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsection{Looking up Insts}
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 \begin{code}
 608 data LookupInstResult
 609   = NoInstance
 610   | SimpleInst (LHsExpr TcId)           -- Just a variable, type application, or literal
 611   | GenInst    [Inst] (LHsExpr TcId)    -- The expression and its needed insts
 612
 613 lookupInst :: Inst -> TcM LookupInstResult
 614 -- It's important that lookupInst does not put any new stuff into
 615 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 616 -- the LookupInstResult, where they can be further processed by tcSimplify
 617
 618
 619 -- Methods
 620
 621 lookupInst inst@(Method _ id tys theta loc)
 622   = do  { (dicts, dict_app) <- instCallDicts loc theta
 623         ; let co_fn = dict_app <.> mkCoTyApps tys
 624         ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
 625   where
 626     span = instLocSrcSpan loc
 627
 628 -- Literals
 629
 630 -- Look for short cuts first: if the literal is *definitely* a
 631 -- int, integer, float or a double, generate the real thing here.
 632 -- This is essential (see nofib/spectral/nucleic).
 633 -- [Same shortcut as in newOverloadedLit, but we
 634 --  may have done some unification by now]
 635
 636 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
 637   | Just expr <- shortCutIntLit i ty
 638   = returnM (GenInst [] (noLoc expr))   -- GenInst, not SimpleInst, because
 639                                         -- expr may be a constructor application
 640   | otherwise
 641   = ASSERT( from_integer_name `isHsVar` fromIntegerName )       -- A LitInst invariant
 642     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
 643     tcInstClassOp loc from_integer [ty]         `thenM` \ method_inst ->
 644     mkIntegerLit i                              `thenM` \ integer_lit ->
 645     returnM (GenInst [method_inst]
 646                      (mkHsApp (L (instLocSrcSpan loc)
 647                                  (HsVar (instToId method_inst))) integer_lit))
 648
 649 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
 650   | Just expr <- shortCutFracLit f ty
 651   = returnM (GenInst [] (noLoc expr))
 652
 653   | otherwise
 654   = ASSERT( from_rat_name `isHsVar` fromRationalName )  -- A LitInst invariant
 655     tcLookupId fromRationalName                 `thenM` \ from_rational ->
 656     tcInstClassOp loc from_rational [ty]        `thenM` \ method_inst ->
 657     mkRatLit f                                  `thenM` \ rat_lit ->
 658     returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
 659                                                (HsVar (instToId method_inst))) rat_lit))
 660
 661 -- Dictionaries
 662 lookupInst (Dict _ pred loc)
 663   = do  { mb_result <- lookupPred pred
 664         ; case mb_result of {
 665             Nothing -> return NoInstance ;
 666             Just (tenv, dfun_id) -> do
 667
 668     -- tenv is a substitution that instantiates the dfun_id
 669     -- to match the requested result type.
 670     --
 671     -- We ASSUME that the dfun is quantified over the very same tyvars
 672     -- that are bound by the tenv.
 673     --
 674     -- However, the dfun
 675     -- might have some tyvars that *only* appear in arguments
 676     --  dfun :: forall a b. C a b, Ord b => D [a]
 677     -- We instantiate b to a flexi type variable -- it'll presumably
 678     -- become fixed later via functional dependencies
 679     { use_stage <- getStage
 680     ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
 681                       (topIdLvl dfun_id) use_stage
 682
 683         -- It's possible that not all the tyvars are in
 684         -- the substitution, tenv. For example:
 685         --      instance C X a => D X where ...
 686         -- (presumably there's a functional dependency in class C)
 687         -- Hence the open_tvs to instantiate any un-substituted tyvars.
 688     ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 689           open_tvs      = filter (`notElemTvSubst` tenv) tyvars
 690     ; open_tvs' <- mappM tcInstTyVar open_tvs
 691     ; let
 692         tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
 693                 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
 694                 -- any nested for-alls in rho.  So the in-scope set is unchanged
 695         dfun_rho   = substTy tenv' rho
 696         (theta, _) = tcSplitPhiTy dfun_rho
 697         src_loc    = instLocSrcSpan loc
 698         dfun       = HsVar dfun_id
 699         tys        = map (substTyVar tenv') tyvars
 700     ; if null theta then
 701         returnM (SimpleInst (L src_loc $ HsCoerce (mkCoTyApps tys) dfun))
 702       else do
 703     { (dicts, dict_app) <- instCallDicts loc theta
 704     ; let co_fn = dict_app <.> mkCoTyApps tys
 705     ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
 706     }}}}
 707
 708 ---------------
 709 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
 710 -- Look up a class constraint in the instance environment
 711 lookupPred pred@(ClassP clas tys)
 712   = do  { eps     <- getEps
 713         ; tcg_env <- getGblEnv
 714         ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
 715         ; case lookupInstEnv inst_envs clas tys of {
 716             ([(tenv, ispec)], [])
 717                 -> do   { let dfun_id = is_dfun ispec
 718                         ; traceTc (text "lookupInst success" <+>
 719                                    vcat [text "dict" <+> ppr pred,
 720                                          text "witness" <+> ppr dfun_id
 721                                          <+> ppr (idType dfun_id) ])
 722                                 -- Record that this dfun is needed
 723                         ; record_dfun_usage dfun_id
 724                         ; return (Just (tenv, dfun_id)) } ;
 725
 726             (matches, unifs)
 727                 -> do   { traceTc (text "lookupInst fail" <+>
 728                                    vcat [text "dict" <+> ppr pred,
 729                                          text "matches" <+> ppr matches,
 730                                          text "unifs" <+> ppr unifs])
 731                 -- In the case of overlap (multiple matches) we report
 732                 -- NoInstance here.  That has the effect of making the
 733                 -- context-simplifier return the dict as an irreducible one.
 734                 -- Then it'll be given to addNoInstanceErrs, which will do another
 735                 -- lookupInstEnv to get the detailed info about what went wrong.
 736                         ; return Nothing }
 737         }}
 738
 739 lookupPred ip_pred = return Nothing
 740
 741 record_dfun_usage dfun_id
 742   = do  { hsc_env <- getTopEnv
 743         ; let  dfun_name = idName dfun_id
 744                dfun_mod  = nameModule dfun_name
 745         ; if isInternalName dfun_name ||    -- Internal name => defined in this module
 746              modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 747           then return () -- internal, or in another package
 748            else do { tcg_env <- getGblEnv
 749                    ; updMutVar (tcg_inst_uses tcg_env)
 750                                (`addOneToNameSet` idName dfun_id) }}
 751
 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 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 769 a do-expression.  We have to find (>>) in the current environment, which is
 770 done by the rename. Then we have to check that it has the same type as
 771 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 772 this:
 773
 774   (>>) :: HB m n mn => m a -> n b -> mn b
 775
 776 So the idea is to generate a local binding for (>>), thus:
 777
 778         let then72 :: forall a b. m a -> m b -> m b
 779             then72 = ...something involving the user's (>>)...
 780         in
 781         ...the do-expression...
 782
 783 Now the do-expression can proceed using then72, which has exactly
 784 the expected type.
 785
 786 In fact tcSyntaxName just generates the RHS for then72, because we only
 787 want an actual binding in the do-expression case. For literals, we can
 788 just use the expression inline.
 789
 790 \begin{code}
 791 tcSyntaxName :: InstOrigin
 792              -> TcType                  -- Type to instantiate it at
 793              -> (Name, HsExpr Name)     -- (Standard name, user name)
 794              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 795 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 796 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 797 -- So we do not call it from lookupInst, which is called from tcSimplify
 798
 799 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 800   | std_nm == user_nm
 801   = newMethodFromName orig ty std_nm    `thenM` \ id ->
 802     returnM (std_nm, HsVar id)
 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     tcPolyExpr (L span user_nm_expr) sigma1     `thenM` \ expr ->
 820     returnM (std_nm, unLoc expr)
 821
 822 syntaxNameCtxt name orig ty tidy_env
 823   = getInstLoc orig             `thenM` \ inst_loc ->
 824     let
 825         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
 826                                 ptext SLIT("(needed by a syntactic construct)"),
 827                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
 828                     nest 2 (pprInstLoc inst_loc)]
 829     in
 830     returnM (tidy_env, msg)
 831 \end{code}