projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix GADT refinement fix-pointing, add ASSERTs and a WARN, make type equality function...
[ghc-hetmet.git]
/
compiler
/
types
/
Type.lhs
diff --git
a/compiler/types/Type.lhs
b/compiler/types/Type.lhs
index
fd8e8c5
..
2aa31eb
100644
(file)
--- a/
compiler/types/Type.lhs
+++ b/
compiler/types/Type.lhs
@@
-24,7
+24,7
@@
module Type (
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
- isCoSuperKind, isSuperKind, isCoercionKind,
+ isCoSuperKind, isSuperKind, isCoercionKind, isEqPred,
mkArrowKind, mkArrowKinds,
isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
mkArrowKind, mkArrowKinds,
isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
@@
-56,7
+56,7
@@
module Type (
predTypeRep, mkPredTy, mkPredTys,
-- Newtypes
predTypeRep, mkPredTy, mkPredTys,
-- Newtypes
- splitRecNewType_maybe,
+ splitRecNewType_maybe, newTyConInstRhs,
-- Lifting and boxity
isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
-- Lifting and boxity
isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
@@
-106,7
+106,7
@@
import TypeRep
-- friends:
import Var ( Var, TyVar, tyVarKind, tyVarName,
-- friends:
import Var ( Var, TyVar, tyVarKind, tyVarName,
- setTyVarName, setTyVarKind )
+ setTyVarName, setTyVarKind, mkWildCoVar )
import VarEnv
import VarSet
import VarEnv
import VarSet
@@
-164,7
+164,9
@@
coreView :: Type -> Maybe Type
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (NoteTy _ ty) = Just ty
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (NoteTy _ ty) = Just ty
-coreView (PredTy p) = Just (predTypeRep p)
+coreView (PredTy p)
+ | isEqPred p = Nothing
+ | otherwise = Just (predTypeRep p)
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-- Its important to use mkAppTys, rather than (foldl AppTy),
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-- Its important to use mkAppTys, rather than (foldl AppTy),
@@
-305,10
+307,11
@@
splitAppTys ty = split ty ty []
\begin{code}
mkFunTy :: Type -> Type -> Type
\begin{code}
mkFunTy :: Type -> Type -> Type
+mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
-mkFunTys tys ty = foldr FunTy ty tys
+mkFunTys tys ty = foldr mkFunTy ty tys
isFunTy :: Type -> Bool
isFunTy ty = isJust (splitFunTy_maybe ty)
isFunTy :: Type -> Bool
isFunTy ty = isJust (splitFunTy_maybe ty)
@@
-410,6
+413,12
@@
splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other = Nothing
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other = Nothing
+-- get instantiated newtype rhs, the arguments had better saturate
+-- the constructor
+newTyConInstRhs :: TyCon -> [Type] -> Type
+newTyConInstRhs tycon tys =
+ let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
+
\end{code}
\end{code}
@@
-590,6
+599,7
@@
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Result might be a newtype application, but the consumer will
-- look through that too if necessary
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Result might be a newtype application, but the consumer will
-- look through that too if necessary
+predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
\end{code}
\end{code}
@@
-1019,6
+1029,7
@@
cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTy
cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2
cmpPredX env (IParam _ _) (ClassP _ _) = LT
cmpPredX env (ClassP _ _) (IParam _ _) = GT
cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2
cmpPredX env (IParam _ _) (ClassP _ _) = LT
cmpPredX env (ClassP _ _) (IParam _ _) = GT
+cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2')
\end{code}
PredTypes are used as a FM key in TcSimplify,
\end{code}
PredTypes are used as a FM key in TcSimplify,
@@
-1417,6
+1428,8
@@
isSubKind :: Kind -> Kind -> Bool
-- (k1 `isSubKind` k2) checks that k1 <: k2
isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc1
isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-- (k1 `isSubKind` k2) checks that k1 <: k2
isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc1
isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2'))
+ = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2'
isSubKind k1 k2 = False
eqKind :: Kind -> Kind -> Bool
isSubKind k1 k2 = False
eqKind :: Kind -> Kind -> Bool
@@
-1459,4
+1472,8
@@
isCoercionKind :: Kind -> Bool
isCoercionKind k | Just k' <- kindView k = isCoercionKind k'
isCoercionKind (PredTy (EqPred {})) = True
isCoercionKind other = False
isCoercionKind k | Just k' <- kindView k = isCoercionKind k'
isCoercionKind (PredTy (EqPred {})) = True
isCoercionKind other = False
+
+isEqPred :: PredType -> Bool
+isEqPred (EqPred _ _) = True
+isEqPred other = False
\end{code}
\end{code}