mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
- mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN,
+ mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
funResultTy, funArgTy, zipFunTys,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
- mkDictTy, splitDictTy_maybe, isDictTy,
+ mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
- mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
+ mkSynTy, isSynTy, deNoteType,
+
+ repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
- mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
+ mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- isForAllTy, applyTy, applyTys, mkPiType,
+ isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys,
- TauType, RhoType, SigmaType, ThetaType,
- isTauTy,
- mkRhoTy, splitRhoTy,
+ TauType, RhoType, SigmaType, PredType(..), ThetaType,
+ ClassPred, ClassContext, mkClassPred,
+ getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
+ isTauTy, mkRhoTy, splitRhoTy,
mkSigmaTy, splitSigmaTy,
-- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
- typePrimRep,
-- Free variables
- tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
- addFreeTyVars,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
+ namesOfType, typeKind, addFreeTyVars,
-- Tidying up for printing
tidyType, tidyTypes,
-- Other imports:
-import {-# SOURCE #-} DataCon( DataCon, dataConType )
-import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
+import {-# SOURCE #-} DataCon( DataCon, dataConRepType )
+import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
-import Var ( TyVar, IdOrTyVar, UVar,
+import Var ( TyVar, Var, UVar,
tyVarKind, tyVarName, setTyVarName, isId, idType,
)
import VarEnv
import VarSet
-import Name ( NamedThing(..), mkLocalName, tidyOccName,
+import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
)
import NameSet
import Class ( classTyCon, Class )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isDataTyCon, isNewTyCon,
+ isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
tyConPrimRep, tyConClass_maybe
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr FunTy ty tys
+splitFunTy :: Type -> (Type, Type)
+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
splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
- | isAlgTyCon tc &&
+ | isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
splitAlgTyConApp_maybe other = Nothing
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = TyConApp (classTyCon clas) tys
+mkPredTy :: PredType -> Type
+mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys
+mkPredTy (IParam n ty) = NoteTy (IPNote n) ty
+
+{-
splitDictTy_maybe :: Type -> Maybe (Class, [Type])
splitDictTy_maybe (TyConApp tc tys)
| maybeToBool maybe_class
splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
splitDictTy_maybe other = Nothing
+-}
+
+splitPredTy_maybe :: Type -> Maybe PredType
+splitPredTy_maybe (TyConApp tc tys)
+ | maybeToBool maybe_class
+ && tyConArity tc == length tys = Just (Class clas tys)
+ where
+ maybe_class = tyConClass_maybe tc
+ Just clas = maybe_class
+
+splitPredTy_maybe (NoteTy (IPNote n) ty)
+ = Just (IParam n ty)
+splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
+splitPredTy_maybe other = Nothing
+
+splitDictTy_maybe :: Type -> Maybe (Class, [Type])
+splitDictTy_maybe ty
+ = case splitPredTy_maybe ty of
+ Just p -> getClassTys_maybe p
+ Nothing -> Nothing
isDictTy :: Type -> Bool
-- This version is slightly more efficient than (maybeToBool . splitDictTy)
interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
+ Representation types
+ ~~~~~~~~~~~~~~~~~~~~
repType looks through
(a) for-alls, and
(b) newtypes
-in addition to synonyms. It's useful in the back end where we're not
+ (c) synonyms
+It's useful in the back end where we're not
interested in newtypes anymore.
\begin{code}
repType :: Type -> Type
-repType (NoteTy _ ty) = repType ty
-repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys)
-repType other_ty = other_ty
+repType (ForAllTy _ ty) = repType ty
+repType (NoteTy _ ty) = repType ty
+repType ty = case splitNewType_maybe ty of
+ Just ty' -> repType ty' -- Still re-apply repType in case of for-all
+ Nothing -> ty
+
+splitRepFunTys :: Type -> ([Type], Type)
+-- Like splitFunTys, but looks through newtypes and for-alls
+splitRepFunTys ty = split [] (repType ty)
+ where
+ split args (FunTy arg res) = split (arg:args) (repType res)
+ split args ty = (reverse args, ty)
+
+typePrimRep :: Type -> PrimRep
+typePrimRep ty = case repType ty of
+ TyConApp tc _ -> tyConPrimRep tc
+ FunTy _ _ -> PtrRep
+ AppTy _ _ -> PtrRep -- ??
+ TyVarTy _ -> PtrRep
splitNewType_maybe :: Type -> Maybe Type
-- Find the representation of a newtype, if it is one
--- Looks through multiple levels of newtype
-splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
-splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
- Just rep_ty' -> Just rep_ty'
- Nothing -> Just rep_ty
- where
- rep_ty = new_type_rep tc tys
-
-splitNewType_maybe other = Nothing
-
-new_type_rep :: TyCon -> [Type] -> Type
--- The representation type for (T t1 .. tn), where T is a newtype
--- Looks through one layer only
-new_type_rep tc tys
- = ASSERT( isNewTyCon tc )
- case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
- Just (rep_ty, _) -> rep_ty
+-- Looks through multiple levels of newtype, but does not look through for-alls
+splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
+splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
+ Just rep_ty -> ASSERT( length tys == tyConArity tc )
+ -- The assert should hold because repType should
+ -- only be applied to *types* (of kind *)
+ Just (applyTys rep_ty tys)
+ Nothing -> Nothing
+splitNewType_maybe other = Nothing
\end{code}
it is given a type variable or a term variable.
\begin{code}
-mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
+mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
mkPiType v ty | isId v = mkFunTy (idType v) ty
| otherwise = mkForAllTy v ty
\end{code}
extension: we handle them by lifting the annotation outside. The
argument, however, must still be unannotated.
+\begin{code}
+hoistForAllTys :: Type -> Type
+ -- Move all the foralls to the top
+ -- e.g. T -> forall a. a ==> forall a. T -> a
+hoistForAllTys ty
+ = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
+ where
+ hoist :: Type -> ([TyVar], Type)
+ hoist ty = case splitFunTys ty of { (args, res) ->
+ case splitForAllTys res of {
+ ([], body) -> ([], ty) ;
+ (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
+ (tvs1 ++ tvs2, mkFunTys args body2)
+ }}}
+\end{code}
+
%************************************************************************
%* *
\subsection{Stuff to do with the source-language types}
+
+PredType and ThetaType are used in types for expressions and bindings.
+ClassPred and ClassContext are used in class and instance declarations.
%* *
%************************************************************************
\begin{code}
type RhoType = Type
type TauType = Type
-type ThetaType = [(Class, [Type])]
+data PredType = Class Class [Type]
+ | IParam Name Type
+type ThetaType = [PredType]
+type ClassPred = (Class, [Type])
+type ClassContext = [ClassPred]
type SigmaType = Type
\end{code}
+\begin{code}
+instance Outputable PredType where
+ ppr = pprPred
+\end{code}
+
+\begin{code}
+mkClassPred clas tys = Class clas tys
+
+getClassTys_maybe :: PredType -> Maybe ClassPred
+getClassTys_maybe (Class clas tys) = Just (clas, tys)
+getClassTys_maybe _ = Nothing
+
+ipName_maybe :: PredType -> Maybe Name
+ipName_maybe (IParam n _) = Just n
+ipName_maybe _ = Nothing
+
+classesToPreds cts = map (uncurry Class) cts
+
+classesOfPreds theta = concatMap cvt theta
+ where cvt (Class clas tys) = [(clas, tys)]
+ cvt (IParam _ _ ) = []
+\end{code}
+
@isTauTy@ tests for nested for-alls.
\begin{code}
\end{code}
\begin{code}
-mkRhoTy :: [(Class, [Type])] -> Type -> Type
-mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
+mkRhoTy :: [PredType] -> Type -> Type
+mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
-splitRhoTy :: Type -> ([(Class, [Type])], Type)
+splitRhoTy :: Type -> ([PredType], Type)
splitRhoTy ty = split ty ty []
where
- split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
- Just pair -> split res res (pair:ts)
+ 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)
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
-splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
+splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
splitSigmaTy ty =
(tyvars, theta, tau)
where
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
+tyVarsOfType (NoteTy (IPNote _) ty) = tyVarsOfType ty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+tyVarsOfPred :: PredType -> TyVarSet
+tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
+tyVarsOfPred (IParam n ty) = tyVarsOfType ty
+
+tyVarsOfTheta :: ThetaType -> TyVarSet
+tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
+
-- Add a Note with the free tyvars to the top of the type
-- (but under a usage if there is one)
addFreeTyVars :: Type -> Type
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
go_note note@(UsgNote _) = note -- Usage annotation is already tidy
go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
+ go_note (IPNote n) = IPNote (tidyIPName n)
tidyTypes env tys = map (tidyType env) tys
\end{code}
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
+\begin{code}
+tidyIPName :: Name -> Name
+tidyIPName name
+ = mkLocalName (getUnique name) (getOccName name) noSrcLoc
+\end{code}
+
%************************************************************************
%* *
Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
isNewTyCon tc
other -> False
-
-typePrimRep :: Type -> PrimRep
-typePrimRep ty = case splitTyConApp_maybe (repType ty) of
- Just (tc, ty_args) -> tyConPrimRep tc
- other -> PtrRep
\end{code}
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqNote (UsgNote usg) = usg `seq` ()
+seqNote (IPNote nm) = nm `seq` ()
\end{code}
projects / ghc-hetmet.git / blobdiff