Commit 979947f5 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-02-06 15:54:23 by simonpj]

Eliminate all vestiages of UsageTy, in preparation for
	Keith's new version.  Hurrah!

	Keith: LBVarInfo and usOnce,usMany are still there,
	because I know you have eliminated LBVarInfo, and I didn't
	want to cause unnecessary conflicts.
parent 6e1e8a09
......@@ -15,8 +15,7 @@ import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
isUnLiftedType, isUnboxedTupleType, repType,
uaUTy, usOnce, usMany, eqUsage, seqType )
isUnLiftedType, isUnboxedTupleType, repType, seqType )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import PrimOp ( PrimOp(..) )
import Var ( Var, Id, setVarUnique )
......@@ -702,23 +701,12 @@ mkDem :: Demand -> Bool -> RhsDemand
mkDem strict once = RhsDemand (isStrictDmd strict) once
mkDemTy :: Demand -> Type -> RhsDemand
mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
isOnceTy :: Type -> Bool
isOnceTy ty
=
#ifdef USMANY
opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
#endif
once
where
u = uaUTy ty
once | u `eqUsage` usOnce = True
| u `eqUsage` usMany = False
| isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
mkDemTy strict ty = RhsDemand (isStrictDmd strict)
False {- For now -}
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
bdrDem id = mkDem (idNewDemandInfo id)
False {- For now -}
safeDem, onceDem :: RhsDemand
safeDem = RhsDemand False False -- always safe to use this
......
......@@ -57,7 +57,7 @@ import IdInfo ( LBVarInfo(..),
megaSeqIdInfo )
import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy,
funResultTy, applyTy
......@@ -111,12 +111,8 @@ mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
mkPiTypes vs ty = foldr mkPiType ty vs
mkPiType v ty
| isId v = add_usage (mkFunTy (idType v) ty)
| isId v = mkFunTy (idType v) ty
| otherwise = mkForAllTy v ty
where
add_usage ty = case idLBVarInfo v of
LBVarInfo u -> mkUTy u ty
otherwise -> ty
\end{code}
\begin{code}
......
......@@ -142,7 +142,6 @@ make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (
make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty (SourceTy p) = make_ty (sourceTypeRep p)
make_ty (UsageTy _ t) = make_ty t
make_ty (NoteTy _ t) = make_ty t
......
......@@ -45,7 +45,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( ThetaType, SourceType(..), PredType,
tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
tyVarsOfType, tyVarsOfTypes, mkAppTy,
)
import VarSet
import VarEnv
......@@ -249,12 +249,10 @@ zapSubstEnv :: Subst -> Subst
zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
extendSubst :: Subst -> Var -> SubstResult -> Subst
extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
Subst in_scope (extendSubstEnv env v r)
extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
Subst in_scope (extendSubstEnvList env v r)
extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
lookupSubst :: Subst -> Var -> Maybe SubstResult
lookupSubst (Subst _ env) v = lookupSubstEnv env v
......@@ -440,8 +438,6 @@ subst_ty subst ty
go (ForAllTy tv ty) = case substTyVar subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
go (UsageTy u ty) = mkUTy (go u) $! (go ty)
\end{code}
Here is where we invent a new binder if necessary.
......
......@@ -106,9 +106,6 @@ data HsType name
-- these next two are only used in interfaces
| HsPredTy (HsPred name)
| HsUsageTy (HsType name) -- Usage annotation
(HsType name) -- Annotated type
-----------------------
......@@ -286,12 +283,6 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
ppr_mono_ty ctxt_prec (HsPredTy pred)
= braces (ppr pred)
ppr_mono_ty ctxt_prec (HsUsageTy u ty)
= maybeParen (ctxt_prec >= pREC_CON)
(sep [ptext SLIT("__u") <+> ppr_mono_ty pREC_CON u,
ppr_mono_ty pREC_CON ty])
-- pREC_FUN would be logical for u, but it yields a reduce/reduce conflict with AppTy
-- Generics
ppr_mono_ty ctxt_prec (HsNumTy n) = integer n
ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2
......@@ -366,10 +357,6 @@ toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of
(map toHsPred preds)
(toHsType tau)
toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty)
-- **! consider dropping usMany annotations ToDo KSW 2000-10
toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
toHsPred (IParam n ty) = HsIParam n (toHsType ty)
......@@ -471,9 +458,6 @@ eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2)
eq_hsType env (HsPredTy p1) (HsPredTy p2)
= eq_hsPred env p1 p2
eq_hsType env (HsUsageTy u1 ty1) (HsUsageTy u2 ty2)
= eq_hsType env u1 u2 && eq_hsType env ty1 ty2
eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
= eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
......
......@@ -6,7 +6,7 @@
\begin{code}
module PrimOp (
PrimOp(..), allThePrimOps,
primOpType, primOpSig, primOpUsg, primOpArity,
primOpType, primOpSig, primOpArity,
mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc,
commutableOp,
......@@ -31,8 +31,7 @@ import RdrName ( RdrName, mkRdrOrig )
import OccName ( OccName, pprOccName, mkVarOcc )
import TyCon ( TyCon, isPrimTyCon, tyConPrimRep )
import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep,
splitFunTy_maybe, tyConAppTyCon, splitTyConApp,
mkUTy, usOnce, usMany
splitFunTy_maybe, tyConAppTyCon, splitTyConApp
)
import PprType () -- get at Outputable Type instance.
import Unique ( mkPrimOpIdUnique )
......@@ -427,49 +426,6 @@ primOpSig op
Compare occ ty -> ([], [ty,ty], boolTy)
GenPrimOp occ tyvars arg_tys res_ty
-> (tyvars, arg_tys, res_ty)
-- primOpUsg is like primOpSig but the types it yields are the
-- appropriate sigma (i.e., usage-annotated) types,
-- as required by the UsageSP inference.
primOpUsg :: PrimOp -> ([TyVar],[Type],Type)
#include "primop-usage.hs-incl"
-- Things with no Haskell pointers inside: in actuality, usages are
-- irrelevant here (hence it doesn't matter that some of these
-- apparently permit duplication; since such arguments are never
-- ENTERed anyway, the usage annotation they get is entirely irrelevant
-- except insofar as it propagates to infect other values that *are*
-- pointed.
-- Helper bits & pieces for usage info.
mkZ = mkUTy usOnce -- pointed argument used zero
mkO = mkUTy usOnce -- pointed argument used once
mkM = mkUTy usMany -- pointed argument used multiply
mkP = mkUTy usOnce -- unpointed argument
mkR = mkUTy usMany -- unpointed result
nomangle op
= case primOpSig op of
(tyvars, arg_tys, res_ty, _, _)
-> (tyvars, map mkP arg_tys, mkR res_ty)
mangle op fs g
= case primOpSig op of
(tyvars, arg_tys, res_ty, _, _)
-> (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty)
inFun op f g ty
= case splitFunTy_maybe ty of
Just (a,b) -> mkFunTy (f a) (g b)
Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
inUB op fs ty
= case splitTyConApp ty of
(tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys)
\end{code}
\begin{code}
......
......@@ -547,7 +547,6 @@ types2 : type ',' type { [$1,$3] }
btype :: { RdrNameHsType }
btype : atype { $1 }
| btype atype { HsAppTy $1 $2 }
| '__u' atype atype { HsUsageTy $2 $3 }
atype :: { RdrNameHsType }
atype : qtc_name { HsTyVar $1 }
......@@ -579,7 +578,6 @@ ttype : '__forall' tv_bndrs
tbtype :: { RdrNameHsType }
tbtype : tatype { $1 }
| tbtype atype { HsAppTy $1 $2 }
| '__u' atype atype { HsUsageTy $2 $3 }
tatype :: { RdrNameHsType }
tatype : qtc_name { HsTyVar $1 }
......
......@@ -157,7 +157,6 @@ tcSplitRhoTyM t
case maybe_ty of
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}
......@@ -274,7 +273,6 @@ putTcTyVar tyvar ty
| otherwise
= ASSERT( isMutTyVar tyvar )
UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty )
tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_`
returnNF_Tc ty
\end{code}
......@@ -498,10 +496,6 @@ zonkType unbound_var_fn ty
go arg `thenNF_Tc` \ arg' ->
returnNF_Tc (mkAppTy fun' arg')
go (UsageTy u ty) = go u `thenNF_Tc` \ u' ->
go ty `thenNF_Tc` \ ty' ->
returnNF_Tc (UsageTy u' ty')
-- The two interesting cases!
go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar
......@@ -725,7 +719,6 @@ check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM ()
-- Rank is allowed rank for function args
-- No foralls otherwise
check_tau_type rank ubx_tup ty@(UsageTy _ _) = failWithTc (usageTyErr ty)
check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty)
check_tau_type rank ubx_tup (SourceTy sty) = getDOptsTc `thenNF_Tc` \ dflags ->
check_source_ty dflags TypeCtxt sty
......@@ -778,7 +771,6 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
----------------------------------------
forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty
usageTyErr ty = ptext SLIT("Illegal usage type:") <+> ppr_ty ty
unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty
ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty
kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
......
......@@ -108,7 +108,6 @@ import {-# SOURCE #-} PprType( pprType )
-- friends:
import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
import Type ( mkUTyM, unUTy ) -- Used locally
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
......@@ -289,9 +288,7 @@ tyVarBindingInfo tv
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
mkRhoTy :: [SourceType] -> Type -> Type
mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
\end{code}
......@@ -305,7 +302,6 @@ isTauTy (AppTy a b) = isTauTy a && isTauTy b
isTauTy (FunTy a b) = isTauTy a && isTauTy b
isTauTy (SourceTy p) = True -- Don't look through source types
isTauTy (NoteTy _ ty) = isTauTy ty
isTauTy (UsageTy _ ty) = isTauTy ty
isTauTy other = False
\end{code}
......@@ -318,7 +314,6 @@ getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (NoteTy _ t) = getDFunTyKey t
getDFunTyKey (FunTy arg _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
getDFunTyKey (UsageTy _ t) = getDFunTyKey t
getDFunTyKey (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable
getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
-- SourceTy shouldn't happen
......@@ -345,12 +340,10 @@ tcSplitForAllTys ty = split ty ty []
where
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs
split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
split orig_ty t tvs = (reverse tvs, orig_ty)
tcIsForAllTy (ForAllTy tv ty) = True
tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty
tcIsForAllTy (UsageTy n ty) = tcIsForAllTy ty
tcIsForAllTy t = False
tcSplitRhoTy :: Type -> ([PredType], Type)
......@@ -360,7 +353,6 @@ tcSplitRhoTy ty = split ty ty []
Just p -> split res res (p:ts)
Nothing -> (reverse ts, orig_ty)
split orig_ty (NoteTy n ty) ts = split orig_ty ty ts
split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts
split orig_ty ty ts = (reverse ts, orig_ty)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
......@@ -381,9 +373,8 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-- Newtypes are opaque, so they may be split
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
tcSplitTyConApp_maybe (UsageTy _ ty) = tcSplitTyConApp_maybe ty
tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys)
-- However, predicates are not treated
-- as tycon applications by the type checker
......@@ -399,7 +390,6 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty
tcSplitFunTy_maybe (UsageTy _ ty) = tcSplitFunTy_maybe ty
tcSplitFunTy_maybe other = Nothing
tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
......@@ -407,10 +397,9 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
tcSplitAppTy_maybe (UsageTy _ ty) = tcSplitAppTy_maybe ty
tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys
--- Don't forget that newtype!
tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys
......@@ -429,7 +418,6 @@ tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe (TyVarTy tv) = Just tv
tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
tcGetTyVar_maybe ty@(UsageTy _ _) = pprPanic "tcGetTyVar_maybe: UTy:" (pprType ty)
tcGetTyVar_maybe other = Nothing
tcGetTyVar :: String -> Type -> TyVar
......@@ -455,7 +443,6 @@ tcSplitMethodTy ty = split ty
Just p -> (p, res)
Nothing -> panic "splitMethodTy"
split (NoteTy n ty) = split ty
split (UsageTy _ ty) = split ty
split _ = panic "splitMethodTy"
tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type])
......@@ -483,14 +470,12 @@ isPred (NType _ _) = False
isPredTy :: Type -> Bool
isPredTy (NoteTy _ ty) = isPredTy ty
isPredTy (UsageTy _ ty) = isPredTy ty
isPredTy (SourceTy sty) = isPred sty
isPredTy _ = False
tcSplitPredTy_maybe :: Type -> Maybe PredType
-- Returns Just for predicates only
tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
tcSplitPredTy_maybe (UsageTy _ ty) = tcSplitPredTy_maybe ty
tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p
tcSplitPredTy_maybe other = Nothing
......@@ -513,8 +498,7 @@ mkPredName uniq loc (IParam ip ty) = mkLocalName uniq (getOccName (ipNameName
--------------------- Dictionary types ---------------------------------
\begin{code}
mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
ClassP clas tys
mkClassPred clas tys = ClassP clas tys
isClassPred :: SourceType -> Bool
isClassPred (ClassP clas tys) = True
......@@ -531,13 +515,11 @@ getClassPredTys :: PredType -> (Class, [Type])
getClassPredTys (ClassP clas tys) = (clas, tys)
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
mkPredTy (ClassP clas tys)
mkDictTy clas tys = mkPredTy (ClassP clas tys)
isDictTy :: Type -> Bool
isDictTy (SourceTy p) = isClassPred p
isDictTy (NoteTy _ ty) = isDictTy ty
isDictTy (UsageTy _ ty) = isDictTy ty
isDictTy other = False
\end{code}
......@@ -597,11 +579,9 @@ cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
-- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
-- we in effect substitute tv2 for tv1 in t1 before continuing
-- Look through NoteTy and UsageTy
-- Look through NoteTy
cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
cmpTy env (UsageTy _ ty1) ty2 = cmpTy env ty1 ty2
cmpTy env ty1 (UsageTy _ ty2) = cmpTy env ty1 ty2
-- Deal with equal constructors
cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
......@@ -674,14 +654,12 @@ isSigmaTy :: Type -> Bool
isSigmaTy (ForAllTy tyvar ty) = True
isSigmaTy (FunTy a b) = isPredTy a
isSigmaTy (NoteTy n ty) = isSigmaTy ty
isSigmaTy (UsageTy _ ty) = isSigmaTy ty
isSigmaTy _ = False
isOverloadedTy :: Type -> Bool
isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
isOverloadedTy (FunTy a b) = isPredTy a
isOverloadedTy (NoteTy n ty) = isOverloadedTy ty
isOverloadedTy (UsageTy _ ty) = isOverloadedTy ty
isOverloadedTy _ = False
\end{code}
......@@ -732,7 +710,6 @@ hoistForAllTys ty
(tvs,theta,tau) -> (tvs,theta,mkFunTy arg tau)
hoist orig_ty (NoteTy _ ty) = hoist orig_ty ty
hoist orig_ty (UsageTy _ ty) = hoist orig_ty ty
hoist orig_ty ty = ([], [], orig_ty)
\end{code}
......@@ -747,7 +724,6 @@ deNoteType (NoteTy _ ty) = deNoteType ty
deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
deNoteSourceType :: SourceType -> SourceType
deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys)
......@@ -770,7 +746,6 @@ namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets`
namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
......@@ -1025,10 +1000,6 @@ uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)"
uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)"
#endif
-- Ignore usages
uTysX (UsageTy _ t1) t2 k subst = uTysX t1 t2 k subst
uTysX t1 (UsageTy _ t2) k subst = uTysX t1 t2 k subst
-- Anything else fails
uTysX ty1 ty2 k subst = Nothing
......@@ -1049,7 +1020,6 @@ uVarX tv1 ty2 k subst@(tmpls, env)
| typeKind ty2 `eqKind` tyVarKind tv1
&& occur_check_ok ty2
-> -- No kind mismatch nor occur check
UASSERT( not (isUTy ty2) )
k (tmpls, extendSubstEnv env tv1 (DoneTy ty2))
| otherwise -> Nothing -- Fail if kind mis-match or occur check
......@@ -1117,8 +1087,7 @@ match (TyVarTy v) ty tmpls k senv
| v `elemVarSet` tmpls
= -- v is a template variable
case lookupSubstEnv senv v of
Nothing -> UASSERT( not (isUTy ty) )
k (extendSubstEnv senv v (DoneTy ty))
Nothing -> k (extendSubstEnv senv v (DoneTy ty))
Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds
| otherwise -> Nothing -- Fails
......@@ -1159,9 +1128,6 @@ match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv
match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv
| tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
match (UsageTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv
match ty1 (UsageTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv
-- With type synonyms, we have to be careful for the exact
-- same reasons as in the unifier. Please see the
-- considerable commentary there before changing anything
......
......@@ -420,10 +420,6 @@ uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1
uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
-- Ignore usage annotations inside typechecker
uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
-- Variables; go for uVar
uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2
uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1
......
......@@ -20,7 +20,7 @@ module PprType(
-- (PprType can see all the representations it's trying to print)
import TypeRep ( Type(..), TyNote(..),
Kind, liftedTypeKind ) -- friend
import Type ( SourceType(..), isUTyVar, eqKind )
import Type ( SourceType(..), eqKind )
import TcType ( ThetaType, PredType,
tcSplitSigmaTy, isPredTy, isDictTy,
tcSplitTyConApp_maybe, tcSplitFunTy_maybe
......@@ -165,13 +165,7 @@ ppr_ty ctxt_prec ty@(ForAllTy _ _)
]
where
(tyvars, theta, tau) = tcSplitSigmaTy ty
pp_tyvars sty = sep (map pprTyVarBndr some_tyvars)
where
some_tyvars | userStyle sty && not opt_PprStyle_RawTypes
= filter (not . isUTyVar) tyvars -- hide uvars from user
| otherwise
= tyvars
pp_tyvars sty = sep (map pprTyVarBndr tyvars)
ppr_theta [] = empty
ppr_theta theta = pprTheta theta <+> ptext SLIT("=>")
......@@ -191,12 +185,6 @@ ppr_ty ctxt_prec (AppTy ty1 ty2)
= maybeParen ctxt_prec tYCON_PREC $
ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2
ppr_ty ctxt_prec (UsageTy u ty)
= maybeParen ctxt_prec tYCON_PREC $
ptext SLIT("__u") <+> ppr_ty tYCON_PREC u
<+> ppr_ty tYCON_PREC ty
-- fUN_PREC would be logical for u, but it yields a reduce/reduce conflict with AppTy
ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion)
= ppr_ty ctxt_prec ty
-- = ppr_ty ctxt_prec expansion -- if we don't want to see syntys
......
......@@ -37,10 +37,6 @@ module Type (
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
mkUTy, splitUTy, splitUTy_maybe,
isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
isUsageKind, isUsage, isUTyVar,
mkSynTy,
repType, splitRepFunTys, typePrimRep,
......@@ -59,7 +55,7 @@ module Type (
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
usageAnnOfType, typeKind, addFreeTyVars,
typeKind, addFreeTyVars,
-- Tidying up for printing
tidyType, tidyTypes,
......@@ -161,21 +157,18 @@ getTyVar :: String -> Type -> TyVar
getTyVar msg (TyVarTy tv) = tv
getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p)
getTyVar msg (NoteTy _ t) = getTyVar msg t
getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
getTyVar msg other = panic ("getTyVar: " ++ msg)
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe (TyVarTy tv) = Just tv
getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p)
getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
getTyVar_maybe other = Nothing
isTyVarTy :: Type -> Bool
isTyVarTy (TyVarTy tv) = True
isTyVarTy (NoteTy _ ty) = isTyVarTy ty
isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p)
isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
isTyVarTy other = False
\end{code}
......@@ -190,13 +183,10 @@ invariant: use it.
\begin{code}
mkAppTy orig_ty1 orig_ty2
= ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
-- argument must be unannotated
mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
mk_app ty1 = AppTy orig_ty1 orig_ty2
mkAppTys :: Type -> [Type] -> Type
......@@ -208,17 +198,14 @@ mkAppTys orig_ty1 [] = orig_ty1
-- the Rational part.
mkAppTys orig_ty1 orig_tys2
= ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
-- arguments must be unannotated
mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
splitAppTy_maybe :: Type -> Maybe (Type, Type)
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p)
......@@ -228,7 +215,6 @@ splitAppTy_maybe (TyConApp tc tys) = split tys []
split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
split (ty:tys) acc = split tys (ty:acc)
splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
splitAppTy_maybe other = Nothing
splitAppTy :: Type -> (Type, Type)
......@@ -243,9 +229,8 @@ splitAppTys ty = split ty ty []
split orig_ty (NoteTy _ ty) args = split orig_ty ty args
split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args
split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
(TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
(TyConApp funTyCon [], [ty1,ty2])
split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
split orig_ty ty args = (orig_ty, args)
\end{code}
......@@ -256,24 +241,20 @@ splitAppTys ty = split ty ty []
\begin{code}
mkFunTy :: Type -> Type -> Type
mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
FunTy arg res
mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
foldr FunTy ty tys
mkFunTys tys ty = foldr FunTy ty tys
splitFunTy :: Type -> (Type, Type)