plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
Inst,
- pprInst, pprInsts, pprInstsInFull, tidyInsts,
+ pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts,
- newMethod, newMethodWithGivenTy, newOverloadedLit,
- newIPDict, tcInstId,
+ newDictsFromOld, newDicts, cloneDict,
+ newMethod, newMethodWithGivenTy, newMethodAtLoc,
+ newOverloadedLit, newIPDict, tcInstId,
- tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
- getIPs,
- predsOfInsts, predsOfInst,
+ tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
+ ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
+ instLoc, getDictClassTys,
lookupInst, lookupSimpleInst, LookupInstResult(..),
- isDict, isClassDict, isMethod, instMentionsIPs,
+ 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,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
- predMentionsIPs, isClassPred, isTyVarClassPred,
+ isClassPred, isTyVarClassPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
tidyType, tidyTypes, tidyFreeTyVars,
tcCmpType, tcCmpTypes, tcCmpPred
)
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, substTheta, mkTyVarSubst, mkTopTyVarSubst
+ substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
)
import Literal ( inIntRange )
import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName )
-import Util ( thenCmp )
+import Util ( thenCmp, equalLength )
+import BasicTypes( IPName(..), mapIPName, ipNameName )
+
import Bag
import Outputable
\end{code}
zonkLIE lie = mapBagNF_Tc zonkInst lie
pprInsts :: [Inst] -> SDoc
-pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
+pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
pprInstsInFull insts
-- But Num and Fractional have only one parameter and no functional
-- dependencies, so I think no caller of predsOfInst will care.
-ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
+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]
-getIPs inst = ipsOfPreds (predsOfInst inst)
+ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
+ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
isMethodFor ids inst = False
-instMentionsIPs :: Inst -> NameSet -> Bool
- -- True if the Inst mentions any of the implicit
- -- parameters in the supplied set of names
-instMentionsIPs (Dict _ pred _) ip_names = pred `predMentionsIPs` ip_names
-instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
-instMentionsIPs other ip_names = 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
\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
= -- Get the Id type and instantiate it at the specified types
let
(tyvars, rho) = tcSplitForAllTys (idType id)
- rho_ty = substTy (mkTyVarSubst tyvars tys) rho
+ rho_ty = substTyWith tyvars tys rho
(pred, tau) = tcSplitMethodTy rho_ty
in
newMethodWithGivenTy orig id tys [pred] tau
= -- Get the Id type and instantiate it at the specified types
let
(tyvars,rho) = tcSplitForAllTys (idType real_id)
- rho_ty = ASSERT( length tyvars == length tys )
+ rho_ty = ASSERT( equalLength tyvars tys )
substTy (mkTopTyVarSubst tyvars tys) rho
(theta, tau) = tcSplitRhoTy rho_ty
in
tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
-tidyInsts :: [Inst] -> (TidyEnv, [Inst])
+tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
-tidyInsts insts
- = (env, map (tidyInst env) insts)
+tidyMoreInsts env insts
+ = (env', map (tidyInst env') insts)
where
- env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
+ env' = tidyFreeTyVars env (tyVarsOfInsts insts)
+
+tidyInsts :: [Inst] -> (TidyEnv, [Inst])
+tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
\end{code}
other -> returnNF_Tc Nothing
\end{code}
-
-