Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts, cloneDict,
- newMethod, newMethodFromName, newMethodWithGivenTy,
- newMethodWith, newMethodAtLoc,
+ newDictsFromOld, newDicts, cloneDict,
newOverloadedLit, newIPDict,
- tcInstCall, tcInstDataCon, tcSyntaxName,
+ newMethod, newMethodFromName, newMethodWithGivenTy,
+ tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
- lookupInst, lookupSimpleInst, LookupInstResult(..),
+ lookupInst, LookupInstResult(..),
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
zonkInst, zonkInsts,
instToId, instName,
- InstOrigin(..), InstLoc, pprInstLoc
+ InstOrigin(..), InstLoc(..), pprInstLoc
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcExpr )
+import {-# SOURCE #-} TcExpr( tcCheckSigma )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
-import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
- mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
+import TcHsSyn ( TcExpr, TcId, TcIdSet,
+ mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
+ mkCoercion, ExprCoFn
)
import TcRnMonad
-import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
+import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
- SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
+ SourceType(..), PredType, TyVarDetails(VanillaTv),
tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
- tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
+ tcSplitPhiTy, mkGenTyConApp,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
- isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
+ isClassPred, isTyVarClassPred, isLinearPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
- isInheritablePred, isIPPred,
+ isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
-import Class ( Class )
import DataCon ( DataCon,dataConSig )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred, pprParendType )
-import Subst ( emptyInScopeSet, mkSubst,
- substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
- )
+import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
import Literal ( inIntRange )
import Var ( TyVar )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
-import Util ( equalLength )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import Outputable
getDictClassTys (Dict _ pred _) = getClassPredTys pred
-- fdPredsOfInst is used to get predicates that contain functional
--- dependencies; i.e. should participate in improvement
-fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
- | otherwise = []
-fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
-fdPredsOfInst other = []
+-- dependencies *or* might do so. The "might do" part is because
+-- a constraint (C a b) might have a superclass with FDs
+-- 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
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
newDictsAtLoc :: InstLoc
-> TcThetaType
-> TcM [Inst]
-newDictsAtLoc inst_loc@(_,loc,_) theta
+newDictsAtLoc inst_loc theta
= newUniqueSupply `thenM` \ us ->
returnM (zipWith mk_dict (uniqsFromSupply us) theta)
where
- mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
+ mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
+ pred inst_loc
+ loc = instLocSrcLoc inst_loc
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
newIPDict :: InstOrigin -> IPName Name -> Type
-> TcM (IPName Id, Inst)
newIPDict orig ip_name ty
- = getInstLoc orig `thenM` \ inst_loc@(_,loc,_) ->
+ = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) ->
newUnique `thenM` \ uniq ->
let
pred = IParam ip_name ty
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
+tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
= tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
newDicts orig theta `thenM` \ dicts ->
let
inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
in
- returnM (inst_fn, tau)
+ returnM (mkCoercion inst_fn, tau)
tcInstDataCon :: InstOrigin -> DataCon
-> TcM ([TcType], -- Types to instantiate at
returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
-
newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
-- always a class op, but with -fno-implicit-prelude GHC is
-- meant to find whatever thing is in scope, and that may
-- be an ordinary function.
- newMethod origin id [ty]
-
-newMethod :: InstOrigin
- -> TcId
- -> [TcType]
- -> TcM Id
-newMethod orig id tys
- = -- Get the Id type and instantiate it at the specified types
- let
- (tyvars, rho) = tcSplitForAllTys (idType id)
- rho_ty = substTyWith tyvars tys rho
- (pred, tau) = tcSplitMethodTy rho_ty
- in
- newMethodWithGivenTy orig id tys [pred] tau
+ getInstLoc origin `thenM` \ loc ->
+ tcInstClassOp loc id [ty] `thenM` \ inst ->
+ extendLIE inst `thenM_`
+ returnM (instToId inst)
newMethodWithGivenTy orig id tys theta tau
= getInstLoc orig `thenM` \ loc ->
- newMethodWith loc id tys theta tau `thenM` \ inst ->
+ newMethod loc id tys theta tau `thenM` \ inst ->
extendLIE inst `thenM_`
returnM (instToId inst)
--------------------------------------------
--- newMethodWith and newMethodAtLoc do *not* drop the
+-- tcInstClassOp, and newMethod do *not* drop the
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
-newMethodWith inst_loc@(_,loc,_) id tys theta tau
+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
+ in
+ newMethod inst_loc sel_id tys preds tau
+
+---------------------------
+newMethod inst_loc id tys theta tau
= 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
in
returnM inst
-
-newMethodAtLoc :: InstLoc
- -> Id -> [TcType]
- -> TcM Inst
-newMethodAtLoc inst_loc real_id tys
- -- This actually builds the Inst
- = -- Get the Id type and instantiate it at the specified types
- let
- (tyvars,rho) = tcSplitForAllTys (idType real_id)
- rho_ty = ASSERT( equalLength tyvars tys )
- substTy (mkTopTyVarSubst tyvars tys) rho
- (theta, tau) = tcSplitPhiTy rho_ty
- in
- newMethodWith inst_loc real_id tys theta tau
\end{code}
In newOverloadedLit we convert directly to an Int or Integer if we
newLitInst orig lit expected_ty
= getInstLoc orig `thenM` \ loc ->
newUnique `thenM` \ new_uniq ->
- zapToType expected_ty `thenM_`
- -- The expected type might be a 'hole' type variable,
- -- in which case we must zap it to an ordinary type variable
let
lit_inst = LitInst lit_id lit expected_ty loc
lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
pprInstsInFull insts
= vcat (map go insts)
where
- go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
+ go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
pprInst (LitInst u lit ty loc)
= hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
tidyInsts :: [Inst] -> (TidyEnv, [Inst])
tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
-showLIE :: String -> TcM () -- Debugging
+showLIE :: SDoc -> TcM () -- Debugging
showLIE str
= do { lie_var <- getLIEVar ;
lie <- readMutVar lie_var ;
- traceTc (text str <+> pprInstsInFull (lieToList lie)) }
+ traceTc (str <+> pprInstsInFull (lieToList lie)) }
\end{code}
-- Dictionaries
-lookupInst dict@(Dict _ (ClassP clas tys) loc)
+lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
= getDOpts `thenM` \ dflags ->
tcGetInstEnv `thenM` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
+ getStage `thenM` \ use_stage ->
+ checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage `thenM_`
+ traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
mk_ty_arg tv = case lookupSubstEnv tenv tv of
| otherwise
= ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
tcLookupId fromIntegerName `thenM` \ from_integer ->
- newMethodAtLoc loc from_integer [ty] `thenM` \ method_inst ->
+ tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
returnM (GenInst [method_inst]
(HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
| otherwise
= ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
tcLookupId fromRationalName `thenM` \ from_rational ->
- newMethodAtLoc loc from_rational [ty] `thenM` \ method_inst ->
+ tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
mkRatLit f `thenM` \ rat_lit ->
returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
\end{code}
-There is a second, simpler interface, when you want an instance of a
-class at a given nullary type constructor. It just returns the
-appropriate dictionary if it exists. It is used only when resolving
-ambiguous dictionaries.
-
-\begin{code}
-lookupSimpleInst :: Class
- -> [Type] -- Look up (c,t)
- -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s
-
-lookupSimpleInst clas tys
- = getDOpts `thenM` \ dflags ->
- tcGetInstEnv `thenM` \ inst_env ->
- case lookupInstEnv dflags inst_env clas tys of
- FoundInst tenv dfun
- -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
- where
- (_, rho) = tcSplitForAllTys (idType dfun)
- (theta,_) = tcSplitPhiTy rho
-
- other -> returnM Nothing
-\end{code}
%************************************************************************
let
-- C.f. newMethodAtLoc
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
- tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau
+ tau1 = substTyWith [tv] [ty] tau
+ -- Actually, the "tau-type" might be a sigma-type in the
+ -- case of locally-polymorphic methods.
in
addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
- tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
+ tcCheckSigma (HsVar user_nm) tau1 `thenM` \ user_fn ->
returnM (user_fn, tau1)
syntaxNameCtxt name orig ty tidy_env
projects / ghc-hetmet.git / blobdiff