\begin{code}
module TcType (
--------------------------------
+ -- TyThing
+ TyThing(..), -- instance NamedThing
+
+ --------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind,
tcSplitForAllTys, tcSplitPhiTy,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
- tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
---------------------------------
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
- typeKind, eqKind, eqUsage,
+ typeKind, eqKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
) where
import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
import Type ( -- Re-exports
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- Kind, Type, SourceType(..), PredType, ThetaType,
- unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
- mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ tyVarsOfTheta, Kind, Type, SourceType(..),
+ PredType, ThetaType, unliftedTypeKind,
+ liftedTypeKind, openTypeKind, mkArrowKind,
+ mkArrowKinds, mkForAllTy, mkForAllTys,
+ defaultKind, isTypeKind, isAnyTypeKind,
mkFunTy, mkFunTys, zipFunTys, isTyVarTy,
- mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
- mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
- isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
+ mkTyConApp, mkGenTyConApp, mkAppTy,
+ mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
+ mkPredTys, isUnLiftedType,
+ isUnboxedTupleType, isPrimitiveType,
splitNewType_maybe, splitTyConApp_maybe,
- tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
- tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage,
- hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
+ tidyTopType, tidyType, tidyPred, tidyTypes,
+ tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
+ tidyTyVarBndr, tidyOpenTyVar,
+ tidyOpenTyVars, eqKind,
+ hasMoreBoxityInfo, liftedBoxity,
+ superBoxity, typeKind, superKind, repType
)
+import DataCon ( DataCon )
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
-import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
+import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
import ForeignCall ( Safety, playSafe )
import VarEnv
import VarSet
import BasicTypes ( IPName(..), ipNameName )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
-import Util ( cmpList, thenCmp, equalLength )
+import Util ( cmpList, thenCmp, equalLength, snocView )
import Maybes ( maybeToBool, expectJust )
import Outputable
\end{code}
%************************************************************************
%* *
+ TyThing
+%* *
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId Id
+ | ADataCon DataCon
+ | ATyCon TyCon
+ | AClass Class
+
+instance NamedThing TyThing where
+ getName (AnId id) = getName id
+ getName (ATyCon tc) = getName tc
+ getName (AClass cl) = getName cl
+ getName (ADataCon dc) = getName dc
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Types}
%* *
%************************************************************************
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 (SourceTy (NType tc tys)) = tc_split_app tc tys
- --- Don't forget that newtype!
+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
tcSplitAppTy_maybe other = Nothing
-tc_split_app tc [] = Nothing
-tc_split_app tc tys = split tys []
- where
- split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
- split (ty:tys) acc = split tys (ty:acc)
+tc_split_app tc tys = case snocView tys of
+ Just (tys',ty') -> Just (TyConApp tc tys', ty')
+ Nothing -> Nothing
tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
+tcSplitAppTys :: Type -> (Type, [Type])
+tcSplitAppTys ty
+ = go ty []
+ where
+ go ty args = case tcSplitAppTy_maybe ty of
+ Just (ty', arg) -> go ty' (arg:args)
+ Nothing -> (ty,args)
+
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe (TyVarTy tv) = Just tv
tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
where sig_ty is the type given by the method's signature, and thus in general
is a ForallTy. At the point that splitMethodTy is called, it is expected
that the outer Forall has already been stripped off. splitMethodTy then
-returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
-Usages stripped off.
+returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
\begin{code}
tcSplitMethodTy :: Type -> (PredType, Type)
-- Non-recursive ones are transparent to splitTyConApp,
-- but recursive ones aren't; hence the splitNewType_maybe
checkRepTyCon check_tc ty
- | Just ty' <- splitNewType_maybe ty = checkRepTyCon check_tc ty'
- | Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc
- | otherwise = False
+ | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
+ | otherwise = False
\end{code}
----------------------------------------------
projects / ghc-hetmet.git / blobdiff