From c4786b4eb8481d3dbda8ba49f675e6d1958d6d18 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 10 Jul 2001 11:32:28 +0000 Subject: [PATCH] [project @ 2001-07-10 11:32:28 by simonpj] Two bug-fixes to the new newtype story 1. Be consistent about using TcType (not Type) in the typechecker. There was an odd function in TcMType that used splitTyConApp instead of tcSplitTyConApp, which resulted in bogus error messages 2. TcType.isTauTy should not look through SourceTy --- ghc/compiler/typecheck/TcMType.lhs | 78 +++++++++++++++++---------------- ghc/compiler/typecheck/TcMonoType.lhs | 7 +-- ghc/compiler/typecheck/TcType.lhs | 41 ++++++++++++----- 3 files changed, 71 insertions(+), 55 deletions(-) diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index f11634e..01cf3cd 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -10,11 +10,6 @@ module TcMType ( TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcRhoType, TcTyVarSet, -------------------------------- - -- Find the type to which a type variable is bound - tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType - tcGetTyVar, -- :: TcTyVar -> NF_TcM (Maybe TcType) does shorting out - - -------------------------------- -- Creating new mutable type variables newTyVar, newTyVarTy, -- Kind -> NF_TcM TcType @@ -45,11 +40,20 @@ module TcMType ( -- friends: -import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend -import Type -- Lots and lots +import TypeRep ( Type(..), SourceType(..), Kind, TyNote(..), -- friend + openKindCon, typeCon + ) import TcType ( tcEqType, tcSplitRhoTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, - tcSplitTyConApp_maybe, tcSplitFunTy_maybe + tcSplitTyConApp_maybe, tcSplitFunTy_maybe, tcSplitForAllTys, + tcGetTyVar, tcIsTyVarTy, + + mkAppTy, mkTyVarTy, mkTyVarTys, mkFunTy, mkTyConApp, + + liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind, + superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind, + tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar, + eqKind, ) import Subst ( Subst, mkTopTyVarSubst, substTy ) import TyCon ( TyCon, mkPrimTyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) @@ -132,10 +136,10 @@ tcSplitRhoTyM t Just pair -> go res res (pair:ts) Nothing -> returnNF_Tc (reverse ts, syn_t) go syn_t (NoteTy n t) ts = go syn_t t ts - go syn_t (TyVarTy tv) ts = tcGetTyVar tv `thenNF_Tc` \ maybe_ty -> + go syn_t (TyVarTy tv) ts = getTcTyVar tv `thenNF_Tc` \ maybe_ty -> case maybe_ty of - Just ty | not (isTyVarTy ty) -> go syn_t ty ts - other -> returnNF_Tc (reverse ts, syn_t) + Just ty | not (tcIsTyVarTy ty) -> go syn_t ty ts + other -> returnNF_Tc (reverse ts, syn_t) go syn_t (UsageTy _ t) ts = go syn_t t ts go syn_t t ts = returnNF_Tc (reverse ts, syn_t) \end{code} @@ -192,7 +196,7 @@ fresh type variables, splits off the dictionary part, and returns the results. \begin{code} tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType) tcInstType ty - = case splitForAllTys ty of + = case tcSplitForAllTys ty of ([], rho) -> -- There may be overloading but no type variables; -- (?x :: Int) => Int -> Int let @@ -216,16 +220,16 @@ tcInstType ty %************************************************************************ \begin{code} -tcPutTyVar :: TcTyVar -> TcType -> NF_TcM TcType -tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) +putTcTyVar :: TcTyVar -> TcType -> NF_TcM TcType +getTcTyVar :: TcTyVar -> NF_TcM (Maybe TcType) \end{code} Putting is easy: \begin{code} -tcPutTyVar tyvar ty +putTcTyVar tyvar ty | not (isMutTyVar tyvar) - = pprTrace "tcPutTyVar" (ppr tyvar) $ + = pprTrace "putTcTyVar" (ppr tyvar) $ returnNF_Tc ty | otherwise @@ -238,7 +242,7 @@ tcPutTyVar tyvar ty Getting is more interesting. The easy thing to do is just to read, thus: \begin{verbatim} -tcGetTyVar tyvar = tcReadMutTyVar tyvar +getTcTyVar tyvar = tcReadMutTyVar tyvar \end{verbatim} But it's more fun to short out indirections on the way: If this @@ -248,9 +252,9 @@ any other type, then there might be bound TyVars embedded inside it. We return Nothing iff the original box was unbound. \begin{code} -tcGetTyVar tyvar +getTcTyVar tyvar | not (isMutTyVar tyvar) - = pprTrace "tcGetTyVar" (ppr tyvar) $ + = pprTrace "getTcTyVar" (ppr tyvar) $ returnNF_Tc (Just (mkTyVarTy tyvar)) | otherwise @@ -306,7 +310,7 @@ zonkTcSigTyVars :: [TcTyVar] -> NF_TcM [TcTyVar] -- that is overkill, so we use this simpler chap zonkTcSigTyVars tyvars = zonkTcTyVars tyvars `thenNF_Tc` \ tys -> - returnNF_Tc (map (getTyVar "zonkTcSigTyVars") tys) + returnNF_Tc (map (tcGetTyVar "zonkTcSigTyVars") tys) \end{code} ----------------- Types @@ -349,8 +353,8 @@ zonkKindEnv pairs -- When zonking a kind, we want to -- zonk a *kind* variable to (Type *) -- zonk a *boxity* variable to * - zonk_unbound_kind_var kv | tyVarKind kv `eqKind` superKind = tcPutTyVar kv liftedTypeKind - | tyVarKind kv `eqKind` superBoxity = tcPutTyVar kv liftedBoxity + zonk_unbound_kind_var kv | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind + | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity | otherwise = pprPanic "zonkKindEnv" (ppr kv) zonkTcTypeToType :: TcType -> NF_TcM Type @@ -361,10 +365,10 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty -- :Void otherwise zonk_unbound_tyvar tv | kind `eqKind` liftedTypeKind || kind `eqKind` openTypeKind - = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in + = putTcTyVar tv voidTy -- Just to avoid creating a new tycon in -- this vastly common case | otherwise - = tcPutTyVar tv (TyConApp (mk_void_tycon tv kind) []) + = putTcTyVar tv (TyConApp (mk_void_tycon tv kind) []) where kind = tyVarKind tv @@ -394,7 +398,7 @@ zonkTcTyVarToTyVar tv immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) immut_tv_ty = mkTyVarTy immut_tv - zap tv = tcPutTyVar tv immut_tv_ty + zap tv = putTcTyVar tv immut_tv_ty -- Bind the mutable version to the immutable one in -- If the type variable is mutable, then bind it to immut_tv_ty @@ -451,7 +455,7 @@ zonkType unbound_var_fn ty go (UsageTy u ty) = go u `thenNF_Tc` \ u' -> go ty `thenNF_Tc` \ ty' -> - returnNF_Tc (mkUTy u' ty') + returnNF_Tc (UsageTy u' ty') -- The two interesting cases! go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar @@ -477,7 +481,7 @@ zonkTyVar unbound_var_fn tyvar returnNF_Tc (TyVarTy tyvar) | otherwise - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Nothing -> unbound_var_fn tyvar -- Mutable and unbound Just other_ty -> zonkType unbound_var_fn other_ty -- Bound @@ -512,7 +516,7 @@ unifyOpenTypeKind :: TcKind -> TcM () -- for some boxity bx unifyOpenTypeKind ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Just ty' -> unifyOpenTypeKind ty' other -> unify_open_kind_help ty @@ -726,7 +730,7 @@ uVar :: Bool -- False => tyvar is the "expected" -> TcM () uVar swapped tv1 ps_ty2 ty2 - = tcGetTyVar tv1 `thenNF_Tc` \ maybe_ty1 -> + = getTcTyVar tv1 `thenNF_Tc` \ maybe_ty1 -> case maybe_ty1 of Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order @@ -747,19 +751,19 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) -- Distinct type variables -- ASSERT maybe_ty1 /= Just | otherwise - = tcGetTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> + = getTcTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> case maybe_ty2 of Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2' Nothing | update_tv2 -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) - tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` + putTcTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () | otherwise -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) - (tcPutTyVar tv1 ps_ty2 `thenNF_Tc_` + (putTcTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc ()) where k1 = tyVarKind tv1 @@ -808,14 +812,14 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2 -- That's why we have this two-state occurs-check zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' -> if not (tv1 `elemVarSet` tyVarsOfType ps_ty2') then - tcPutTyVar tv1 ps_ty2' `thenNF_Tc_` + putTcTyVar tv1 ps_ty2' `thenNF_Tc_` returnTc () else zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' -> if not (tv1 `elemVarSet` tyVarsOfType non_var_ty2') then -- This branch rarely succeeds, except in strange cases -- like that in the example above - tcPutTyVar tv1 non_var_ty2' `thenNF_Tc_` + putTcTyVar tv1 non_var_ty2' `thenNF_Tc_` returnTc () else failWithTcM (unifyOccurCheck tv1 ps_ty2') @@ -851,7 +855,7 @@ unifyFunTy :: TcType -- Fail if ty isn't a function type -> TcM (TcType, TcType) -- otherwise return arg and result types unifyFunTy ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Just ty' -> unifyFunTy ty' other -> unify_fun_ty_help ty @@ -873,7 +877,7 @@ unifyListTy :: TcType -- expected list type -> TcM TcType -- list element type unifyListTy ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Just ty' -> unifyListTy ty' other -> unify_list_ty_help ty @@ -892,7 +896,7 @@ unify_list_ty_help ty -- Revert to ordinary unification \begin{code} unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType] unifyTupleTy boxity arity ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Just ty' -> unifyTupleTy boxity arity ty' other -> unify_tuple_ty_help boxity arity ty diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 7a7086b..4ceae2b 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -305,12 +305,7 @@ tcHsSigType and tcHsLiftedSigType are used for type signatures written by the pr \begin{code} tcHsSigType, tcHsLiftedSigType :: RenamedHsType -> TcM Type -- Do kind checking, and hoist for-alls to the top -tcHsSigType ty = traceTc (text "tcHsSig1:" <+> ppr ty) `thenTc_` - kcTypeType ty `thenTc_` - traceTc (text "tcHsSig2:" <+> ppr ty) `thenTc_` - tcHsType ty `thenTc` \ sig_ty -> - traceTc (text "tcHsSig3:" <+> ppr sig_ty) `thenTc_` - returnTc sig_ty +tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty tcHsLiftedSigType ty = kcLiftedType ty `thenTc_` tcHsType ty tcHsType :: RenamedHsType -> TcM Type diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index d9c6387..8ebc1b4 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -52,7 +52,7 @@ module TcType ( PredType, mkPredTy, mkPredTys, getClassPredTys_maybe, getClassPredTys, isPredTy, isClassPred, isTyVarClassPred, predHasFDs, mkDictTy, tcSplitPredTy_maybe, predTyUnique, - isDictTy, tcSplitDFunTy, + isDictTy, tcSplitDFunTy, predTyUnique, mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName, --------------------------------- @@ -63,20 +63,23 @@ module TcType ( -------------------------------- -- Rexported from Type - Kind, Type, SourceType(..), PredType, ThetaType, - unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + Kind, -- Stuff to do with kinds is insensitive to pre/post Tc + unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, + + Type, SourceType(..), PredType, ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, - mkTyVarTy, mkTyVarTys, mkTyConTy, - predTyUnique, mkClassPred, + mkTyVarTy, mkTyVarTys, mkTyConTy, + isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto + tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, - eqKind, eqUsage, + typeKind, eqKind, eqUsage, - -- Reexported ??? tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta ) where @@ -86,8 +89,22 @@ module TcType ( import {-# SOURCE #-} PprType( pprType ) -- friends: -import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type -- Lots and lots +import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend +import Type ( mkUTyM, unUTy ) -- Used locally + +import Type ( -- Re-exports + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + Kind, Type, TauType, SourceType(..), PredType, ThetaType, + unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + mkForAllTy, mkForAllTys, defaultKind, + mkFunTy, mkFunTys, zipFunTys, + mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, + isUnLiftedType, isUnboxedTupleType, + tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, + tidyTyVar, tidyTyVars, eqKind, eqUsage, + hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind + ) import TyCon ( TyCon, isPrimTyCon, tyConArity, isNewTyCon ) import Class ( classTyCon, classHasFDs, Class ) import Var ( TyVar, tyVarKind ) @@ -137,7 +154,7 @@ 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 (SourceTy p) = isTauTy (sourceTypeRep p) +isTauTy (SourceTy p) = True -- Don't look through source types isTauTy (NoteTy _ ty) = isTauTy ty isTauTy (UsageTy _ ty) = isTauTy ty isTauTy other = False @@ -360,7 +377,7 @@ isClassPred :: SourceType -> Bool isClassPred (ClassP clas tys) = True isClassPred other = False -isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys +isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys isTyVarClassPred other = False getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type]) @@ -548,7 +565,7 @@ isPrimitiveType :: Type -> Bool -- Returns types that are opaque to Haskell. -- Most of these are unlifted, but now that we interact with .NET, we -- may have primtive (foreign-imported) types that are lifted -isPrimitiveType ty = case splitTyConApp_maybe ty of +isPrimitiveType ty = case tcSplitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) isPrimTyCon tc other -> False -- 1.7.10.4