Type - public interface
\begin{code}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+-- | Main functions for manipulating types and type-related things
module Type (
- -- re-exports from TypeRep
- TyThing(..), Type, PredType(..), ThetaType,
- funTyCon,
+ -- Note some of this is just re-exports from TyCon..
- -- Kinds
- Kind, SimpleKind, KindVar,
- kindFunResult, splitKindFunTys, splitKindFunTysN,
-
- liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
- argTypeKindTyCon, ubxTupleKindTyCon,
-
- liftedTypeKind, unliftedTypeKind, openTypeKind,
- argTypeKind, ubxTupleKind,
-
- tySuperKind, coSuperKind,
-
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
- isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
- isCoSuperKind, isSuperKind, isCoercionKind, isEqPred,
- mkArrowKind, mkArrowKinds,
-
- isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
- isSubKindCon,
-
- -- Re-exports from TyCon
- PrimRep(..),
+ -- * Main data types representing Types
+ -- $type_classification
+
+ -- $representation_types
+ TyThing(..), Type, PredType(..), ThetaType,
- mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
+ -- ** Constructing and deconstructing types
+ mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
mkAppTy, mkAppTys, splitAppTy, splitAppTys,
splitAppTy_maybe, repSplitAppTy_maybe,
mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
splitFunTys, splitFunTysN,
- funResultTy, funArgTy, zipFunTys, isFunTy,
+ funResultTy, funArgTy, zipFunTys,
mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp,
- repType, repType', typePrimRep, coreView, tcView, kindView,
+ mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
+ applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
+
+ -- (Newtypes)
+ newTyConInstRhs,
+
+ -- (Type families)
+ tyFamInsts,
+
+ -- (Source types)
+ mkPredTy, mkPredTys, mkFamilyTyConApp,
- mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- applyTy, applyTys, isForAllTy, dropForAlls,
+ -- ** Common type constructors
+ funTyCon,
- -- Source types
- predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon,
+ -- ** Predicates on types
+ isTyVarTy, isFunTy,
- -- Newtypes
- splitRecNewType_maybe, newTyConInstRhs,
+ -- (Lifting and boxity)
+ isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
+ isPrimitiveType, isStrictType, isStrictPred,
- -- Lifting and boxity
- isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
- isStrictType, isStrictPred,
+ -- * Main data types representing Kinds
+ -- $kind_subtyping
+ Kind, SimpleKind, KindVar,
+
+ -- ** Deconstructing Kinds
+ kindFunResult, splitKindFunTys, splitKindFunTysN,
- -- Free variables
+ -- ** Common Kinds and SuperKinds
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ argTypeKind, ubxTupleKind,
+
+ tySuperKind, coSuperKind,
+
+ -- ** Common Kind type constructors
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon,
+
+ -- ** Predicates on Kinds
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
+ isCoSuperKind, isSuperKind, isCoercionKind, isEqPred,
+ mkArrowKind, mkArrowKinds,
+
+ isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
+ isSubKindCon,
+
+ -- * Type free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- typeKind, addFreeTyVars,
+ typeKind,
- -- Tidying up for printing
+ -- * Tidying type related things up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyFreeTyVars,
tidyTopType, tidyPred,
tidyKind,
- -- Comparison
+ -- * Type comparison
coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcCmpPred, tcEqTypeX,
+ tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
- -- Seq
+ -- * Forcing evaluation of types
seqType, seqTypes,
- -- Type substitutions
- TvSubstEnv, emptyTvSubstEnv, -- Representation widely visible
- TvSubst(..), emptyTvSubst, -- Representation visible to a few friends
+ -- * Other views onto Types
+ coreView, tcView, kindView,
+
+ repType,
+
+ -- * Type representation for the code generator
+ PrimRep(..),
+
+ typePrimRep, predTypeRep,
+
+ -- * Main type substitution data types
+ TvSubstEnv, -- Representation widely visible
+ TvSubst(..), -- Representation visible to a few friends
+
+ -- ** Manipulating type substitutions
+ emptyTvSubstEnv, emptyTvSubst,
+
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
isEmptyTvSubst,
- -- Performing substitution on types
- substTy, substTys, substTyWith, substTheta,
+ -- ** Performing substitution on types
+ substTy, substTys, substTyWith, substTysWith, substTheta,
substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
- -- Pretty-printing
- pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll,
- pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
+ -- * Pretty-printing
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+
+ pprSourceTyCon
) where
#include "HsVersions.h"
import StaticFlags
import Util
import Outputable
-import UniqSet
+import FastString
+import Data.List
import Data.Maybe ( isJust )
\end{code}
+\begin{code}
+-- $type_classification
+-- #type_classification#
+--
+-- Types are one of:
+--
+-- [Unboxed] Iff its representation is other than a pointer
+-- Unboxed types are also unlifted.
+--
+-- [Lifted] Iff it has bottom as an element.
+-- Closures always have lifted types: i.e. any
+-- let-bound identifier in Core must have a lifted
+-- type. Operationally, a lifted object is one that
+-- can be entered.
+-- Only lifted types may be unified with a type variable.
+--
+-- [Algebraic] Iff it is a type with one or more constructors, whether
+-- declared with @data@ or @newtype@.
+-- An algebraic type is one that can be deconstructed
+-- with a case expression. This is /not/ the same as
+-- lifted types, because we also include unboxed
+-- tuples in this classification.
+--
+-- [Data] Iff it is a type declared with @data@, or a boxed tuple.
+--
+-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell.
+--
+-- Currently, all primitive types are unlifted, but that's not necessarily
+-- the case: for example, @Int@ could be primitive.
+--
+-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed
+-- but unlifted (such as @ByteArray#@). The only primitive types that we
+-- classify as algebraic are the unboxed tuples.
+--
+-- Some examples of type classifications that may make this a bit clearer are:
+--
+-- @
+-- Type primitive boxed lifted algebraic
+-- -----------------------------------------------------------------------------
+-- Int# Yes No No No
+-- ByteArray# Yes Yes No No
+-- (\# a, b \#) Yes No No Yes
+-- ( a, b ) No Yes Yes Yes
+-- [a] No Yes Yes Yes
+-- @
+
+-- $representation_types
+-- A /source type/ is a type that is a separate type as far as the type checker is
+-- concerned, but which has a more low-level representation as far as Core-to-Core
+-- passes and the rest of the back end is concerned. Notably, 'PredTy's are removed
+-- from the representation type while they do exist in the source types.
+--
+-- You don't normally have to worry about this, as the utility functions in
+-- this module will automatically convert a source into a representation type
+-- if they are spotted, to the best of it's abilities. If you don't want this
+-- to happen, use the equivalent functions from the "TcType" module.
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-In Core, we "look through" non-recursive newtypes and PredTypes.
-
\begin{code}
{-# INLINE coreView #-}
coreView :: Type -> Maybe Type
--- Strips off the *top layer only* of a type to give
+-- ^ In Core, we \"look through\" non-recursive newtypes and 'PredTypes': this
+-- function tries to obtain a different view of the supplied type given this
+--
+-- Strips off the /top layer only/ of a type to give
-- its underlying representation type.
-- Returns Nothing if there is nothing to look through.
--
--- In the case of newtypes, it returns
--- *either* a vanilla TyConApp (recursive newtype, or non-saturated)
--- *or* the newtype representation (otherwise), meaning the
--- type written in the RHS of the newtype decl,
--- which may itself be a newtype
+-- In the case of @newtype@s, it returns one of:
--
--- Example: newtype R = MkR S
--- newtype S = MkS T
--- newtype T = MkT (T -> T)
--- expandNewTcApp on R gives Just S
--- on S gives Just T
--- on T gives Nothing (no expansion)
+-- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated)
+--
+-- 2) The newtype representation (otherwise), meaning the
+-- type written in the RHS of the newtype declaration,
+-- which may itself be a newtype
+--
+-- For example, with:
+--
+-- > newtype R = MkR S
+-- > newtype S = MkS T
+-- > newtype T = MkT (T -> T)
+--
+-- 'expandNewTcApp' on:
+--
+-- * @R@ gives @Just S@
+-- * @S@ gives @Just T@
+-- * @T@ gives @Nothing@ (no expansion)
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
-coreView (NoteTy _ ty) = Just ty
coreView (PredTy p)
| isEqPred p = Nothing
| otherwise = Just (predTypeRep p)
-- Its important to use mkAppTys, rather than (foldl AppTy),
-- because the function part might well return a
-- partially-applied type constructor; indeed, usually will!
-coreView ty = Nothing
+coreView _ = Nothing
-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
--- Same, but for the type checker, which just looks through synonyms
-tcView (NoteTy _ ty) = Just ty
+-- ^ Similar to 'coreView', but for the type checker, which just looks through synonyms
tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-tcView ty = Nothing
+tcView _ = Nothing
-----------------------------------------------
{-# INLINE kindView #-}
kindView :: Kind -> Maybe Kind
--- C.f. coreView, tcView
+-- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
+
-- For the moment, we don't even handle synonyms in kinds
-kindView (NoteTy _ k) = Just k
-kindView other = Nothing
+kindView _ = Nothing
\end{code}
mkTyVarTys :: [TyVar] -> [Type]
mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
+-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
+-- given message if this is not a type variable type. See also 'getTyVar_maybe'
getTyVar :: String -> Type -> TyVar
getTyVar msg ty = case getTyVar_maybe ty of
Just tv -> tv
isTyVarTy :: Type -> Bool
isTyVarTy ty = isJust (getTyVar_maybe ty)
+-- | Attempts to obtain the type variable underlying a 'Type'
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
getTyVar_maybe (TyVarTy tv) = Just tv
-getTyVar_maybe other = Nothing
+getTyVar_maybe _ = Nothing
\end{code}
invariant: use it.
\begin{code}
+-- | Applies a type to another, as in e.g. @k a@
+mkAppTy :: Type -> Type -> Type
mkAppTy orig_ty1 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
+ mk_app _ = AppTy orig_ty1 orig_ty2
-- Note that the TyConApp could be an
-- under-saturated type synonym. GHC allows that; e.g.
-- type Foo k = k a -> k a
mkAppTys orig_ty1 orig_tys2
= mk_app orig_ty1
where
- mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
-- mkTyConApp: see notes with mkAppTy
- mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
+ mk_app _ = foldl AppTy orig_ty1 orig_tys2
-------------
splitAppTy_maybe :: Type -> Maybe (Type, Type)
+-- ^ Attempt to take a type application apart, whether it is a
+-- function, type constructor, or plain type application. Note
+-- that type family applications are NEVER unsaturated by this!
splitAppTy_maybe ty | Just ty' <- coreView ty
= splitAppTy_maybe ty'
splitAppTy_maybe ty = repSplitAppTy_maybe ty
-------------
repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
--- Does the AppTy split, but assumes that any view stuff is already done
+-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
+-- any Core view stuff is already done
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
-repSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
- Just (tys', ty') -> Just (TyConApp tc tys', ty')
- Nothing -> Nothing
-repSplitAppTy_maybe other = Nothing
+repSplitAppTy_maybe (TyConApp tc tys)
+ | not (isOpenSynTyCon tc) || length tys > tyConArity tc
+ = case snocView tys of -- never create unsaturated type family apps
+ Just (tys', ty') -> Just (TyConApp tc tys', ty')
+ Nothing -> Nothing
+repSplitAppTy_maybe _other = Nothing
-------------
splitAppTy :: Type -> (Type, Type)
+-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',
+-- and panics if this is not possible
splitAppTy ty = case splitAppTy_maybe ty of
Just pr -> pr
Nothing -> panic "splitAppTy"
-------------
splitAppTys :: Type -> (Type, [Type])
+-- ^ Recursively splits a type as far as is possible, leaving a residual
+-- type being applied to and the type arguments applied to it. Never fails,
+-- even if that means returning an empty list of type applications.
splitAppTys ty = split ty ty []
where
split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
- split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
- split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
- split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
+ split _ (AppTy ty arg) args = split ty ty (arg:args)
+ split _ (TyConApp tc tc_args) args
+ = let -- keep type families saturated
+ n | isOpenSynTyCon tc = tyConArity tc
+ | otherwise = 0
+ (tc_args1, tc_args2) = splitAt n tc_args
+ in
+ (TyConApp tc tc_args1, tc_args2 ++ args)
+ split _ (FunTy ty1 ty2) args = ASSERT( null args )
(TyConApp funTyCon [], [ty1,ty2])
- split orig_ty ty args = (orig_ty, args)
+ split orig_ty _ args = (orig_ty, args)
\end{code}
\begin{code}
mkFunTy :: Type -> Type -> Type
+-- ^ Creates a function type from the given argument and result type
mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
mkFunTy arg res = FunTy arg res
isFunTy ty = isJust (splitFunTy_maybe ty)
splitFunTy :: Type -> (Type, Type)
+-- ^ Attempts to extract the argument and result types from a type, and
+-- panics if that is not possible. See also 'splitFunTy_maybe'
splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'
splitFunTy (FunTy arg res) = (arg, res)
splitFunTy other = pprPanic "splitFunTy" (ppr other)
splitFunTy_maybe :: Type -> Maybe (Type, Type)
+-- ^ Attempts to extract the argument and result types from a type
splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'
splitFunTy_maybe (FunTy arg res) = Just (arg, res)
-splitFunTy_maybe other = Nothing
+splitFunTy_maybe _ = Nothing
splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
- split args orig_ty (FunTy arg res) = split (arg:args) res res
- split args orig_ty ty = (reverse args, orig_ty)
+ split args _ (FunTy arg res) = split (arg:args) res res
+ split args orig_ty _ = (reverse args, orig_ty)
splitFunTysN :: Int -> Type -> ([Type], Type)
--- Split off exactly n arg tys
+-- ^ Split off exactly the given number argument types, and panics if that is not possible
splitFunTysN 0 ty = ([], ty)
splitFunTysN n ty = case splitFunTy ty of { (arg, res) ->
case splitFunTysN (n-1) res of { (args, res) ->
(arg:args, res) }}
-zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
+-- | Splits off argument types from the given type and associating
+-- them with the things in the input list from left to right. The
+-- final result type is returned, along with the resulting pairs of
+-- objects and types, albeit with the list of pairs in reverse order.
+-- Panics if there are not enough argument types for the input list.
+zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type)
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
where
- split acc [] nty ty = (reverse acc, nty)
+ split acc [] nty _ = (reverse acc, nty)
split acc xs nty ty
| Just ty' <- coreView ty = split acc xs nty ty'
- split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
- split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
+ split acc (x:xs) _ (FunTy arg res) = split ((x,arg):acc) xs res res
+ split _ _ _ _ = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
funResultTy :: Type -> Type
+-- ^ Extract the function result type and panic if that is not possible
funResultTy ty | Just ty' <- coreView ty = funResultTy ty'
-funResultTy (FunTy arg res) = res
-funResultTy ty = pprPanic "funResultTy" (ppr ty)
+funResultTy (FunTy _arg res) = res
+funResultTy ty = pprPanic "funResultTy" (ppr ty)
funArgTy :: Type -> Type
+-- ^ Extract the function argument type and panic if that is not possible
funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
-funArgTy (FunTy arg res) = arg
-funArgTy ty = pprPanic "funArgTy" (ppr ty)
+funArgTy (FunTy arg _res) = arg
+funArgTy ty = pprPanic "funArgTy" (ppr ty)
\end{code}
-
---------------------------------------------------------------------
TyConApp
~~~~~~~~
-@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy,
-as apppropriate.
\begin{code}
+-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
+-- Applies its arguments to the constructor from left to right
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon tys
| isFunTyCon tycon, [ty1,ty2] <- tys
| otherwise
= TyConApp tycon tys
+-- | Create the plain type constructor type which has been applied to no type arguments at all.
mkTyConTy :: TyCon -> Type
mkTyConTy tycon = mkTyConApp tycon []
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..
+-- | The same as @fst . splitTyConApp@
tyConAppTyCon :: Type -> TyCon
tyConAppTyCon ty = fst (splitTyConApp ty)
+-- | The same as @snd . splitTyConApp@
tyConAppArgs :: Type -> [Type]
tyConAppArgs ty = snd (splitTyConApp ty)
+-- | Attempts to tease a type apart into a type constructor and the application
+-- of a number of arguments to that constructor. Panics if that is not possible.
+-- See also 'splitTyConApp_maybe'
splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp ty = case splitTyConApp_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "splitTyConApp" (ppr ty)
+-- | Attempts to tease a type apart into a type constructor and the application
+-- of a number of arguments to that constructor
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
-splitTyConApp_maybe other = Nothing
+splitTyConApp_maybe _ = Nothing
--- Sometimes we do NOT want to look throught a newtype. When case matching
--- on a newtype we want a convenient way to access the arguments of a newty
--- constructor so as to properly form a coercion.
+-- | Sometimes we do NOT want to look through a @newtype@. When case matching
+-- on a newtype we want a convenient way to access the arguments of a @newtype@
+-- constructor so as to properly form a coercion, and so we use 'splitNewTyConApp'
+-- instead of 'splitTyConApp_maybe'
splitNewTyConApp :: Type -> (TyCon, [Type])
splitNewTyConApp ty = case splitNewTyConApp_maybe ty of
Just stuff -> stuff
splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty'
splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
-splitNewTyConApp_maybe other = Nothing
+splitNewTyConApp_maybe _ = Nothing
--- get instantiated newtype rhs, the arguments had better saturate
--- the constructor
newTyConInstRhs :: TyCon -> [Type] -> Type
-newTyConInstRhs tycon tys =
- let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
+-- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an
+-- eta-reduced version of the @newtype@ if possible
+newTyConInstRhs tycon tys
+ = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
+ mkAppTys (substTyWith tvs tys1 ty) tys2
+ where
+ (tvs, ty) = newTyConEtadRhs tycon
+ (tys1, tys2) = splitAtList tvs tys
\end{code}
interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
+Note [Expanding newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+When expanding a type to expose a data-type constructor, we need to be
+careful about newtypes, lest we fall into an infinite loop. Here are
+the key examples:
+
+ newtype Id x = MkId x
+ newtype Fix f = MkFix (f (Fix f))
+ newtype T = MkT (T -> T)
+
+ Type Expansion
+ --------------------------
+ T T -> T
+ Fix Maybe Maybe (Fix Maybe)
+ Id (Id Int) Int
+ Fix Id NO NO NO
+
+Notice that we can expand T, even though it's recursive.
+And we can expand Id (Id Int), even though the Id shows up
+twice at the outer level.
+
+So, when expanding, we keep track of when we've seen a recursive
+newtype at outermost level; and bale out if we see it again.
+
+
Representation types
~~~~~~~~~~~~~~~~~~~~
-repType looks through
- (a) for-alls, and
- (b) synonyms
- (c) predicates
- (d) usage annotations
- (e) all newtypes, including recursive ones, but not newtype families
-It's useful in the back end.
\begin{code}
+-- | Looks through:
+--
+-- 1. For-alls
+--
+-- 2. Synonyms
+--
+-- 3. Predicates
+--
+-- 4. Usage annotations
+--
+-- 5. All newtypes, including recursive ones, but not newtype families
+--
+-- It's useful in the back end of the compiler.
repType :: Type -> Type
-- Only applied to types of kind *; hence tycons are saturated
-repType ty | Just ty' <- coreView ty = repType ty'
-repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys)
- | isClosedNewTyCon tc = -- Recursive newtypes are opaque to coreView
- -- but we must expand them here. Sure to
- -- be saturated because repType is only applied
- -- to types of kind *
- ASSERT( {- isRecursiveTyCon tc && -} tys `lengthIs` tyConArity tc )
- repType (new_type_rep tc tys)
-repType ty = ty
-
--- repType' aims to be a more thorough version of repType
--- For now it simply looks through the TyConApp args too
-repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
- | otherwise = go1 ty
- where
- go1 = go . repType
- go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
- go ty = ty
-
-
--- new_type_rep doesn't ask any questions:
--- it just expands newtype, whether recursive or not
-new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
- case newTyConRep new_tycon of
- (tvs, rep_ty) -> substTyWith tvs tys rep_ty
+repType ty
+ = go [] ty
+ where
+ go :: [TyCon] -> Type -> Type
+ go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
+ = go rec_nts ty'
+
+ go rec_nts (ForAllTy _ ty) -- Look through foralls
+ = go rec_nts ty
+
+ go rec_nts ty@(TyConApp tc tys) -- Expand newtypes
+ | Just _co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
+ = if tc `elem` rec_nts -- in Type.lhs
+ then ty
+ else go rec_nts' nt_rhs
+ where
+ nt_rhs = newTyConInstRhs tc tys
+ rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+ | otherwise = rec_nts
+
+ go _ ty = ty
+
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
+
+-- | Discovers the primitive representation of a more abstract 'Type'
typePrimRep :: Type -> PrimRep
typePrimRep ty = case repType ty of
TyConApp tc _ -> tyConPrimRep tc
FunTy _ _ -> PtrRep
AppTy _ _ -> PtrRep -- See note below
TyVarTy _ -> PtrRep
- other -> pprPanic "typePrimRep" (ppr ty)
+ _ -> pprPanic "typePrimRep" (ppr ty)
-- Types of the form 'f a' must be of kind *, not *#, so
-- we are guaranteed that they are represented by pointers.
-- The reason is that f must have kind *->*, not *->*#, because
-- (we claim) there is no way to constrain f's kind any other
-- way.
-
\end{code}
mkForAllTy tyvar ty
= mkForAllTys [tyvar] ty
+-- | Wraps foralls over the type using the provided 'TyVar's from left to right
mkForAllTys :: [TyVar] -> Type -> Type
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty) = isForAllTy ty
isForAllTy (ForAllTy _ _) = True
-isForAllTy other_ty = False
+isForAllTy _ = False
+-- | Attempts to take a forall type apart, returning the bound type variable
+-- and the remainder of the type
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe ty = splitFAT_m ty
where
splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
splitFAT_m _ = Nothing
+-- | Attempts to take a forall type apart, returning all the immediate such bound
+-- type variables and the remainder of the type. Always suceeds, even if that means
+-- returning an empty list of 'TyVar's
splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
- split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
- split orig_ty t tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
+-- | Equivalent to @snd . splitForAllTys@
dropForAlls :: Type -> Type
dropForAlls ty = snd (splitForAllTys ty)
\end{code}
applyTy, applyTys
~~~~~~~~~~~~~~~~~
-Instantiate a for-all type with one or more type arguments.
-Used when we have a polymorphic function applied to type args:
- f t1 t2
-Then we use (applyTys type-of-f [t1,t2]) to compute the type of
-the expression.
\begin{code}
+-- | Instantiate a forall type with one or more type arguments.
+-- Used when we have a polymorphic function applied to type args:
+--
+-- > f t1 t2
+--
+-- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression.
+-- Panics if no application is possible.
applyTy :: Type -> Type -> Type
applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
-applyTy other arg = panic "applyTy"
+applyTy _ _ = panic "applyTy"
applyTys :: Type -> [Type] -> Type
--- This function is interesting because
--- a) the function may have more for-alls than there are args
--- b) less obviously, it may have fewer for-alls
--- For case (b) think of
--- applyTys (forall a.a) [forall b.b, Int]
+-- ^ This function is interesting because:
+--
+-- 1. The function may have more for-alls than there are args
+--
+-- 2. Less obviously, it may have fewer for-alls
+--
+-- For case 2. think of:
+--
+-- > applyTys (forall a.a) [forall b.b, Int]
+--
-- This really can happen, via dressing up polymorphic types with newtype
-- clothing. Here's an example:
--- newtype R = R (forall a. a->a)
--- foo = case undefined :: R of
--- R f -> f ()
+--
+-- > newtype R = R (forall a. a->a)
+-- > foo = case undefined :: R of
+-- > R f -> f ()
+
+applyTys ty args = applyTysD empty ty args
-applyTys orig_fun_ty [] = orig_fun_ty
-applyTys orig_fun_ty arg_tys
+applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version
+applyTysD _ orig_fun_ty [] = orig_fun_ty
+applyTysD doc orig_fun_ty arg_tys
| n_tvs == n_args -- The vastly common case
= substTyWith tvs arg_tys rho_ty
| n_tvs > n_args -- Too many for-alls
= substTyWith (take n_args tvs) arg_tys
(mkForAllTys (drop n_args tvs) rho_ty)
| otherwise -- Too many type args
- = ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop!
+ = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop!
applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
(drop n_tvs arg_tys)
where
%* *
%************************************************************************
-A "source type" is a type that is a separate type as far as the type checker is
-concerned, but which has low-level representation as far as the back end is concerned.
-
Source types are always lifted.
The key function is predTypeRep which gives the representation of a source type:
mkPredTys preds = map PredTy preds
predTypeRep :: PredType -> Type
--- Convert a PredType to its "representation type";
--- the post-type-checking type used by all the Core passes of GHC.
--- Unwraps only the outermost level; for example, the result might
--- be a newtype application
+-- ^ Convert a 'PredType' to its representation type. However, it unwraps
+-- only the outermost level; for example, the result might be a newtype application
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Result might be a newtype application, but the consumer will
-- look through that too if necessary
predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
--- Pretty prints a tycon, using the family instance in case of a
--- representation tycon. For example
--- e.g. data T [a] = ...
--- In that case we want to print `T [a]', where T is the family TyCon
+mkFamilyTyConApp :: TyCon -> [Type] -> Type
+-- ^ Given a family instance TyCon and its arg types, return the
+-- corresponding family type. E.g:
+--
+-- > data family T a
+-- > data instance T (Maybe b) = MkT b
+--
+-- Where the instance tycon is :RTL, so:
+--
+-- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
+mkFamilyTyConApp tc tys
+ | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
+ , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
+ = mkTyConApp fam_tc (substTys fam_subst fam_tys)
+ | otherwise
+ = mkTyConApp tc tys
+
+-- | Pretty prints a 'TyCon', using the family instance in case of a
+-- representation tycon. For example:
+--
+-- > data T [a] = ...
+--
+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
+pprSourceTyCon :: TyCon -> SDoc
pprSourceTyCon tycon
- | Just (repTyCon, tys) <- tyConFamInst_maybe tycon
- = ppr $ repTyCon `TyConApp` tys -- can't be FunTyCon
+ | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
| otherwise
= ppr tycon
\end{code}
%************************************************************************
%* *
- NewTypes
-%* *
-%************************************************************************
-
-\begin{code}
-splitRecNewType_maybe :: Type -> Maybe Type
--- Sometimes we want to look through a recursive newtype, and that's what happens here
--- It only strips *one layer* off, so the caller will usually call itself recursively
--- Only applied to types of kind *, hence the newtype is always saturated
-splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty'
-splitRecNewType_maybe (TyConApp tc tys)
- | isClosedNewTyCon tc
- = ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied
- -- to *types* (of kind *)
- ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView
- case newTyConRhs tc of
- (tvs, rep_ty) -> ASSERT( length tvs == length tys )
- Just (substTyWith tvs tys rep_ty)
-
-splitRecNewType_maybe other = Nothing
-
-
-
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Kinds and free variables}
%* *
%************************************************************************
-- We should be looking for the coercion kind,
-- not the type kind
foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
-typeKind (NoteTy _ ty) = typeKind ty
typeKind (PredTy pred) = predKind pred
-typeKind (AppTy fun arg) = kindFunResult (typeKind fun)
-typeKind (ForAllTy tv ty) = typeKind ty
+typeKind (AppTy fun _) = kindFunResult (typeKind fun)
+typeKind (ForAllTy _ ty) = typeKind ty
typeKind (TyVarTy tyvar) = tyVarKind tyvar
-typeKind (FunTy arg res)
+typeKind (FunTy _arg res)
-- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
-- not unliftedTypKind (#)
-- The only things that can be after a function arrow are
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tyVarsOfType :: Type -> TyVarSet
--- NB: for type synonyms tyVarsOfType does *not* expand the synonym
+-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
tyVarsOfType (TyVarTy tv) = unitVarSet tv
-tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
-tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
+tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
tyVarsOfType (PredTy sty) = tyVarsOfPred sty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfTheta :: ThetaType -> TyVarSet
tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
-
--- Add a Note with the free tyvars to the top of the type
-addFreeTyVars :: Type -> Type
-addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
-addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
\end{code}
%************************************************************************
%* *
-\subsection{TidyType}
+\subsection{Type families}
%* *
%************************************************************************
-tidyTy tidies up a type for printing in an error message, or in
-an interface file.
+\begin{code}
+-- | Finds type family instances occuring in a type after expanding synonyms.
+tyFamInsts :: Type -> [(TyCon, [Type])]
+tyFamInsts ty
+ | Just exp_ty <- tcView ty = tyFamInsts exp_ty
+tyFamInsts (TyVarTy _) = []
+tyFamInsts (TyConApp tc tys)
+ | isOpenSynTyCon tc = [(tc, tys)]
+ | otherwise = concat (map tyFamInsts tys)
+tyFamInsts (FunTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
+tyFamInsts (AppTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
+tyFamInsts (ForAllTy _ ty) = tyFamInsts ty
+\end{code}
+
-It doesn't change the uniques at all, just the print names.
+%************************************************************************
+%* *
+\subsection{TidyType}
+%* *
+%************************************************************************
\begin{code}
+-- | This tidies up a type for printing in an error message, or in
+-- an interface file.
+--
+-- It doesn't change the uniques at all, just the print names.
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidyTyVarBndr env@(tidy_env, subst) tyvar
= case tidyOccName tidy_env (getOccName name) of
name = tyVarName tyvar
tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
--- Add the free tyvars to the env in tidy form,
+-- ^ Add the free 'TyVar's to the env in tidy form,
-- so that we can tidy the type they are free in
tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
--- Treat a new tyvar as a binder, and give it a fresh tidy name
-tidyOpenTyVar env@(tidy_env, subst) tyvar
+-- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
+-- using the environment if one has not already been allocated. See
+-- also 'tidyTyVarBndr'
+tidyOpenTyVar env@(_, subst) tyvar
= case lookupVarEnv subst tyvar of
Just tyvar' -> (env, tyvar') -- Already substituted
Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder
tidyType :: TidyEnv -> Type -> Type
-tidyType env@(tidy_env, subst) ty
+tidyType env@(_, subst) ty
= go ty
where
go (TyVarTy tv) = case lookupVarEnv subst tv of
Just tv' -> TyVarTy tv'
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
- go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
go (PredTy sty) = PredTy (tidyPred env sty)
go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
where
(envp, tvp) = tidyTyVarBndr env tv
- go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
-
+tidyTypes :: TidyEnv -> [Type] -> [Type]
tidyTypes env tys = map (tidyType env) tys
tidyPred :: TidyEnv -> PredType -> PredType
\end{code}
-@tidyOpenType@ grabs the free type variables, tidies them
-and then uses @tidyType@ to work over the type itself
-
\begin{code}
+-- | Grabs the free type variables, tidies them
+-- and then uses 'tidyType' to work over the type itself
tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType env ty
= (env', tidyType env' ty)
tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
+-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
%************************************************************************
\begin{code}
+-- | See "Type#type_classification" for what an unlifted type is
isUnLiftedType :: Type -> Bool
-- isUnLiftedType returns True for forall'd unlifted types:
-- x :: forall a. Int#
-- construct them
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
-isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
+isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty
isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
-isUnLiftedType other = False
+isUnLiftedType _ = False
isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> isUnboxedTupleTyCon tc
- other -> False
+ Just (tc, _ty_args) -> isUnboxedTupleTyCon tc
+ _ -> False
--- Should only be applied to *types*; hence the assert
+-- | See "Type#type_classification" for what an algebraic type is.
+-- Should only be applied to /types/, as opposed to e.g. partially
+-- saturated type constructors
isAlgType :: Type -> Bool
-isAlgType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
- isAlgTyCon tc
- other -> False
+isAlgType ty
+ = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ isAlgTyCon tc
+ _other -> False
+
+-- | See "Type#type_classification" for what an algebraic type is.
+-- Should only be applied to /types/, as opposed to e.g. partially
+-- saturated type constructors. Closed type constructors are those
+-- with a fixed right hand side, as opposed to e.g. associated types
+isClosedAlgType :: Type -> Bool
+isClosedAlgType ty
+ = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ isAlgTyCon tc && not (isOpenTyCon tc)
+ _other -> False
\end{code}
-@isStrictType@ computes whether an argument (or let RHS) should
-be computed strictly or lazily, based only on its type.
-Works just like isUnLiftedType, except that it has a special case
-for dictionaries. Since it takes account of ClassP, you might think
-this function should be in TcType, but isStrictType is used by DataCon,
-which is below TcType in the hierarchy, so it's convenient to put it here.
-
\begin{code}
+-- | Computes whether an argument (or let right hand side) should
+-- be computed strictly or lazily, based only on its type.
+-- Works just like 'isUnLiftedType', except that it has a special case
+-- for dictionaries (i.e. does not work purely on representation types)
+
+-- Since it takes account of class 'PredType's, you might think
+-- this function should be in 'TcType', but 'isStrictType' is used by 'DataCon',
+-- which is below 'TcType' in the hierarchy, so it's convenient to put it here.
+isStrictType :: Type -> Bool
isStrictType (PredTy pred) = isStrictPred pred
isStrictType ty | Just ty' <- coreView ty = isStrictType ty'
-isStrictType (ForAllTy tv ty) = isStrictType ty
+isStrictType (ForAllTy _ ty) = isStrictType ty
isStrictType (TyConApp tc _) = isUnLiftedTyCon tc
-isStrictType other = False
+isStrictType _ = False
+-- | We may be strict in dictionary types, but only if it
+-- has more than one component.
+--
+-- (Being strict in a single-component dictionary risks
+-- poking the dictionary component, which is wrong.)
+isStrictPred :: PredType -> Bool
isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-isStrictPred other = False
- -- We may be strict in dictionary types, but only if it
- -- has more than one component.
- -- [Being strict in a single-component dictionary risks
- -- poking the dictionary component, which is wrong.]
+isStrictPred _ = False
\end{code}
\begin{code}
isPrimitiveType :: Type -> Bool
--- Returns types that are opaque to Haskell.
+-- ^ Returns true of 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
Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
isPrimTyCon tc
- other -> False
+ _ -> False
\end{code}
%************************************************************************
%* *
-\subsection{Sequencing on types
+\subsection{Sequencing on types}
%* *
%************************************************************************
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 (PredTy p) = seqPred p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
seqTypes [] = ()
seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
-seqNote :: TyNote -> ()
-seqNote (FTVNote set) = sizeUniqSet set `seq` ()
-
seqPred :: PredType -> ()
seqPred (ClassP c tys) = c `seq` seqTypes tys
seqPred (IParam n ty) = n `seq` seqType ty
See Note [Newtype eta] in TyCon.lhs
\begin{code}
+-- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.)
coreEqType :: Type -> Type -> Bool
coreEqType t1 t2
= eq rn_env t1 t2
| Just t2' <- coreView t2 = eq env t1 t2'
-- Fall through case; not equal!
- eq env t1 t2 = False
+ eq _ _ _ = False
\end{code}
%* *
%************************************************************************
-Note that
- tcEqType, tcCmpType
-do *not* look through newtypes, PredTypes
-
\begin{code}
tcEqType :: Type -> Type -> Bool
+-- ^ Type equality on source types. Does not look through @newtypes@ or 'PredType's
tcEqType t1 t2 = isEqual $ cmpType t1 t2
tcEqTypes :: [Type] -> [Type] -> Bool
tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
tcCmpType :: Type -> Type -> Ordering
+-- ^ Type ordering on source types. Does not look through @newtypes@ or 'PredType's
tcCmpType t1 t2 = cmpType t1 t2
tcCmpTypes :: [Type] -> [Type] -> Ordering
tcEqPred :: PredType -> PredType -> Bool
tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
+tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool
+tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
+
tcCmpPred :: PredType -> PredType -> Ordering
tcCmpPred p1 p2 = cmpPred p1 p2
tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
\end{code}
+\begin{code}
+-- | Checks whether the second argument is a subterm of the first. (We don't care
+-- about binders, as we are only interested in syntactic subterms.)
+tcPartOfType :: Type -> Type -> Bool
+tcPartOfType t1 t2
+ | tcEqType t1 t2 = True
+tcPartOfType t1 t2
+ | Just t2' <- tcView t2 = tcPartOfType t1 t2'
+tcPartOfType _ (TyVarTy _) = False
+tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2
+tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2
+tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
+
+tcPartOfPred :: Type -> PredType -> Bool
+tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2
+tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts
+tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+\end{code}
+
Now here comes the real worker
\begin{code}
cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
cmpTypeX env (PredTy p1) (PredTy p2) = cmpPredX env p1 p2
cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2
-cmpTypeX env t1 (NoteTy _ t2) = cmpTypeX env t1 t2
-- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
-cmpTypeX env (AppTy _ _) (TyVarTy _) = GT
-
-cmpTypeX env (FunTy _ _) (TyVarTy _) = GT
-cmpTypeX env (FunTy _ _) (AppTy _ _) = GT
-
-cmpTypeX env (TyConApp _ _) (TyVarTy _) = GT
-cmpTypeX env (TyConApp _ _) (AppTy _ _) = GT
-cmpTypeX env (TyConApp _ _) (FunTy _ _) = GT
-
-cmpTypeX env (ForAllTy _ _) (TyVarTy _) = GT
-cmpTypeX env (ForAllTy _ _) (AppTy _ _) = GT
-cmpTypeX env (ForAllTy _ _) (FunTy _ _) = GT
-cmpTypeX env (ForAllTy _ _) (TyConApp _ _) = GT
+cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT
-cmpTypeX env (PredTy _) t2 = GT
+cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT
+cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT
-cmpTypeX env _ _ = LT
+cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT
+cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT
+cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT
+
+cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT
+cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT
+cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT
+cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT
+
+cmpTypeX _ (PredTy _) _ = GT
+
+cmpTypeX _ _ _ = LT
-------------
cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
-cmpTypesX env [] [] = EQ
+cmpTypesX _ [] [] = EQ
cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2
-cmpTypesX env [] tys = LT
-cmpTypesX env ty [] = GT
+cmpTypesX _ [] _ = LT
+cmpTypesX _ _ [] = GT
-------------
cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering
cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2')
-- Constructor order: IParam < ClassP < EqPred
-cmpPredX env (IParam {}) _ = LT
-cmpPredX env (ClassP {}) (IParam {}) = GT
-cmpPredX env (ClassP {}) (EqPred {}) = LT
-cmpPredX env (EqPred {}) _ = GT
+cmpPredX _ (IParam {}) _ = LT
+cmpPredX _ (ClassP {}) (IParam {}) = GT
+cmpPredX _ (ClassP {}) (EqPred {}) = LT
+cmpPredX _ (EqPred {}) _ = GT
\end{code}
PredTypes are used as a FM key in TcSimplify,
%************************************************************************
\begin{code}
+-- | Type substitution
+--
+-- #tvsubst_invariant#
+-- The following invariants must hold of a 'TvSubst':
+--
+-- 1. The in-scope set is needed /only/ to
+-- guide the generation of fresh uniques
+--
+-- 2. In particular, the /kind/ of the type variables in
+-- the in-scope set is not relevant
+--
+-- 3. The substition is only applied ONCE! This is because
+-- in general such application will not reached a fixed point.
data TvSubst
= TvSubst InScopeSet -- The in-scope type variables
TvSubstEnv -- The substitution itself
Note [Extending the TvSubst]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The following invariant should hold of a TvSubst
-
- The in-scope set is needed *only* to
- guide the generation of fresh uniques
-
- In particular, the *kind* of the type variables in
- the in-scope set is not relevant
+See #tvsubst_invariant# for the invariants that must hold.
This invariant allows a short-cut when the TvSubstEnv is empty:
if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
-------------------------------------------------------------- -}
-
+-- | A substitition of 'Type's for 'TyVar's
type TvSubstEnv = TyVarEnv Type
-- A TvSubstEnv is used both inside a TvSubst (with the apply-once
-- invariant discussed in Note [Apply Once]), and also independently
-- in the middle of matching, and unification (see Types.Unify)
-- So you have to look at the context to know if it's idempotent or
-- apply-once or whatever
+
emptyTvSubstEnv :: TvSubstEnv
emptyTvSubstEnv = emptyVarEnv
composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv
--- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1
--- It assumes that both are idempotent
--- Typically, env1 is the refinement to a base substitution env2
+-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@.
+-- It assumes that both are idempotent.
+-- Typically, @env1@ is the refinement to a base substitution @env2@
composeTvSubst in_scope env1 env2
= env1 `plusVarEnv` mapVarEnv (substTy subst1) env2
-- First apply env1 to the range of env2
where
subst1 = TvSubst in_scope env1
+emptyTvSubst :: TvSubst
emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
isEmptyTvSubst :: TvSubst -> Bool
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
+-- Note [Generating the in-scope set for a substitution]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- If we want to substitute [a -> ty1, b -> ty2] I used to
+-- think it was enough to generate an in-scope set that includes
+-- fv(ty1,ty2). But that's not enough; we really should also take the
+-- free vars of the type we are substituting into! Example:
+-- (forall b. (a,b,x)) [a -> List b]
+-- Then if we use the in-scope set {b}, there is a danger we will rename
+-- the forall'd variable to 'x' by mistake, getting this:
+-- (forall x. (List b, x, x)
+-- Urk! This means looking at all the calls to mkOpenTvSubst....
+
+
+-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
+-- environment, hence "open"
mkOpenTvSubst :: TvSubstEnv -> TvSubst
mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
+-- environment, hence "open"
zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst
zipOpenTvSubst tyvars tys
-#ifdef DEBUG
- | length tyvars /= length tys
+ | debugIsOn && (length tyvars /= length tys)
= pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
| otherwise
-#endif
= TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys)
--- mkTopTvSubst is called when doing top-level substitutions.
--- Here we expect that the free vars of the range of the
--- substitution will be empty.
+-- | Called when doing top-level substitutions. Here we expect that the
+-- free vars of the range of the substitution will be empty.
mkTopTvSubst :: [(TyVar, Type)] -> TvSubst
mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs)
zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst
zipTopTvSubst tyvars tys
-#ifdef DEBUG
- | length tyvars /= length tys
+ | debugIsOn && (length tyvars /= length tys)
= pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
| otherwise
-#endif
= TvSubst emptyInScopeSet (zipTyEnv tyvars tys)
zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv tyvars tys
-#ifdef DEBUG
- | length tyvars /= length tys
+ | debugIsOn && (length tyvars /= length tys)
= pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
| otherwise
-#endif
= zip_ty_env tyvars tys emptyVarEnv
-- Later substitutions in the list over-ride earlier ones,
-- but there should be no loops
+zip_ty_env :: [TyVar] -> [Type] -> TvSubstEnv -> TvSubstEnv
zip_ty_env [] [] env = env
zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty)
-- There used to be a special case for when
instance Outputable TvSubst where
ppr (TvSubst ins env)
- = brackets $ sep[ ptext SLIT("TvSubst"),
- nest 2 (ptext SLIT("In scope:") <+> ppr ins),
- nest 2 (ptext SLIT("Env:") <+> ppr env) ]
+ = brackets $ sep[ ptext (sLit "TvSubst"),
+ nest 2 (ptext (sLit "In scope:") <+> ppr ins),
+ nest 2 (ptext (sLit "Env:") <+> ppr env) ]
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+-- | Type substitution making use of an 'TvSubst' that
+-- is assumed to be open, see 'zipOpenTvSubst'
substTyWith :: [TyVar] -> [Type] -> Type -> Type
substTyWith tvs tys = ASSERT( length tvs == length tys )
substTy (zipOpenTvSubst tvs tys)
+-- | Type substitution making use of an 'TvSubst' that
+-- is assumed to be open, see 'zipOpenTvSubst'
+substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
+substTysWith tvs tys = ASSERT( length tvs == length tys )
+ substTys (zipOpenTvSubst tvs tys)
+
+-- | Substitute within a 'Type'
substTy :: TvSubst -> Type -> Type
substTy subst ty | isEmptyTvSubst subst = ty
| otherwise = subst_ty subst ty
+-- | Substitute within several 'Type's
substTys :: TvSubst -> [Type] -> [Type]
substTys subst tys | isEmptyTvSubst subst = tys
| otherwise = map (subst_ty subst) tys
+-- | Substitute within a 'ThetaType'
substTheta :: TvSubst -> ThetaType -> ThetaType
substTheta subst theta
| isEmptyTvSubst subst = theta
| otherwise = map (substPred subst) theta
+-- | Substitute within a 'PredType'
substPred :: TvSubst -> PredType -> PredType
substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
substPred subst (EqPred ty1 ty2) = EqPred (subst_ty subst ty1) (subst_ty subst ty2)
-deShadowTy :: TyVarSet -> Type -> Type -- Remove any nested binders mentioning tvs
+-- | Remove any nested binders mentioning the 'TyVar's in the 'TyVarSet'
+deShadowTy :: TyVarSet -> Type -> Type
deShadowTy tvs ty
= subst_ty (mkTvSubst in_scope emptyTvSubstEnv) ty
where
subst_ty subst ty
= go ty
where
- go (TyVarTy tv) = substTyVar subst tv
- go (TyConApp tc tys) = let args = map go tys
- in args `seqList` TyConApp tc args
-
- go (PredTy p) = PredTy $! (substPred subst p)
+ go (TyVarTy tv) = substTyVar subst tv
+ go (TyConApp tc tys) = let args = map go tys
+ in args `seqList` TyConApp tc args
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
+ go (PredTy p) = PredTy $! (substPred subst p)
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
- -- The mkAppTy smart constructor is important
- -- we might be replacing (a Int), represented with App
- -- by [Int], represented with TyConApp
- go (ForAllTy tv ty) = case substTyVarBndr subst tv of
- (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
+ go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ -- The mkAppTy smart constructor is important
+ -- we might be replacing (a Int), represented with App
+ -- by [Int], represented with TyConApp
+ go (ForAllTy tv ty) = case substTyVarBndr subst tv of
+ (subst', tv') ->
+ ForAllTy tv' $! (subst_ty subst' ty)
substTyVar :: TvSubst -> TyVar -> Type
-substTyVar subst@(TvSubst in_scope env) tv
+substTyVar subst@(TvSubst _ _) tv
= case lookupTyVar subst tv of {
Nothing -> TyVarTy tv;
Just ty -> ty -- See Note [Apply Once]
lookupTyVar :: TvSubst -> TyVar -> Maybe Type
-- See Note [Extending the TvSubst]
-lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
+lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv
substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
substTyVarBndr subst@(TvSubst in_scope env) old_var
Kinds
~~~~~
-There's a little subtyping at the kind level:
-
- ?
- / \
- / \
- ?? (#)
- / \
- * #
-
-where * [LiftedTypeKind] means boxed type
- # [UnliftedTypeKind] means unboxed type
- (#) [UbxTupleKind] means unboxed tuple
- ?? [ArgTypeKind] is the lub of *,#
- ? [OpenTypeKind] means any type at all
-
-In particular:
-
- error :: forall a:?. String -> a
- (->) :: ?? -> ? -> *
- (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
\begin{code}
+-- $kind_subtyping
+-- #kind_subtyping#
+-- There's a little subtyping at the kind level:
+--
+-- @
+-- ?
+-- \/ \
+-- \/ \
+-- ?? (\#)
+-- \/ \
+-- \* \#
+-- .
+-- Where: \* [LiftedTypeKind] means boxed type
+-- \# [UnliftedTypeKind] means unboxed type
+-- (\#) [UbxTupleKind] means unboxed tuple
+-- ?? [ArgTypeKind] is the lub of {\*, \#}
+-- ? [OpenTypeKind] means any type at all
+-- @
+--
+-- In particular:
+--
+-- > error :: forall a:?. String -> a
+-- > (->) :: ?? -> ? -> \*
+-- > (\\(x::t) -> ...)
+--
+-- Where in the last example @t :: ??@ (i.e. is not an unboxed tuple)
+
type KindVar = TyVar -- invariant: KindVar will always be a
-- TcTyVar with details MetaTv TauTv ...
-- kind var constructors and functions are in TcType
%************************************************************************
\begin{code}
+-- | Essentially 'funResultTy' on kinds
kindFunResult :: Kind -> Kind
kindFunResult k = funResultTy k
+-- | Essentially 'splitFunTys' on kinds
splitKindFunTys :: Kind -> ([Kind],Kind)
splitKindFunTys k = splitFunTys k
+-- | Essentially 'splitFunTysN' on kinds
splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
splitKindFunTysN k = splitFunTysN k
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
+isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
+ isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
-isOpenTypeKind other = False
+isOpenTypeKind _ = False
isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
-isUbxTupleKind other = False
+isUbxTupleKind _ = False
isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
-isArgTypeKind other = False
+isArgTypeKind _ = False
isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
-isUnliftedTypeKind other = False
+isUnliftedTypeKind _ = False
isSubOpenTypeKind :: Kind -> Bool
--- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
+-- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
False
| otherwise = False
isSubArgTypeKind :: Kind -> Bool
--- True of any sub-kind of ArgTypeKind
+-- ^ True of any sub-kind of ArgTypeKind
isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
-isSubArgTypeKind other = False
+isSubArgTypeKind _ = False
+-- | Is this a super-kind (i.e. a type-of-kinds)?
isSuperKind :: Type -> Bool
isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
-isSuperKind other = False
+isSuperKind _ = False
+-- | Is this a kind (i.e. a type-of-types)?
isKind :: Kind -> Bool
isKind k = isSuperKind (typeKind k)
-
-
isSubKind :: Kind -> Kind -> Bool
--- (k1 `isSubKind` k2) checks that k1 <: k2
+-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2'))
= ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2'
-isSubKind k1 k2 = False
+isSubKind _ _ = False
eqKind :: Kind -> Kind -> Bool
eqKind = tcEqType
isSubKindCon :: TyCon -> TyCon -> Bool
--- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
+-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
isSubKindCon kc1 kc2
| isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
| isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
| otherwise = False
defaultKind :: Kind -> Kind
--- Used when generalising: default kind '?' and '??' to '*'
---
+-- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
+-- information on what that means
+
-- When we generalise, we make generic type variables whose kind is
-- simple (* or *->* etc). So generic type variables (other than
-- built-in constants like 'error') always have simple kinds. This is important;
isEqPred :: PredType -> Bool
isEqPred (EqPred _ _) = True
-isEqPred other = False
+isEqPred _ = False
\end{code}
projects / ghc-hetmet.git / blobdiff