Move mkPiTypes back to Type, rename mkForAllArrowKinds to mkPiKinds

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,
@@ -137,20 +137,6 @@ Various possibilities suggest themselves:
  - Expand synonyms on the fly, when the problem arises. That is what
    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

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

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

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

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 )

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

compiler/typecheck/TcUnify.lhs

@@ -43,7 +43,6 @@ module TcUnify (
 
 import HsSyn
 import TypeRep
-import CoreUtils( mkPiTypes )
 import TcErrors	( unifyCtxt )
 import TcMType
 import TcIface

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