X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=b54183e97c80d55c99b96d12510cdd67b96a679d;hb=6f122ef3930b51bca54bb96858fe9b8f1d85c461;hp=6ec5e2d8415340fd26752f34711b2ba9d12853b9;hpb=a69d07dab4da24816eb78f651c9be7faef9f0c08;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 6ec5e2d..b54183e 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -44,13 +44,13 @@ module Type ( mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys, + applyTy, applyTys, mkPiType, hoistForAllTys, TauType, RhoType, SigmaType, PredType(..), ThetaType, ClassPred, ClassContext, mkClassPred, getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds, isTauTy, mkRhoTy, splitRhoTy, - mkSigmaTy, splitSigmaTy, + mkSigmaTy, isSigmaTy, splitSigmaTy, -- Lifting and boxity isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, @@ -241,14 +241,17 @@ splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty splitFunTy_maybe :: Type -> Maybe (Type, Type) -splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe other = Nothing +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe (NoteTy (IPNote _) ty) = Nothing +splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (NoteTy (IPNote _) ty) + = (reverse args, orig_ty) split args orig_ty (NoteTy _ ty) = split args orig_ty ty split args orig_ty ty = (reverse args, orig_ty) @@ -304,10 +307,11 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) -- including functions are returned as Just .. splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty -splitTyConApp_maybe other = Nothing +splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +splitTyConApp_maybe (NoteTy (IPNote _) ty) = Nothing +splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty +splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for -- *saturated* applications of *algebraic* data types @@ -318,6 +322,8 @@ splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) splitAlgTyConApp_maybe (TyConApp tc tys) | isAlgTyCon tc && tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) +splitAlgTyConApp_maybe (NoteTy (IPNote _) ty) + = Nothing splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty splitAlgTyConApp_maybe other = Nothing @@ -448,6 +454,8 @@ typePrimRep ty = case repType ty of splitNewType_maybe :: Type -> Maybe Type -- Find the representation of a newtype, if it is one -- Looks through multiple levels of newtype, but does not look through for-alls +splitNewType_maybe (NoteTy (IPNote _) ty) + = Nothing splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of Just rep_ty -> ASSERT( length tys == tyConArity tc ) @@ -590,14 +598,10 @@ splitForAllTy_maybe ty = case splitUsgTy_maybe ty of return (tyvar, NoteTy (UsgNote usg) ty'') Nothing -> splitFAT_m ty where - splitFAT_m (NoteTy _ ty) = splitFAT_m ty - splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) - splitFAT_m _ = Nothing - -isForAllTy :: Type -> Bool -isForAllTy (NoteTy _ ty) = isForAllTy ty -isForAllTy (ForAllTy tyvar ty) = True -isForAllTy _ = False + splitFAT_m (NoteTy (IPNote _) ty) = Nothing + splitFAT_m (NoteTy _ ty) = splitFAT_m ty + splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = case splitUsgTy_maybe ty of @@ -605,9 +609,10 @@ splitForAllTys ty = case splitUsgTy_maybe ty of in (tvs, NoteTy (UsgNote usg) ty'') Nothing -> split ty ty [] where - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (NoteTy (IPNote _) ty) tvs = (reverse tvs, orig_ty) + split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs + split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} @mkPiType@ makes a (->) type or a forall type, depending on whether @@ -719,12 +724,13 @@ classesOfPreds theta = concatMap cvt theta \begin{code} isTauTy :: Type -> Bool -isTauTy (TyVarTy v) = True -isTauTy (TyConApp _ tys) = all isTauTy tys -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (NoteTy _ ty) = isTauTy ty -isTauTy other = False +isTauTy (TyVarTy v) = True +isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (NoteTy (IPNote _) ty) = False +isTauTy (NoteTy _ ty) = isTauTy ty +isTauTy other = False \end{code} \begin{code} @@ -737,8 +743,9 @@ splitRhoTy ty = split ty ty [] split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of Just p -> split res res (p:ts) Nothing -> (reverse ts, orig_ty) - split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts - split orig_ty ty ts = (reverse ts, orig_ty) + split orig_ty (NoteTy (IPNote _) ty) ts = (reverse ts, orig_ty) + split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts + split orig_ty ty ts = (reverse ts, orig_ty) \end{code} @@ -746,6 +753,17 @@ splitRhoTy ty = split ty ty [] \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) +isSigmaTy :: Type -> Bool +isSigmaTy (FunTy a b) = isPredTy a + where isPredTy (NoteTy (IPNote _) _) = True + -- JRL could be a dict ty, but that would be polymorphic, + -- and thus there would have been an outer ForAllTy + isPredTy _ = False +isSigmaTy (NoteTy (IPNote _) _) = False +isSigmaTy (NoteTy _ ty) = isSigmaTy ty +isSigmaTy (ForAllTy tyvar ty) = True +isSigmaTy _ = False + splitSigmaTy :: Type -> ([TyVar], [PredType], Type) splitSigmaTy ty = (tyvars, theta, tau) @@ -988,6 +1006,5 @@ seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () seqNote (UsgNote usg) = usg `seq` () -seqNote (IPNote nm) = nm `seq` () +seqNote (IPNote nm) = nm `seq` () \end{code} -