mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcMonad
-import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
- tcLookupValue, tcLookupGlobalValue
- )
+import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
+import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
zonkTcTyVars, zonkTcType, zonkTcTypes,
zonkTcThetaType
)
-import Bag
+import CoreFVs ( idFreeTyVars )
import Class ( Class, FunDep )
import FunDeps ( instantiateFdClassTys )
-import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
+import Id ( Id, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
import PprType ( pprPred )
import Type ( Type, PredType(..),
isTyVarTy, mkDictTy, mkPredTy,
splitForAllTys, splitSigmaTy, funArgTy,
- splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ splitMethodTy, splitRhoTy, classesOfPreds,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tidyOpenType, tidyOpenTypes
)
import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet,
doubleDataCon, isDoubleTy,
isIntegerTy, voidTy
)
-import PrelNames( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
+import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
+import Bag
import Outputable
\end{code}
let
(tyvars, rho) = splitForAllTys (idType id)
rho_ty = substTy (mkTyVarSubst tyvars tys) rho
- (theta, tau) = splitRhoTy rho_ty
+ (pred, tau) = splitMethodTy rho_ty
in
- newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
+ newMethodWithGivenTy orig id tys [pred] tau `thenNF_Tc` \ meth_inst ->
returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
instOverloadedFun orig v arg_tys theta tau
pprInst m@(Method u id tys theta tau loc)
= hsep [ppr id, ptext SLIT("at"),
brackets (interppSP tys) {- ,
- ppr theta, ppr tau,
+ ptext SLIT("theta"), ppr theta,
+ ptext SLIT("tau"), ppr tau
show_uniq u,
ppr (instToId m) -}]
-- (i.e. no funny business with user-defined
-- packages of numeric classes)
= -- So we can use the Prelude fromInt
- tcLookupGlobalId fromIntClassOpName `thenNF_Tc` \ from_int ->
+ tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int ->
newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
| isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
| otherwise
- = tcLookupGlobalValue from_rat_name `thenNF_Tc` \ from_rational ->
+ = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational ->
newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
let
rational_ty = funArgTy (idType method_id)
-> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
where
(_, theta, _) = splitSigmaTy (idType dfun)
- theta' = map (\(Class clas tys) -> (clas,tys)) theta
+ theta' = classesOfPreds theta
other -> returnNF_Tc Nothing
\end{code}