Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
2da8a4d1
Commit
2da8a4d1
authored
Nov 16, 2011
by
dreixel
Browse files
Move mkPiTypes back to Type, rename mkForAllArrowKinds to mkPiKinds
parent
e589a49d
Changes
8
Hide whitespace changes
Inline
Side-by-side
compiler/coreSyn/CoreUtils.lhs
View file @
2da8a4d1
...
...
@@ -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
View file @
2da8a4d1
...
...
@@ -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 = mk
ForAllArrow
Kinds tvs rhs_kind
where kind = mk
Pi
Kinds 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 = mk
ForAllArrow
Kinds ktvs liftedTypeKind
where kind = mk
Pi
Kinds 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 = mk
ForAllArrow
Kinds tvs constraintKind
; let { clas_kind = mk
Pi
Kinds tvs constraintKind
; tycon = mkClassTyCon tycon_name clas_kind tvs
rhs rec_clas tc_isrec
...
...
compiler/simplCore/SetLevels.lhs
View file @
2da8a4d1
...
...
@@ -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
View file @
2da8a4d1
...
...
@@ -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
View file @
2da8a4d1
...
...
@@ -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
View file @
2da8a4d1
...
...
@@ -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
View file @
2da8a4d1
...
...
@@ -43,7 +43,6 @@ module TcUnify (
import HsSyn
import TypeRep
import CoreUtils( mkPiTypes )
import TcErrors ( unifyCtxt )
import TcMType
import TcIface
...
...
compiler/types/Type.lhs
View file @
2da8a4d1
...
...
@@ -39,7 +39,7 @@ module Type (
splitTyConApp_maybe, splitTyConApp,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
mk
ForAllArrowKind
s,
mk
PiKinds, mkPiType, mkPiType
s,
applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
-- (Newtypes)
...
...
@@ -675,12 +675,25 @@ mkForAllTy tyvar ty
mkForAllTys :: [TyVar] -> Type -> Type
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
mk
ForAllArrow
Kinds :: [TyVar] -> Kind -> Kind
-- mk
ForAllArrow
Kinds [k1, k2, (a:k1 -> *)] k2
mk
Pi
Kinds :: [TyVar] -> Kind -> Kind
-- mk
Pi
Kinds [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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment