X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=8271ce32f389168eac64f3219f2002b90aef3ae9;hb=938f825c4c3aac524459a801816db10718dff9de;hp=a6a6d679cdd9d00f9f3a64f844e48f3960010ed7;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index a6a6d67..8271ce3 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,637 +1,905 @@ -\begin{code} -#include "HsVersions.h" +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[Type]{Type - public interface} +\begin{code} module Type ( - GenType(..), Type(..), TauType(..), - mkTyVarTy, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, - mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe, - mkTyConTy, getTyCon_maybe, applyTyCon, - mkSynTy, - mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy, - mkForAllUsageTy, getForAllUsageTy, - applyTy, - - isPrimType, - - RhoType(..), SigmaType(..), ThetaType(..), - mkDictTy, - mkRhoTy, splitRhoTy, - mkSigmaTy, splitSigmaTy, + -- re-exports from TypeRep: + Type, + Kind, TyVarSubst, - maybeAppTyCon, getAppTyCon, - maybeAppDataTyCon, getAppDataTyCon, - maybeBoxedPrimType, + superKind, superBoxity, -- :: SuperKind - matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta, + boxedKind, -- :: Kind :: BX + anyBoxKind, -- :: Kind :: BX + typeCon, -- :: KindCon :: BX -> KX + anyBoxCon, -- :: KindCon :: BX - instantiateTy,instantiateUsage, + boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind - isTauTy, + mkArrowKind, mkArrowKinds, -- mentioned below: hasMoreBoxityInfo, - tyVarsOfType, tyVarsOfTypes, getTypeKind + funTyCon, + -- exports from this module: + hasMoreBoxityInfo, -) where + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking -import PrelLoop -- for paranoia checking + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, --- friends: -import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} ) -import Kind ( mkBoxedTypeKind, resultKind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, - getTyConKind, getTyConDataCons, TyCon ) -import TyVar ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), - emptyTyVarSet, unionTyVarSets, minusTyVarSet, - singletonTyVarSet, nullTyVarEnv, lookupTyVarEnv, - addOneToTyVarEnv, TyVarEnv(..) ) -import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..), - nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, - eqUsage ) + mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN, + funResultTy, funArgTy, zipFunTys, --- others -import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, - Ord3(..){-instances-} - ) -\end{code} + mkTyConApp, mkTyConTy, splitTyConApp_maybe, + splitAlgTyConApp_maybe, splitAlgTyConApp, + mkDictTy, splitDictTy_maybe, isDictTy, -Data types -~~~~~~~~~~ + mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe, -\begin{code} -type Type = GenType TyVar UVar -- Used after typechecker - -data GenType tyvar uvar -- Parameterised over type and usage variables - = TyVarTy tyvar - - | AppTy - (GenType tyvar uvar) - (GenType tyvar uvar) - - | TyConTy -- Constants of a specified kind - TyCon - (GenUsage uvar) -- Usage gives uvar of the full application, - -- iff the full application is of kind Type - -- c.f. the Usage field in TyVars - - | SynTy -- Synonyms must be saturated, and contain their expansion - TyCon -- Must be a SynTyCon - [GenType tyvar uvar] - (GenType tyvar uvar) -- Expansion! - - | ForAllTy - tyvar - (GenType tyvar uvar) -- TypeKind - - | ForAllUsageTy - uvar -- Quantify over this - [uvar] -- Bounds; the quantified var must be - -- less than or equal to all these - (GenType tyvar uvar) - - -- Two special cases that save a *lot* of administrative - -- overhead: - - | FunTy -- BoxedTypeKind - (GenType tyvar uvar) -- Both args are of TypeKind - (GenType tyvar uvar) - (GenUsage uvar) - - | DictTy -- TypeKind - Class -- Class - (GenType tyvar uvar) -- Arg has kind TypeKind - (GenUsage uvar) -\end{code} + UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, + mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, -\begin{code} -type RhoType = Type -type TauType = Type -type ThetaType = [(Class, Type)] -type SigmaType = Type -\end{code} + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + isForAllTy, applyTy, applyTys, mkPiType, + TauType, RhoType, SigmaType, ThetaType, + isTauTy, + mkRhoTy, splitRhoTy, + mkSigmaTy, splitSigmaTy, -Expand abbreviations -~~~~~~~~~~~~~~~~~~~~ -Removes just the top level of any abbreviations. + -- Lifting and boxity + isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType, + typePrimRep, -\begin{code} -expandTy :: Type -> Type -- Restricted to Type due to Dict expansion + -- Free variables + tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + addFreeTyVars, + + -- Tidying up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyTyVar, tidyTyVars, + tidyTopType, + + -- Seq + seqType, seqTypes + + ) where + +#include "HsVersions.h" + +-- We import the representation and primitive functions from TypeRep. +-- Many things are reexported, but not the representation! + +import TypeRep -expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2 -expandTy (SynTy _ _ t) = expandTy t -expandTy (DictTy clas ty u) - = case all_arg_tys of +-- Other imports: - [arg_ty] -> expandTy arg_ty -- just the itself +import {-# SOURCE #-} DataCon( DataCon, dataConType ) +import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages +import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy ) - -- The extra expandTy is to make sure that - -- the result isn't still a dict, which it might be - -- if the original guy was a dict with one superdict and - -- no methods! +-- friends: +import Var ( TyVar, IdOrTyVar, UVar, + tyVarKind, tyVarName, setTyVarName, isId, idType, + ) +import VarEnv +import VarSet - other -> ASSERT(not (null all_arg_tys)) - foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys +import Name ( NamedThing(..), mkLocalName, tidyOccName, + ) +import NameSet +import Class ( classTyCon, Class ) +import TyCon ( TyCon, + isUnboxedTupleTyCon, isUnLiftedTyCon, + isFunTyCon, isDataTyCon, isNewTyCon, + isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, tyConDataCons, getSynTyConDefn, + tyConPrimRep, tyConClass_maybe + ) - -- A tuple of 'em - -- Note: length of all_arg_tys can be 0 if the class is - -- _CCallable, _CReturnable (and anything else - -- *really weird* that the user writes). +-- others +import SrcLoc ( noSrcLoc ) +import Maybes ( maybeToBool ) +import PrimRep ( PrimRep(..), isFollowableRep ) +import Unique ( Uniquable(..) ) +import Util ( mapAccumL, seqList ) +import Outputable +import UniqSet ( sizeUniqSet ) -- Should come via VarSet +\end{code} + + +%************************************************************************ +%* * +\subsection{Stuff to do with kinds.} +%* * +%************************************************************************ + +\begin{code} +hasMoreBoxityInfo :: Kind -> Kind -> Bool +hasMoreBoxityInfo k1 k2 + | k2 == openTypeKind = ASSERT( is_type_kind k1) True + | otherwise = k1 == k2 where - (tyvar, super_classes, ops) = getClassSig clas - super_dict_tys = map mk_super_ty super_classes - class_op_tys = map mk_op_ty ops - all_arg_tys = super_dict_tys ++ class_op_tys - mk_super_ty sc = DictTy sc ty usageOmega - mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op) - -expandTy ty = ty + -- Returns true for things of form (Type x) + is_type_kind k = case splitTyConApp_maybe k of + Just (tc,[_]) -> tc == typeCon + Nothing -> False \end{code} -Simple construction and analysis functions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +%************************************************************************ +%* * +\subsection{Constructor-specific functions} +%* * +%************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ \begin{code} -mkTyVarTy :: t -> GenType t u -mkTyVarTy = TyVarTy --- could we use something for (map mkTyVarTy blahs) ?? WDP +mkTyVarTy :: TyVar -> Type +mkTyVarTy = TyVarTy -getTyVar :: String -> GenType t u -> t +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +getTyVar :: String -> Type -> TyVar getTyVar msg (TyVarTy tv) = tv -getTyVar msg (SynTy _ _ t) = getTyVar msg t -getTyVar msg other = error ("getTyVar" ++ msg) +getTyVar msg (NoteTy _ t) = getTyVar msg t +getTyVar msg other = panic ("getTyVar: " ++ msg) -getTyVar_maybe :: GenType t u -> Maybe t +getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t -getTyVar_maybe other = Nothing +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe other = Nothing -isTyVarTy :: GenType t u -> Bool +isTyVarTy :: Type -> Bool isTyVarTy (TyVarTy tv) = True -isTyVarTy (SynTy _ _ t) = isTyVarTy t -isTyVarTy other = False +isTyVarTy (NoteTy _ ty) = isTyVarTy ty +isTyVarTy other = False \end{code} -\begin{code} -mkAppTy = AppTy -mkAppTys :: GenType t u -> [GenType t u] -> GenType t u -mkAppTys t ts = foldl AppTy t ts +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. -splitAppTy :: GenType t u -> (GenType t u, [GenType t u]) -splitAppTy t = go t [] +\begin{code} +mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 ) + mk_app orig_ty1 + where + mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) + mk_app ty1 = AppTy orig_ty1 orig_ty2 + +mkAppTys :: Type -> [Type] -> Type +mkAppTys orig_ty1 [] = orig_ty1 + -- This check for an empty list of type arguments + -- avoids the needless of a type synonym constructor. + -- For example: mkAppTys Rational [] + -- returns to (Ratio Integer), which has needlessly lost + -- the Rational part. +mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 ) + mk_app orig_ty1 where - go (AppTy t arg) ts = go t (arg:ts) - go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (t,ts) + mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) + mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) ) + foldl AppTy orig_ty1 orig_tys2 + +splitAppTy_maybe :: Type -> Maybe (Type, Type) +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 (TyConApp tc []) = Nothing +splitAppTy_maybe (TyConApp tc tys) = split tys [] + where + split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) + split (ty:tys) acc = split tys (ty:acc) + +splitAppTy_maybe other = Nothing + +splitAppTy :: Type -> (Type, Type) +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +splitAppTys :: Type -> (Type, [Type]) +splitAppTys ty = split ty ty [] + where + split orig_ty (AppTy ty arg) args = split ty ty (arg:args) + split orig_ty (NoteTy _ ty) args = split orig_ty ty args + split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) + (TyConApp funTyCon [], [ty1,ty2]) + split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) + split orig_ty ty args = (orig_ty, args) \end{code} + +--------------------------------------------------------------------- + FunTy + ~~~~~ + \begin{code} --- NB mkFunTy, mkFunTys puts in Omega usages, for now at least -mkFunTy arg res = FunTy arg res usageOmega +mkFunTy :: Type -> Type -> Type +mkFunTy arg res = FunTy arg res + +mkFunTys :: [Type] -> Type -> Type +mkFunTys tys ty = foldr FunTy ty tys -mkFunTys :: [GenType t u] -> GenType t u -> GenType t u -mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts +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 -getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u) -getFunTy_maybe (FunTy arg result _) = Just (arg,result) -getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res) - | isFunTyCon tycon = Just (arg, res) -getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t -getFunTy_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 _ ty) = split args orig_ty ty + split args orig_ty ty = (reverse args, orig_ty) + +splitFunTysN :: String -> Int -> Type -> ([Type], Type) +splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty + where + split 0 args syn_ty ty = (reverse args, syn_ty) + split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res + split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty + split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty) -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -splitFunTy t = go t [] +zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) +zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where - go (FunTy arg res _) ts = go res (arg:ts) - go (AppTy (AppTy (TyConTy tycon _) arg) res) ts - | isFunTyCon tycon - = go res (arg:ts) - go (SynTy _ _ t) ts - = go t ts - go t ts - = (reverse ts, t) + split acc [] nty ty = (reverse acc, nty) + split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res + split acc xs nty (NoteTy _ ty) = split acc xs nty ty + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) + +funResultTy :: Type -> Type +funResultTy (FunTy arg res) = res +funResultTy (NoteTy _ ty) = funResultTy ty +funResultTy ty = pprPanic "funResultTy" (pprType ty) + +funArgTy :: Type -> Type +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy ty = pprPanic "funArgTy" (pprType ty) \end{code} + +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ + \begin{code} --- NB applyTyCon puts in usageOmega, for now at least -mkTyConTy tycon = TyConTy tycon usageOmega +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon && length tys == 2 + = case tys of + (ty1:ty2:_) -> FunTy ty1 ty2 + + | otherwise + = ASSERT(not (isSynTyCon tycon)) + TyConApp tycon tys + +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) + TyConApp tycon [] + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- 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 + +-- splitAlgTyConApp_maybe looks for +-- *saturated* applications of *algebraic* data types +-- "Algebraic" => newtype, data type, or dictionary (not function types) +-- We return the constructors too. + +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 _ ty) = splitAlgTyConApp_maybe ty +splitAlgTyConApp_maybe other = Nothing + +splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) + -- Here the "algebraic" property is an *assertion* +splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) + (tc, tys, tyConDataCons tc) +splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty +\end{code} + +"Dictionary" types are just ordinary data types, but you can +tell from the type constructor whether it's a dictionary or not. -applyTyCon :: TyCon -> [GenType t u] -> GenType t u -applyTyCon tycon tys = foldl AppTy (TyConTy tycon usageOmega) tys +\begin{code} +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = TyConApp (classTyCon clas) tys -getTyCon_maybe :: GenType t u -> Maybe TyCon -getTyCon_maybe (TyConTy tycon _) = Just tycon -getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t -getTyCon_maybe other_ty = Nothing +splitDictTy_maybe :: Type -> Maybe (Class, [Type]) +splitDictTy_maybe (TyConApp tc tys) + | maybeToBool maybe_class + && tyConArity tc == length tys = Just (clas, tys) + where + maybe_class = tyConClass_maybe tc + Just clas = maybe_class + +splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty +splitDictTy_maybe other = Nothing + +isDictTy :: Type -> Bool + -- This version is slightly more efficient than (maybeToBool . splitDictTy) +isDictTy (TyConApp tc tys) + | maybeToBool (tyConClass_maybe tc) + && tyConArity tc == length tys + = True +isDictTy (NoteTy _ ty) = isDictTy ty +isDictTy other = False \end{code} +--------------------------------------------------------------------- + SynTy + ~~~~~ + \begin{code} mkSynTy syn_tycon tys - = SynTy syn_tycon tys (panic "Type.mkSynTy:expansion") + = ASSERT( isSynTyCon syn_tycon ) + ASSERT( isNotUsgTy body ) + ASSERT( length tyvars == length tys ) + NoteTy (SynNote (TyConApp syn_tycon tys)) + (substTy (mkTyVarSubst tyvars tys) body) + where + (tyvars, body) = getSynTyConDefn syn_tycon + +isSynTy (NoteTy (SynNote _) _) = True +isSynTy other = False + +deNoteType :: Type -> Type + -- Sorry for the cute name +deNoteType ty@(TyVarTy tyvar) = ty +deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) +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) \end{code} -Tau stuff -~~~~~~~~~ +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms whereever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. + + + +repType looks through + (a) for-alls, and + (b) newtypes +in addition to synonyms. It's useful in the back end where we're not +interested in newtypes anymore. + \begin{code} -isTauTy :: GenType t u -> Bool -isTauTy (TyVarTy v) = True -isTauTy (TyConTy _ _) = True -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b _) = isTauTy a && isTauTy b -isTauTy (SynTy _ _ ty) = isTauTy ty -isTauTy other = False +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 + +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 \end{code} -Rho stuff -~~~~~~~~~ -NB mkRhoTy and mkDictTy put in usageOmega, for now at least + + +--------------------------------------------------------------------- + UsgNote + ~~~~~~~ + +NB: Invariant: if present, usage note is at the very top of the type. +This should be carefully preserved. + +In some parts of the compiler, comments use the _Once Upon a +Polymorphic Type_ (POPL'99) usage of "rho = generalised +usage-annotated type; sigma = usage-annotated type; tau = +usage-annotated type except on top"; unfortunately this conflicts with +the rho/tau/theta/sigma usage in the rest of the compiler. (KSW +1999-07) \begin{code} -mkDictTy :: Class -> GenType t u -> GenType t u -mkDictTy clas ty = DictTy clas ty usageOmega +mkUsgTy :: UsageAnn -> Type -> Type +#ifndef USMANY +mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty ) + ty +#endif +mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty ) + NoteTy (UsgNote usg) ty + +-- The isUsgTy function is utterly useless if UsManys are omitted. +-- Be warned! KSW 1999-04. +isUsgTy :: Type -> Bool +#ifndef USMANY +isUsgTy _ = True +#else +isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty +isUsgTy (NoteTy (UsgNote _) _ ) = True +isUsgTy other = False +#endif -mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u -mkRhoTy theta ty = - foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta +-- The isNotUsgTy function may return a false True if UsManys are omitted; +-- in other words, A SSERT( isNotUsgTy ty ) may be useful but +-- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04. +isNotUsgTy :: Type -> Bool +isNotUsgTy (NoteTy (UsgForAll _) _) = False +isNotUsgTy (NoteTy (UsgNote _) _) = False +isNotUsgTy other = True + +-- splitUsgTy_maybe is not exported, since it is meaningless if +-- UsManys are omitted. It is used in several places in this module, +-- however. KSW 1999-04. +splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type) +splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 ) + Just (usg,ty2) +splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty +splitUsgTy_maybe ty = Nothing + +splitUsgTy :: Type -> (UsageAnn,Type) +splitUsgTy ty = case splitUsgTy_maybe ty of + Just ans -> ans + Nothing -> +#ifndef USMANY + (UsMany,ty) +#else + pprPanic "splitUsgTy: no usage annot:" $ pprType ty +#endif -splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u) -splitRhoTy t = - go t [] - where - go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts) - go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts - | isFunTyCon tycon - = go r ((c,t):ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (reverse ts, t) +tyUsg :: Type -> UsageAnn +tyUsg = fst . splitUsgTy + +unUsgTy :: Type -> Type +-- strip outer usage annotation if present +unUsgTy ty = case splitUsgTy_maybe ty of + Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty ) + ty1 + Nothing -> ty + +mkUsForAllTy :: UVar -> Type -> Type +mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty + +mkUsForAllTys :: [UVar] -> Type -> Type +mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs + +splitUsForAllTys :: Type -> ([UVar],Type) +splitUsForAllTys ty = split ty [] + where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs) + split other_ty uvs = (reverse uvs, other_ty) + +substUsTy :: VarEnv UsageAnn -> Type -> Type +-- assumes range is fresh uvars, so no conflicts +substUsTy ve (NoteTy note@(UsgNote (UsVar u)) + ty ) = NoteTy (case lookupVarEnv ve u of + Just ua -> UsgNote ua + Nothing -> note) + (substUsTy ve ty) +substUsTy ve (NoteTy note@(UsgNote _) ty ) = NoteTy note (substUsTy ve ty) +substUsTy ve (NoteTy note@(UsgForAll _) ty ) = NoteTy note (substUsTy ve ty) +substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) + (substUsTy ve ty2) +substUsTy ve (NoteTy note@(FTVNote _) ty ) = NoteTy note (substUsTy ve ty) +substUsTy ve ty@(TyVarTy _ ) = ty +substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1) + (substUsTy ve ty2) +substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1) + (substUsTy ve ty2) +substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys) +substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty) \end{code} -Forall stuff -~~~~~~~~~~~~ +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ + +We need to be clever here with usage annotations; they need to be +lifted or lowered through the forall as appropriate. + \begin{code} -mkForAllTy = ForAllTy - -mkForAllTys :: [t] -> GenType t u -> GenType t u -mkForAllTys tyvars ty = foldr ForAllTy ty tyvars - -getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u) -getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t -getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t) -getForAllTy_maybe _ = Nothing - -splitForAllTy :: GenType t u-> ([t], GenType t u) -splitForAllTy t = go t [] - where - go (ForAllTy tv t) tvs = go t (tv:tvs) - go (SynTy _ _ t) tvs = go t tvs - go t tvs = (reverse tvs, t) +mkForAllTy :: TyVar -> Type -> Type +mkForAllTy tyvar ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> NoteTy (UsgNote usg) + (ForAllTy tyvar ty') + Nothing -> ForAllTy tyvar ty + +mkForAllTys :: [TyVar] -> Type -> Type +mkForAllTys tyvars ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> NoteTy (UsgNote usg) + (foldr ForAllTy ty' tyvars) + Nothing -> foldr ForAllTy ty tyvars + +splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTy_maybe ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty' + 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 + +splitForAllTys :: Type -> ([TyVar], Type) +splitForAllTys ty = case splitUsgTy_maybe ty of + Just (usg,ty') -> let (tvs,ty'') = split ty' ty' [] + 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) \end{code} -\begin{code} -mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u -mkForAllUsageTy = ForAllUsageTy +@mkPiType@ makes a (->) type or a forall type, depending on whether +it is given a type variable or a term variable. -getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u) -getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t) -getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t -getForAllUsageTy _ = Nothing +\begin{code} +mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work... +mkPiType v ty | isId v = mkFunTy (idType v) ty + | otherwise = mkForAllTy v ty \end{code} -Applied tycons (includes FunTyCons) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Applying a for-all to its arguments + \begin{code} -maybeAppTyCon - :: GenType tyvar uvar - -> Maybe (TyCon, -- the type constructor - [GenType tyvar uvar]) -- types to which it is applied - -maybeAppTyCon ty - = case (getTyCon_maybe app_ty) of - Nothing -> Nothing - Just tycon -> Just (tycon, arg_tys) - where - (app_ty, arg_tys) = splitAppTy ty +applyTy :: Type -> Type -> Type +applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg) +applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg) +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg ) + substTy (mkTyVarSubst [tv] [arg]) ty +applyTy other arg = panic "applyTy" + +applyTys :: Type -> [Type] -> Type +applyTys fun_ty arg_tys + = substTy (mkTyVarSubst tvs arg_tys) ty + where + (tvs, ty) = split fun_ty arg_tys + + split fun_ty [] = ([], fun_ty) + split (NoteTy note@(UsgNote _) fun_ty) + args = case split fun_ty args of + (tvs, ty) -> (tvs, NoteTy note ty) + split (NoteTy note@(UsgForAll _) fun_ty) + args = case split fun_ty args of + (tvs, ty) -> (tvs, NoteTy note ty) + split (NoteTy _ fun_ty) args = split fun_ty args + split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$ + text "in application of" <+> pprType fun_ty) + case split fun_ty args of + (tvs, ty) -> (tv:tvs, ty) + split other_ty args = panic "applyTys" +\end{code} +Note that we allow applications to be of usage-annotated- types, as an +extension: we handle them by lifting the annotation outside. The +argument, however, must still be unannotated. -getAppTyCon - :: GenType tyvar uvar - -> (TyCon, -- the type constructor - [GenType tyvar uvar]) -- types to which it is applied -getAppTyCon ty - = case maybeAppTyCon ty of - Just stuff -> stuff -#ifdef DEBUG - Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty) -#endif -\end{code} +%************************************************************************ +%* * +\subsection{Stuff to do with the source-language types} +%* * +%************************************************************************ -Applied data tycons (give back constrs) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -maybeAppDataTyCon - :: GenType tyvar uvar - -> Maybe (TyCon, -- the type constructor - [GenType tyvar uvar], -- types to which it is applied - [Id]) -- its family of data-constructors - -maybeAppDataTyCon ty - = case (getTyCon_maybe app_ty) of - Nothing -> Nothing - Just tycon | isFunTyCon tycon - -> Nothing - | otherwise - -> Just (tycon, arg_tys, getTyConDataCons tycon) - where - (app_ty, arg_tys) = splitAppTy ty +type RhoType = Type +type TauType = Type +type ThetaType = [(Class, [Type])] +type SigmaType = Type +\end{code} +@isTauTy@ tests for nested for-alls. -getAppDataTyCon - :: GenType tyvar uvar - -> (TyCon, -- the type constructor - [GenType tyvar uvar], -- types to which it is applied - [Id]) -- its family of data-constructors +\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 +\end{code} -getAppDataTyCon ty - = case maybeAppDataTyCon ty of - Just stuff -> stuff -#ifdef DEBUG - Nothing -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty) -#endif +\begin{code} +mkRhoTy :: [(Class, [Type])] -> Type -> Type +mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta +splitRhoTy :: Type -> ([(Class, [Type])], 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) + 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) +\end{code} -maybeBoxedPrimType :: Type -> Maybe (Id, Type) -maybeBoxedPrimType ty - = case (maybeAppDataTyCon ty) of -- Data type, - Just (tycon, tys_applied, [data_con]) -- with exactly one constructor - -> case (getInstantiatedDataConSig data_con tys_applied) of - (_, [data_con_arg_ty], _) -- Applied to exactly one type, - | isPrimType data_con_arg_ty -- which is primitive - -> Just (data_con, data_con_arg_ty) - other_cases -> Nothing - other_cases -> Nothing -\end{code} \begin{code} -splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u) +mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) + +splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type) splitSigmaTy ty = (tyvars, theta, tau) where - (tyvars,rho) = splitForAllTy ty + (tyvars,rho) = splitForAllTys ty (theta,tau) = splitRhoTy rho - -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) \end{code} -Finding the kind of a type -~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -getTypeKind :: GenType (GenTyVar any) u -> Kind -getTypeKind (TyVarTy tyvar) = getTyVarKind tyvar -getTypeKind (TyConTy tycon usage) = getTyConKind tycon -getTypeKind (SynTy _ _ ty) = getTypeKind ty -getTypeKind (FunTy fun arg _) = mkBoxedTypeKind -getTypeKind (DictTy clas arg _) = mkBoxedTypeKind -getTypeKind (AppTy fun arg) = resultKind (getTypeKind fun) -getTypeKind (ForAllTy _ _) = mkBoxedTypeKind -getTypeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind -\end{code} - +%************************************************************************ +%* * +\subsection{Kinds and free variables} +%* * +%************************************************************************ -Free variables of a type -~~~~~~~~~~~~~~~~~~~~~~~~ +--------------------------------------------------------------------- + Finding the kind of a type + ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi - -tyVarsOfType (TyVarTy tv) = singletonTyVarSet tv -tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet -tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys -tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res -tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg -tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty -tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` singletonTyVarSet tyvar -tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty - -tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi -tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys -\end{code} +typeKind :: Type -> Kind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (NoteTy _ ty) = typeKind ty +typeKind (AppTy fun arg) = funResultTy (typeKind fun) -Instantiating a type -~~~~~~~~~~~~~~~~~~~~ -\begin{code} -applyTy :: Eq t => GenType t u -> GenType t u -> GenType t u -applyTy (SynTy _ _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty -applyTy other arg = panic "applyTy" +typeKind (FunTy arg res) = boxedTypeKind -- A function is boxed regardless of its result type + -- No functions at the type level, hence we don't need + -- to say (typeKind res). -instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u -instantiateTy tenv ty - = go ty - where - go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of - [] -> TyVarTy tv - (ty:_) -> ty - go ty@(TyConTy tycon usage) = ty - go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty) - go (FunTy arg res usage) = FunTy (go arg) (go res) usage - go (AppTy fun arg) = AppTy (go fun) (go arg) - go (DictTy clas ty usage) = DictTy clas (go ty) usage - go (ForAllTy tv ty) = ASSERT(null tv_bound) - ForAllTy tv (go ty) - where - tv_bound = [() | (tv',_) <- tenv, tv==tv'] - - go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty) - -instantiateUsage - :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' -instantiateUsage = error "instantiateUsage: not implemented" +typeKind (ForAllTy tv ty) = typeKind ty \end{code} + +--------------------------------------------------------------------- + Free variables of a type + ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -isPrimType :: GenType tyvar uvar -> Bool -isPrimType (AppTy ty _) = isPrimType ty -isPrimType (SynTy _ _ ty) = isPrimType ty -isPrimType (TyConTy tycon _) = isPrimTyCon tycon -isPrimType _ = False +tyVarsOfType :: Type -> TyVarSet + +tyVarsOfType (TyVarTy tv) = unitVarSet tv +tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys +tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs +tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1 +tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty +tyVarsOfType (NoteTy (UsgForAll _) 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 + +-- Add a Note with the free tyvars to the top of the type +-- (but under a usage if there is one) +addFreeTyVars :: Type -> Type +addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty) +addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty) +addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty +addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty + +-- Find the free names of a type, including the type constructors and classes it mentions +namesOfType :: Type -> NameSet +namesOfType (TyVarTy tv) = unitNameSet (getName tv) +namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` + namesOfTypes tys +namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 +namesOfType (NoteTy other_note ty2) = namesOfType ty2 +namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res +namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg +namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) + +namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys \end{code} + %************************************************************************ %* * -\subsection{Matching on types} +\subsection{TidyType} %* * %************************************************************************ -Matching is a {\em unidirectional} process, matching a type against a -template (which is just a type with type variables in it). The -matcher assumes that there are no repeated type variables in the -template, so that it simply returns a mapping of type variables to -types. It also fails on nested foralls. +tidyTy tidies up a type for printing in an error message, or in +an interface file. -@matchTys@ matches corresponding elements of a list of templates and -types. +It doesn't change the uniques at all, just the print names. \begin{code} -matchTy :: GenType t1 u1 -- Template - -> GenType t2 u2 -- Proposed instance of template - -> Maybe [(t1,GenType t2 u2)] -- Matching substitution +tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVar env@(tidy_env, subst) tyvar + = case lookupVarEnv subst tyvar of + + Just tyvar' -> -- Already substituted + (env, tyvar') + + Nothing -> -- Make a new nice name for it + + case tidyOccName tidy_env (getOccName name) of + (tidy', occ') -> -- New occname reqd + ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarName tyvar name' + name' = mkLocalName (getUnique name) occ' noSrcLoc + -- Note: make a *user* tyvar, so it printes nicely + -- Could extract src loc, but no need. + where + name = tyVarName tyvar -matchTys :: [GenType t1 u1] -- Templates - -> [GenType t2 u2] -- Proposed instance of template - -> Maybe [(t1,GenType t2 u2)] -- Matching substitution +tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars -matchTy ty1 ty2 = match [] [] ty1 ty2 -matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2) +tidyType :: TidyEnv -> Type -> Type +tidyType env@(tidy_env, subst) ty + = go ty + where + go (TyVarTy tv) = case lookupVarEnv subst tv of + Nothing -> TyVarTy tv + Just tv' -> TyVarTy tv' + go (TyConApp tycon tys) = let args = map go tys + in args `seqList` TyConApp tycon args + go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty) + go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg) + go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg) + go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) + where + (envp, tvp) = tidyTyVar env tv + + go_note (SynNote ty) = SynNote SAPPLY (go ty) + 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 + +tidyTypes env tys = map (tidyType env) tys \end{code} -@match@ is the main function. + +@tidyOpenType@ grabs the free type variables, tidies them +and then uses @tidyType@ to work over the type itself \begin{code} -match :: [(t1, GenType t2 u2)] -- r, the accumulating result - -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list - -> GenType t1 u1 -> GenType t2 u2 -- Current match pair - -> Maybe [(t1, GenType t2 u2)] - -match r w (TyVarTy v) ty = match' ((v,ty) : r) w -match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2 -match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2 -match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w -match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2 -match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2 -match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2 - - -- 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 - -- here! (WDP 95/05) - --- Catch-all fails -match _ _ _ _ = Nothing - -match' r [] = Just r -match' r ((ty1,ty2):w) = match r w ty1 ty2 +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType env' ty) + where + env' = foldl go env (varSetElems (tyVarsOfType ty)) + go env tyvar = fst (tidyTyVar env tyvar) + +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys + +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty \end{code} + %************************************************************************ %* * -\subsection{Equality on types} +\subsection{Boxedness and liftedness} %* * %************************************************************************ -The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t -and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see -dictionaries or polymorphic types). The function eqTy has a more -specific type, but does the `right thing' for all types. - \begin{code} -eqSimpleTheta :: (Eq t,Eq u) => - [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool - -eqSimpleTheta [] [] = True -eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) = - c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2 -eqSimpleTheta other1 other2 = False +isUnboxedType :: Type -> Bool +isUnboxedType ty = not (isFollowableRep (typePrimRep ty)) + +isUnLiftedType :: Type -> Bool + -- isUnLiftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them + +isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty +isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType other = False + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> isUnboxedTupleTyCon tc + other -> False + +-- Should only be applied to *types*; hence the assert +isAlgType :: Type -> Bool +isAlgType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isAlgTyCon tc + other -> False + +-- Should only be applied to *types*; hence the assert +isDataType :: Type -> Bool +isDataType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isDataTyCon tc + other -> False + +isNewType :: Type -> Bool +isNewType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isNewTyCon tc + other -> False + +typePrimRep :: Type -> PrimRep +typePrimRep ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> tyConPrimRep tc + other -> PtrRep \end{code} -\begin{code} -eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool - -(TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) = - tv1 == tv2 -(AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) = - f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 -(TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) = - tc1 == tc2 && u1 == u2 - -(FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) = - f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2 -(FunTy f1 a1 u1) `eqSimpleTy` t2 = - -- Expand t1 just in case t2 matches that version - (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2 -t1 `eqSimpleTy` (FunTy f2 a2 u2) = - -- Expand t2 just in case t1 matches that version - t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2) - -(SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) = - (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2) - || t1 `eqSimpleTy` t2 -(SynTy _ _ t1) `eqSimpleTy` t2 = - t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again -t1 `eqSimpleTy` (SynTy _ _ t2) = - t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again - -(DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy" -_ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy" - -(ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy" -_ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy" - -(ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy" -_ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy" - -_ `eqSimpleTy` _ = False -\end{code} -Types are ordered so we can sort on types in the renamer etc. DNT: Since -this class is also used in CoreLint and other such places, we DO expand out -Fun/Syn/Dict types (if necessary). +%************************************************************************ +%* * +\subsection{Sequencing on types +%* * +%************************************************************************ \begin{code} -eqTy :: Type -> Type -> Bool - -eqTy t1 t2 = - eq nullTyVarEnv nullUVarEnv t1 t2 - where - eq tve uve (TyVarTy tv1) (TyVarTy tv2) = - tv1 == tv2 || - case (lookupTyVarEnv tve tv1) of - Just tv -> tv == tv2 - Nothing -> False - eq tve uve (AppTy f1 a1) (AppTy f2 a2) = - eq tve uve f1 f2 && eq tve uve a1 a2 - eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) = - tc1 == tc2 && eqUsage uve u1 u2 - - eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) = - eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2 - eq tve uve (FunTy f1 a1 u1) t2 = - -- Expand t1 just in case t2 matches that version - eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2 - eq tve uve t1 (FunTy f2 a2 u2) = - -- Expand t2 just in case t1 matches that version - eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2) - - eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) = - c1 == c2 && eq tve uve t1 t2 && eqUsage uve u1 u2 - eq tve uve t1@(DictTy _ _ _) t2 = - eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again - eq tve uve t1 t2@(DictTy _ _ _) = - eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again - - eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) = - (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2) - || eq tve uve t1 t2 - eq tve uve (SynTy _ _ t1) t2 = - eq tve uve t1 t2 -- Expand the abbrevation and try again - eq tve uve t1 (SynTy _ _ t2) = - eq tve uve t1 t2 -- Expand the abbrevation and try again - - eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) = - eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2 - eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) = - eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2 - - eq _ _ _ _ = False - - eqBounds uve [] [] = True - eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2 - eqBounds uve _ _ = False +seqType :: Type -> () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (NoteTy note t2) = seqNote note `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy tv ty) = tv `seq` seqType ty + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +seqNote :: TyNote -> () +seqNote (SynNote ty) = seqType ty +seqNote (FTVNote set) = sizeUniqSet set `seq` () +seqNote (UsgNote usg) = usg `seq` () \end{code} +