module Inst (
Inst,
- pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages
+ pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
tidyInsts, tidyMoreInsts,
newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
- tcOverloadedLit, newIPDict,
+ shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstCall, tcInstStupidTheta,
- tcSyntaxName,
+ tcInstClassOp, tcInstStupidTheta,
+ tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..), lookupPred,
- tcExtendLocalInstEnv, tcGetInstEnvs,
+ tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
- isTyVarDict, isStdClassTyVarDict, isMethodFor,
- instBindingRequired,
+ isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
instToId, instName,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckSigma, tcSyntaxOp )
-import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
+import {-# SOURCE #-} TcExpr( tcPolyExpr )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
nlHsLit, nlHsVar )
-import TcHsSyn ( TcId, TcIdSet,
- mkHsTyApp, mkHsDictApp, zonkId,
- mkCoercion, ExprCoFn
- )
+import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId )
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
-import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
-import TcIface ( loadImportedInsts )
+import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
+ lookupInstEnv, extendInstEnv, pprInstances,
+ instanceHead, instanceDFunId, setInstanceDFunId )
+import FunDeps ( checkFunDeps )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
- tcInstTyVar, tcInstType, tcSkolType
+ tcInstTyVar, tcInstSkolType
)
-import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
- PredType(..), SkolemInfo(..), Expected(..), typeKind, mkSigmaTy,
- tcSplitForAllTys, tcSplitForAllTys, mkFunTy,
- tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
+import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
+ BoxyRhoType,
+ PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
+ tcSplitForAllTys, applyTys,
+ tcSplitPhiTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
- tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
+ mkPredTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred,
- getClassPredTys, getClassPredTys_maybe, mkPredName,
+ getClassPredTys, mkPredName,
isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
- pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
+ pprPred, pprParendType, pprTheta
)
import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
notElemTvSubst, extendTvSubstList )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
-import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
- isInternalName, setNameUnique, mkSystemVarNameEncoded )
+ isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind, setIdType )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
-import DynFlags( DynFlags )
+import DynFlags ( DynFlag(..), dopt )
import Maybes ( isJust )
import Outputable
\end{code}
instName inst = idName (instToId inst)
instToId :: Inst -> TcId
-instToId (LitInst nm _ ty _) = mkLocalId nm ty
-instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
-instToId (Method id _ _ _ _ _) = id
+instToId (LitInst nm _ ty _) = mkLocalId nm ty
+instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
+instToId (Method id _ _ _ _) = id
-instLoc (Dict _ _ loc) = loc
-instLoc (Method _ _ _ _ _ loc) = loc
-instLoc (LitInst _ _ _ loc) = loc
+instLoc (Dict _ _ loc) = loc
+instLoc (Method _ _ _ _ loc) = loc
+instLoc (LitInst _ _ _ loc) = loc
dictPred (Dict _ pred _ ) = pred
dictPred inst = pprPanic "dictPred" (ppr inst)
-- Leaving these in is really important for the call to fdPredsOfInsts
-- in TcSimplify.inferLoop, because the result is fed to 'grow',
-- which is supposed to be conservative
-fdPredsOfInst (Dict _ pred _) = [pred]
-fdPredsOfInst (Method _ _ _ theta _ _) = theta
-fdPredsOfInst other = [] -- LitInsts etc
+fdPredsOfInst (Dict _ pred _) = [pred]
+fdPredsOfInst (Method _ _ _ theta _) = theta
+fdPredsOfInst other = [] -- LitInsts etc
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
-isInheritableInst (Dict _ pred _) = isInheritablePred pred
-isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
-isInheritableInst other = True
+isInheritableInst (Dict _ pred _) = isInheritablePred pred
+isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
+isInheritableInst other = True
ipNamesOfInsts :: [Inst] -> [Name]
-- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
-ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst other = []
+ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
+ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
-tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
-tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
-tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
+tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
+tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
isIPDict other = False
isMethod :: Inst -> Bool
-isMethod (Method _ _ _ _ _ _) = True
-isMethod other = False
+isMethod (Method {}) = True
+isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
-isMethodFor ids inst = False
+isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
+isMethodFor ids inst = False
isLinearInst :: Inst -> Bool
isLinearInst (Dict _ pred _) = isLinearPred pred
linearInstType :: Inst -> TcType -- %x::t --> t
linearInstType (Dict _ (IParam _ ty) _) = ty
-
-
-isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
- Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
- other -> False
\end{code}
-Two predicates which deal with the case where class constraints don't
-necessarily result in bindings. The first tells whether an @Inst@
-must be witnessed by an actual binding; the second tells whether an
-@Inst@ can be generalised over.
-
-\begin{code}
-instBindingRequired :: Inst -> Bool
-instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
-instBindingRequired other = True
-\end{code}
%************************************************************************
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
-tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
- = do { (tyvars, theta, tau) <- tcInstType fun_ty
- ; dicts <- newDicts orig theta
- ; extendLIEs dicts
- ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
- (map instToId dicts))
- ; return (mkCoercion inst_fn, tyvars, tau) }
-
tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
-- the constraints into the constraint set
stupid_theta = dataConStupidTheta data_con
tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
-newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
+newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
-- Use tcLookupId not tcLookupGlobalId; the method is almost
extendLIE inst `thenM_`
returnM (instToId inst)
-newMethodWithGivenTy orig id tys theta tau
- = getInstLoc orig `thenM` \ loc ->
- newMethod loc id tys theta tau `thenM` \ inst ->
- extendLIE inst `thenM_`
+newMethodWithGivenTy orig id tys
+ = getInstLoc orig `thenM` \ loc ->
+ newMethod loc id tys `thenM` \ inst ->
+ extendLIE inst `thenM_`
returnM (instToId inst)
--------------------------------------------
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
= let
- (tyvars,rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = ASSERT( length tyvars == length tys )
- substTyWith tyvars tys rho
- (preds,tau) = tcSplitPhiTy rho_ty
+ (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
in
zipWithM_ checkKind tyvars tys `thenM_`
- newMethod inst_loc sel_id tys preds tau
+ newMethod inst_loc sel_id tys
checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
- = do { ty1 <- zonkTcType ty
+ = do { let ty1 = ty
+ -- ty1 <- zonkTcType ty
; if typeKind ty1 `isSubKind` tyVarKind tv
then return ()
- else do
- { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
- ; tv1 <- tcInstTyVar tv
- ; unifyTauTy (mkTyVarTy tv1) ty1 }}
+ else
+
+ pprPanic "checkKind: adding kind constraint"
+ (vcat [ppr tv <+> ppr (tyVarKind tv),
+ ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
+ }
+-- do { tv1 <- tcInstTyVar tv
+-- ; unifyType ty1 (mkTyVarTy tv1) } }
---------------------------
-newMethod inst_loc id tys theta tau
+newMethod inst_loc id tys
= newUnique `thenM` \ new_uniq ->
let
- meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
- inst = Method meth_id id tys theta tau inst_loc
- loc = instLocSrcLoc inst_loc
+ (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
+ meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
+ inst = Method meth_id id tys theta inst_loc
+ loc = instLocSrcLoc inst_loc
in
returnM inst
\end{code}
-In tcOverloadedLit we convert directly to an Int or Integer if we
-know that's what we want. This may save some time, by not
-temporarily generating overloaded literals, but it won't catch all
-cases (the rest are caught in lookupInst).
-
\begin{code}
-tcOverloadedLit :: InstOrigin
- -> HsOverLit Name
- -> TcType
- -> TcM (HsOverLit TcId)
-tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
- | fi `isHsVar` fromIntegerName -- Do not generate a LitInst for rebindable syntax.
- -- Reason: If we do, tcSimplify will call lookupInst, which
- -- will call tcSyntaxName, which does unification,
- -- which tcSimplify doesn't like
- -- ToDo: noLoc sadness
- = do { integer_ty <- tcMetaTy integerTyConName
- ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
- ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
-
- | Just expr <- shortCutIntLit i expected_ty
- = return (HsIntegral i expr)
-
- | otherwise
- = do { expr <- newLitInst orig lit expected_ty
- ; return (HsIntegral i expr) }
-
-tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
- | fr `isHsVar` fromRationalName -- c.f. HsIntegral case
- = do { rat_ty <- tcMetaTy rationalTyConName
- ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
- ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
-
- | Just expr <- shortCutFracLit r expected_ty
- = return (HsFractional r expr)
-
- | otherwise
- = do { expr <- newLitInst orig lit expected_ty
- ; return (HsFractional r expr) }
-
-newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
-newLitInst orig lit expected_ty -- Make a LitInst
- = do { loc <- getInstLoc orig
- ; new_uniq <- newUnique
- ; let
- lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
- -- The "encoded" bit means that we don't need to
- -- z-encode the string every time we call this!
- lit_inst = LitInst lit_nm lit expected_ty loc
- ; extendLIE lit_inst
- ; return (HsVar (instToId lit_inst)) }
-
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
| isIntTy ty && inIntRange i -- Short cut for Int
= zonkTcPredType pred `thenM` \ new_pred ->
returnM (Dict name new_pred loc)
-zonkInst (Method m id tys theta tau loc)
+zonkInst (Method m id tys theta loc)
= zonkId id `thenM` \ new_id ->
-- Essential to zonk the id in case it's a local variable
-- Can't use zonkIdOcc because the id might itself be
zonkTcTypes tys `thenM` \ new_tys ->
zonkTcThetaType theta `thenM` \ new_theta ->
- zonkTcType tau `thenM` \ new_tau ->
- returnM (Method m new_id new_tys new_theta new_tau loc)
+ returnM (Method m new_id new_tys new_theta loc)
zonkInst (LitInst nm lit ty loc)
= zonkTcType ty `thenM` \ new_ty ->
pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
-pprInst m@(Method inst_id id tys theta tau loc)
+pprInst m@(Method inst_id id tys theta loc)
= ppr inst_id <+> dcolon <+>
braces (sep [ppr id <+> ptext SLIT("at"),
brackets (sep (map pprParendType tys))])
pprInstInFull inst
= sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
-pprDFuns :: [DFunId] -> SDoc
--- Prints the dfun as an instance declaration
-pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
- 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
- pprClassPred clas tys])
- | dfun <- dfuns
- , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
- -- Print without the for-all, which the programmer doesn't write
-
tidyInst :: TidyEnv -> Inst -> Inst
-tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
-tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
-tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
+tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
+tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
+tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
%************************************************************************
\begin{code}
-tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
+tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
-- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
- ; dflags <- getDOpts
- ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
+ ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
-addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
+addLocalInst :: InstEnv -> Instance -> TcM InstEnv
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
-addInst dflags home_ie dfun
+addLocalInst home_ie ispec
= do { -- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
- -- We use tcSkolType because we don't want to allocate fresh
+ -- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
- (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
+ let dfun = instanceDFunId ispec
+ ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
+ ispec' = setInstanceDFunId ispec dfun'
-- Load imported instances, so that we report
-- duplicates correctly
- ; pkg_ie <- loadImportedInsts cls tys'
+ ; eps <- getEps
+ ; let inst_envs = (eps_inst_env eps, home_ie)
-- Check functional dependencies
- ; case checkFunDeps (pkg_ie, home_ie) dfun' of
- Just dfuns -> funDepErr dfun dfuns
+ ; case checkFunDeps inst_envs ispec' of
+ Just specs -> funDepErr ispec' specs
Nothing -> return ()
-- Check for duplicate instance decls
- ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
- ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
- isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
- -- Find memebers of the match list which
- -- dfun itself matches. If the match is 2-way, it's a duplicate
- ; case dup_dfuns of
- dup_dfun : _ -> dupInstErr dfun dup_dfun
- [] -> return ()
+ ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
+ ; dup_ispecs = [ dup_ispec
+ | (_, dup_ispec) <- matches
+ , let (_,_,_,dup_tys) = instanceHead dup_ispec
+ , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
+ -- Find memebers of the match list which ispec itself matches.
+ -- If the match is 2-way, it's a duplicate
+ ; case dup_ispecs of
+ dup_ispec : _ -> dupInstErr ispec' dup_ispec
+ [] -> return ()
-- OK, now extend the envt
- ; return (extendInstEnv home_ie dfun') }
-
-
-traceDFuns dfuns
- = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
+ ; return (extendInstEnv home_ie ispec') }
+
+getOverlapFlag :: TcM OverlapFlag
+getOverlapFlag
+ = do { dflags <- getDOpts
+ ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
+ incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
+ overlap_flag | incoherent_ok = Incoherent
+ | overlap_ok = OverlapOk
+ | otherwise = NoOverlap
+
+ ; return overlap_flag }
+
+traceDFuns ispecs
+ = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
where
- pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+ pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
+ -- Print the dfun name itself too
-funDepErr dfun dfuns
- = addDictLoc dfun $
+funDepErr ispec ispecs
+ = addDictLoc ispec $
addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
- 2 (pprDFuns (dfun:dfuns)))
-dupInstErr dfun dup_dfun
- = addDictLoc dfun $
+ 2 (pprInstances (ispec:ispecs)))
+dupInstErr ispec dup_ispec
+ = addDictLoc ispec $
addErr (hang (ptext SLIT("Duplicate instance declarations:"))
- 2 (pprDFuns [dfun, dup_dfun]))
+ 2 (pprInstances [ispec, dup_ispec]))
-addDictLoc dfun thing_inside
+addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
- loc = getSrcLoc dfun
+ loc = getSrcLoc ispec
\end{code}
-- Methods
-lookupInst inst@(Method _ id tys theta _ loc)
+lookupInst inst@(Method _ id tys theta loc)
= newDictsAtLoc loc theta `thenM` \ dicts ->
returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
where
lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
- = do { pkg_ie <- loadImportedInsts clas tys
- -- Suck in any instance decls that may be relevant
+ = do { eps <- getEps
; tcg_env <- getGblEnv
- ; dflags <- getDOpts
- ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
- ([(tenv, (_,_,dfun_id))], [])
- -> do { traceTc (text "lookupInst success" <+>
+ ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
+ ; case lookupInstEnv inst_envs clas tys of {
+ ([(tenv, ispec)], [])
+ -> do { let dfun_id = is_dfun ispec
+ ; traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ])
lookupPred ip_pred = return Nothing
record_dfun_usage dfun_id
- = do { dflags <- getDOpts
+ = do { gbl <- getGblEnv
; let dfun_name = idName dfun_id
dfun_mod = nameModule dfun_name
- ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
+ ; if isInternalName dfun_name || -- Internal name => defined in this module
+ not (isHomeModule (tcg_home_mods gbl) dfun_mod)
then return () -- internal, or in another package
else do { tcg_env <- getGblEnv
; updMutVar (tcg_inst_uses tcg_env)
-- same type as the standard one.
-- Tiresome jiggling because tcCheckSigma takes a located expression
getSrcSpanM `thenM` \ span ->
- tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
+ tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
returnM (std_nm, unLoc expr)
syntaxNameCtxt name orig ty tidy_env
projects / ghc-hetmet.git / blobdiff