diff options
| -rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 16 | ||||
| -rw-r--r-- | compiler/iface/BuildTyCl.lhs | 6 | ||||
| -rw-r--r-- | compiler/simplCore/SetLevels.lhs | 4 | ||||
| -rw-r--r-- | compiler/specialise/Specialise.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 1 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 1 | ||||
| -rw-r--r-- | compiler/typecheck/TcUnify.lhs | 1 | ||||
| -rw-r--r-- | compiler/types/Type.lhs | 25 |
8 files changed, 26 insertions, 30 deletions
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 27026b2353..851486b887 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -12,7 +12,7 @@ module CoreUtils ( mkCast, mkTick, mkTickNoHNF, bindNonRec, needsCaseBinding, - mkAltExpr, mkPiType, mkPiTypes, + mkAltExpr, -- * Taking expressions apart findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, @@ -138,20 +138,6 @@ Various possibilities suggest themselves: we are doing here. It's not too expensive, I think. \begin{code} -mkPiType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or a forall type, depending --- on whether it is given a type variable or a term variable. -mkPiTypes :: [Var] -> Type -> Type --- ^ 'mkPiType' for multiple type or value arguments - -mkPiType v ty - | isId v = mkFunTy (idType v) ty - | otherwise = mkForAllTy v ty - -mkPiTypes vs ty = foldr mkPiType ty vs -\end{code} - -\begin{code} applyTypeToArg :: Type -> CoreExpr -> Type -- ^ Determines the type resulting from applying an expression to a function with the given type applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 9d4a825586..612b098c2f 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -62,7 +62,7 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family | otherwise = return (mkSynTyCon tc_name kind tvs rhs parent) - where kind = mkForAllArrowKinds tvs rhs_kind + where kind = mkPiKinds tvs rhs_kind ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables adn type variables @@ -88,7 +88,7 @@ buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn | otherwise = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn) - where kind = mkForAllArrowKinds ktvs liftedTypeKind + where kind = mkPiKinds ktvs liftedTypeKind -- | If a family tycon with instance types is given, the current tycon is an -- instance of that family and we need to @@ -307,7 +307,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec then mkNewTyConRhs tycon_name rec_tycon dict_con else return (mkDataTyConRhs [dict_con]) - ; let { clas_kind = mkForAllArrowKinds tvs constraintKind + ; let { clas_kind = mkPiKinds tvs constraintKind ; tycon = mkClassTyCon tycon_name clas_kind tvs rhs rec_clas tc_isrec diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 7e3b44c7d5..a80dea4603 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -63,7 +63,7 @@ module SetLevels ( import CoreSyn import CoreMonad ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, exprOkForSpeculation, mkPiTypes ) +import CoreUtils ( exprType, exprOkForSpeculation ) import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it import Coercion ( isCoVar ) @@ -78,7 +78,7 @@ import Literal ( litIsTrivial ) import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( isUnLiftedType, Type, sortQuantVars ) +import Type ( isUnLiftedType, Type, sortQuantVars, mkPiTypes ) import Kind ( kiVarsOfKinds ) import BasicTypes ( Arity ) import UniqSupply diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 77ab8db886..a452593a3e 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -25,7 +25,7 @@ import VarSet import VarEnv import CoreSyn import Rules -import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkPiTypes ) +import CoreUtils ( exprIsTrivial, applyTypeToArgs ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) import UniqSupply ( UniqSM, initUs_, MonadUnique(..) ) import Name diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 837f3823ba..dbed0d3bfc 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -44,7 +44,6 @@ import Var import VarEnv import VarSet ( mkVarSet, varSetElems ) import Pair -import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) import PrelNames ( typeableClassNames ) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 11fb17f9e9..e789411b96 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -89,7 +89,6 @@ import Data.IORef ( readIORef ) #ifdef GHCI import TcType ( isUnitTy, isTauTy ) -import CoreUtils( mkPiTypes ) import TcHsType import TcMatches import RnTypes diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 67bafaca36..7fbcc5c1cd 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -43,7 +43,6 @@ module TcUnify ( import HsSyn import TypeRep -import CoreUtils( mkPiTypes ) import TcErrors ( unifyCtxt ) import TcMType import TcIface diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index cb253d82fc..a29e9415d7 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -39,7 +39,7 @@ module Type ( splitTyConApp_maybe, splitTyConApp, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - mkForAllArrowKinds, + mkPiKinds, mkPiType, mkPiTypes, applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, -- (Newtypes) @@ -675,12 +675,25 @@ mkForAllTy tyvar ty mkForAllTys :: [TyVar] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -mkForAllArrowKinds :: [TyVar] -> Kind -> Kind --- mkForAllArrowKinds [k1, k2, (a:k1 -> *)] k2 +mkPiKinds :: [TyVar] -> Kind -> Kind +-- mkPiKinds [k1, k2, (a:k1 -> *)] k2 -- returns forall k1 k2. (k1 -> *) -> k2 -mkForAllArrowKinds ktvs res = - mkForAllTys kvs $ mkArrowKinds (map tyVarKind tvs) res - where (kvs, tvs) = splitKiTyVars ktvs +mkPiKinds [] res = res +mkPiKinds (tv:tvs) res + | isKiVar tv = ForAllTy tv (mkPiKinds tvs res) + | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) + +mkPiType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or a forall type, depending +-- on whether it is given a type variable or a term variable. +mkPiTypes :: [Var] -> Type -> Type +-- ^ 'mkPiType' for multiple type or value arguments + +mkPiType v ty + | isId v = mkFunTy (varType v) ty + | otherwise = mkForAllTy v ty + +mkPiTypes vs ty = foldr mkPiType ty vs isForAllTy :: Type -> Bool isForAllTy (ForAllTy _ _) = True |