Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts,
- newMethod, newMethodWithGivenTy, newOverloadedLit,
- newIPDict, tcInstId,
+ newDictsFromOld, newDicts, cloneDict,
+ newMethod, newMethodWithGivenTy, newMethodAtLoc,
+ newOverloadedLit, newIPDict, tcInstId,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
lookupInst, lookupSimpleInst, LookupInstResult(..),
- isDict, isClassDict, isMethod,
+ isDict, isClassDict, isMethod, isLinearInst, linearInstType,
isTyVarDict, isStdClassTyVarDict, isMethodFor,
instBindingRequired, instCanBeGeneralised,
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType,
)
-import TcType ( Type,
+import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
SourceType(..), PredType, ThetaType,
tcSplitForAllTys, tcSplitForAllTys,
tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy,
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
-import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
+import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
-import NameSet ( NameSet )
import PprType ( pprPred )
import Subst ( emptyInScopeSet, mkSubst,
substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName )
import Util ( thenCmp, equalLength )
+import BasicTypes( IPName(..), mapIPName, ipNameName )
+
import Bag
import Outputable
\end{code}
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst :: Inst -> [Name]
-- Get the implicit parameters mentioned by these Insts
+-- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-ipNamesOfInst (Dict _ (IParam n _) _) = [n]
-ipNamesOfInst (Method _ _ _ theta _ _) = [n | IParam n _ <- theta]
+ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
isMethodFor ids inst = False
+isLinearInst :: Inst -> Bool
+isLinearInst (Dict _ pred _) = isLinearPred pred
+isLinearInst other = False
+ -- We never build Method Insts that have
+ -- linear implicit paramters in them.
+ -- Hence no need to look for Methods
+ -- See Inst.tcInstId
+
+isLinearPred :: TcPredType -> Bool
+isLinearPred (IParam (Linear n) _) = True
+isLinearPred other = False
+
+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
\begin{code}
instBindingRequired :: Inst -> Bool
instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
-instBindingRequired (Dict _ (IParam _ _) _) = False
instBindingRequired other = True
instCanBeGeneralised :: Inst -> Bool
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
newDictsAtLoc loc theta
+cloneDict :: Inst -> NF_TcM Inst
+cloneDict (Dict id ty loc) = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (Dict (setIdUnique id uniq) ty loc)
+
newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
where
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
--- For implicit parameters, since there is only one in scope
--- at any time, we use the name of the implicit parameter itself
-newIPDict orig name ty
- = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
- returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
- where pred = IParam name ty
+-- 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
+-- But with splittable implicit parameters there may be many in
+-- scope, so we make up a new name.
+newIPDict :: InstOrigin -> IPName Name -> Type
+ -> NF_TcM (IPName Id, Inst)
+newIPDict orig ip_name ty
+ = tcGetInstLoc orig `thenNF_Tc` \ inst_loc@(_,loc,_) ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ let
+ pred = IParam ip_name ty
+ id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
+ in
+ returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
\end{code}
\begin{code}
tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
tcInstId fun
- | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
- | otherwise = loop_share fun
+ = loop (HsVar fun) emptyLIE (idType fun)
where
orig = OccurrenceOf fun
- loop_noshare fun fun_ty
- = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
- let
- ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
- in
- if null theta then -- Is it overloaded?
- returnNF_Tc (ty_app, emptyLIE, tau)
- else
- newDicts orig theta `thenNF_Tc` \ dicts ->
- loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
- returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
-
- loop_share fun
- = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
- let
- arg_tys = mkTyVarTys tyvars
- in
- if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
- else
- -- Yes, it's overloaded
- newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
- loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
- returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
-
+ loop fun lie fun_ty = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
+ loop_help fun lie (mkTyVarTys tyvars) theta tau
+
+ loop_help fun lie arg_tys [] tau -- Not overloaded
+ = returnNF_Tc (mkHsTyApp fun arg_tys, lie, tau)
+
+ loop_help (HsVar fun_id) lie arg_tys theta tau
+ | can_share theta -- Sharable method binding
+ = newMethodWithGivenTy orig fun_id arg_tys theta tau `thenNF_Tc` \ meth ->
+ loop (HsVar (instToId meth))
+ (unitLIE meth `plusLIE` lie) tau
+
+ loop_help fun lie arg_tys theta tau -- The general case
+ = newDicts orig theta `thenNF_Tc` \ dicts ->
+ loop (mkHsDictApp (mkHsTyApp fun arg_tys) (map instToId dicts))
+ (mkLIE dicts `plusLIE` lie) tau
+
+ can_share theta | opt_NoMethodSharing = False
+ | otherwise = not (any isLinearPred theta)
+ -- This is a slight hack.
+ -- If f :: (%x :: T) => Int -> Int
+ -- Then if we have two separate calls, (f 3, f 4), we cannot
+ -- make a method constraint that then gets shared, thus:
+ -- let m = f %x in (m 3, m 4)
+ -- because that loses the linearity of the constraint.
+ -- The simplest thing to do is never to construct a method constraint
+ -- in the first place that has a linear implicit parameter in it.
newMethod :: InstOrigin
-> TcId
projects / ghc-hetmet.git / blobdiff