Commit 2da8a4d1 authored by dreixel's avatar dreixel

Move mkPiTypes back to Type, rename mkForAllArrowKinds to mkPiKinds

parent e589a49d
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 )
......
......@@ -89,7 +89,6 @@ import Data.IORef ( readIORef )
#ifdef GHCI
import TcType ( isUnitTy, isTauTy )
import CoreUtils( mkPiTypes )
import TcHsType
import TcMatches
import RnTypes
......
......@@ -43,7 +43,6 @@ module TcUnify (
import HsSyn
import TypeRep
import CoreUtils( mkPiTypes )
import TcErrors ( unifyCtxt )
import TcMType
import TcIface
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment