Commit cdea9949 authored by simonpj's avatar simonpj

[project @ 2005-11-16 12:55:58 by simonpj]

Two significant changes to the representation of types

1. Change the representation of type synonyms

    Up to now, type synonym applications have been held in
    *both* expanded *and* un-expanded form.  Unfortunately, this
    has exponential (!) behaviour when type synonyms are deeply
    nested.  E.g.
	    type P a b = (a,b)
	    f :: P a (P b (P c (P d e)))
    
    This showed up in a program of Joel Reymont, now immortalised
    as typecheck/should_compile/syn-perf.hs

    So now synonyms are held as ordinary TyConApps, and expanded
    only on demand.  

    SynNote has disappeared altogether, so the only remaining TyNote
    is a FTVNote.  I'm not sure if it's even useful.

2. Eta-reduce newtypes

    See the Note [Newtype eta] in TyCon.lhs
    
    If we have 
	    newtype T a b = MkT (S a b)
    
    then, in Core land, we would like S = T, even though the application
    of T is then not saturated. This commit eta-reduces T's RHS, and
    keeps that inside the TyCon (in nt_etad_rhs).  Result is that 
    coreEqType can be simpler, and has less need of expanding newtypes.
parent b6e680de
......@@ -946,7 +946,6 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
NoteTy (FTVNote _) ty -> getTyDescription ty
NoteTy (SynNote ty1) _ -> getTyDescription ty1
PredTy sty -> getPredTyDescription sty
ForAllTy _ ty -> getTyDescription ty
}
......
......@@ -14,10 +14,10 @@ module BuildTyCl (
import IfaceEnv ( newImplicitBinder )
import TcRnMonad
import DataCon ( DataCon, isNullarySrcDataCon,
import DataCon ( DataCon, isNullarySrcDataCon, dataConTyVars,
mkDataCon, dataConFieldLabels, dataConOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
import VarSet ( isEmptyVarSet, intersectVarSet )
import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet )
import TysWiredIn ( unitTy )
import BasicTypes ( RecFlag, StrictnessMark(..) )
import Name ( Name )
......@@ -27,9 +27,12 @@ import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
isRecursiveTyCon,
ArgVrcs, AlgTyConRhs(..), newTyConRhs )
import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type,
import Type ( mkArrowKinds, liftedTypeKind, typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
mkPredTys, mkTyVarTys, ThetaType, Type,
substTyWith, zipTopTvSubst, substTheta )
import Outputable
import List ( nub )
......@@ -67,19 +70,36 @@ mkAbstractTyConRhs = AbstractTyCon
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
= DataTyCon cons (all isNullarySrcDataCon cons)
= DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
mkNewTyConRhs tycon con
= NewTyCon con rhs_ty (mkNewTyConRep tycon)
= NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = eta_reduce tvs rhs_ty,
nt_rep = mkNewTyConRep tycon rhs_ty }
where
tvs = dataConTyVars con
rhs_ty = head (dataConOrigArgTys con)
-- Newtypes are guaranteed vanilla, so OrigArgTys will do
eta_reduce [] ty = ([], ty)
eta_reduce (a:as) ty | null as',
Just (fun, arg) <- splitAppTy_maybe ty',
Just tv <- getTyVar_maybe arg,
tv == a,
not (a `elemVarSet` tyVarsOfType fun)
= ([], fun) -- Successful eta reduction
| otherwise
= (a:as', ty')
where
(as', ty') = eta_reduce as ty
mkNewTyConRep :: TyCon -- The original type constructor
-> Type -- The arg type of its constructor
-> Type -- Chosen representation type
-- (guaranteed not to be another newtype)
-- Free vars of rep = tyConTyVars tc
-- The "representation type" is guaranteed not to be another newtype
-- at the outermost level; but it might have newtypes in type arguments
-- Find the representation type for this newtype TyCon
-- Remember that the representation type is the *ultimate* representation
......@@ -92,24 +112,24 @@ mkNewTyConRep :: TyCon -- The original type constructor
-- The trick is to to deal correctly with recursive newtypes
-- such as newtype T = MkT T
mkNewTyConRep tc
mkNewTyConRep tc rhs_ty
| null (tyConDataCons tc) = unitTy
-- External Core programs can have newtypes with no data constructors
| otherwise = go [] tc
| otherwise = go [tc] rhs_ty
where
-- Invariant: tc is a NewTyCon
-- tcs have been seen before
go tcs tc
| tc `elem` tcs = unitTy
| otherwise
= case splitTyConApp_maybe rhs_ty of
Just (tc1, tys) | isNewTyCon tc1
-> ASSERT( length (tyConTyVars tc1) == length tys )
substTyWith (tyConTyVars tc1) tys (go (tc:tcs) tc1)
other -> rhs_ty
where
(_tc_tvs, rhs_ty) = newTyConRhs tc
-- Invariant: tcs have been seen before
go tcs rep_ty
= case splitTyConApp_maybe rep_ty of
Just (tc, tys)
| tc `elem` tcs -> unitTy -- Recursive loop
| isNewTyCon tc -> ASSERT( isRecursiveTyCon tc )
-- Non-recursive ones have been
-- dealt with by splitTyConApp_maybe
go (tc:tcs) (substTyWith tvs tys rhs_ty)
where
(tvs, rhs_ty) = newTyConRhs tc
other -> rep_ty
------------------------------------------------------
buildDataCon :: Name -> Bool -> Bool
......
......@@ -518,9 +518,9 @@ tyThingToIfaceDecl ext (ATyCon tycon)
tyvars = tyConTyVars tycon
(_, syn_ty) = getSynTyConDefn tycon
ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls AbstractTyCon = IfAbstractTyCon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
-- in TcRnDriver for GHCi, when browsing a module, in which case the
......
......@@ -337,13 +337,13 @@ toIfaceBndr ext var
---------------------
toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
-- Synonyms are retained in the interface type
toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv)
toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys)
toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t)
toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st)
toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app -- Retain synonyms
toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty
----------------
......
......@@ -547,9 +547,11 @@ mkIfTcApp :: TyCon -> [Type] -> Type
-- foralls to the right of an arrow), so we must be careful to hoist them here.
-- This hack should go away when we get rid of hoisting.
-- Then we should go back to mkGenTyConApp or something like it
mkIfTcApp tc tys
| isSynTyCon tc = hoistForAllTys (mkSynTy tc tys)
| otherwise = mkTyConApp tc tys
--
-- Nov 05: the type is now hoisted before being put into an interface file
mkIfTcApp tc tys = mkTyConApp tc tys
-- | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys)
-- | otherwise = mkTyConApp tc tys
-----------------------------------------
tcIfacePredType :: IfacePredType -> IfL PredType
......
......@@ -65,16 +65,9 @@ import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
import Data.Maybe ( isNothing )
import System.Directory ( doesFileExist )
import Control.Monad ( foldM )
import Data.List ( nub, partition, sortBy )
#ifdef mingw32_TARGET_OS
import Data.List ( isPrefixOf )
#endif
import Data.List ( isSuffixOf )
import Data.List ( nub, partition, sortBy, isSuffixOf )
import FastString
import EXCEPTION ( throwDyn )
import ErrUtils ( debugTraceMsg, putMsg, Message )
......
......@@ -63,6 +63,8 @@ import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
mk'indexOfP,mk'eq,mk'neq)
-- GHC
import TcType ( tcIsForAllTy, tcView )
import TypeRep ( Type(..) )
import StaticFlags (opt_Flatten)
import Panic (panic)
import ErrUtils (dumpIfSet_dyn)
......@@ -72,7 +74,6 @@ import Literal (Literal, literalType)
import Var (Var(..), idType, isTyVar)
import Id (setIdType)
import DataCon (DataCon, dataConTag)
import TypeRep (Type(..))
import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
import CoreFVs (exprFreeVars)
import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
......@@ -246,7 +247,7 @@ vectorise (App expr arg) =
(vexpr, vexprTy) <- vectorise expr
(varg, vargTy) <- vectorise arg
if (isPolyType vexprTy)
if (tcIsForAllTy vexprTy)
then do
let resTy = applyTypeToArg vexprTy varg
return (App vexpr varg, resTy)
......@@ -256,13 +257,6 @@ vectorise (App expr arg) =
let resTy = applyTypeToArg t1 varg
return ((App vexpr' varg), resTy) -- apply the first component of
-- the vectorized function
where
isPolyType t =
(case t of
(ForAllTy _ _) -> True
(NoteTy _ nt) -> isPolyType nt
_ -> False)
vectorise e@(Lam b expr)
| isTyVar b
......@@ -317,6 +311,10 @@ myShowTy (TyConApp _ t) =
-}
vectoriseTy :: Type -> Type
vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
-- Look through notes and synonyms
-- NB: This will discard notes and synonyms, of course
-- ToDo: retain somehow?
vectoriseTy t@(TyVarTy v) = t
vectoriseTy t@(AppTy t1 t2) =
AppTy (vectoriseTy t1) (vectoriseTy t2)
......@@ -327,8 +325,6 @@ vectoriseTy t@(FunTy t1 t2) =
(liftTy t)]
vectoriseTy t@(ForAllTy v ty) =
ForAllTy v (vectoriseTy ty)
vectoriseTy t@(NoteTy note ty) = -- FIXME: is the note still valid after
NoteTy note (vectoriseTy ty) -- this or should we just throw it away
vectoriseTy t = t
......@@ -336,9 +332,9 @@ vectoriseTy t = t
-- on the *top level* (is this sufficient???)
liftTy:: Type -> Type
liftTy ty | Just ty' <- tcView ty = liftTy ty'
liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
liftTy (NoteTy n t) = NoteTy n $ liftTy t
liftTy t = mkPArrTy t
......
......@@ -47,7 +47,7 @@ import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
import NameSet
import Literal ( inIntRange, inCharRange )
import BasicTypes ( compareFixity, funTyFixity, negateFixity, compareFixity,
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
import ListSetOps ( removeDups )
import Outputable
......
......@@ -47,7 +47,7 @@ module TcMType (
-- friends:
import HsSyn ( LHsType )
import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation
import TypeRep ( Type(..), PredType(..), -- Friend; can see representation
ThetaType
)
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
......@@ -61,7 +61,7 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
typeKind, isFlexi, isSkolemTyVar,
mkAppTy, mkTyVarTy, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe,
tyVarsOfType, tyVarsOfTypes,
tyVarsOfType, tyVarsOfTypes, tcView,
pprPred, pprTheta, pprClassPred )
import Kind ( Kind(..), KindVar, kindVarRef, mkKindVar, isSubKind,
isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
......@@ -527,11 +527,7 @@ zonkType unbound_var_fn rflag ty
go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' ->
returnM (TyConApp tycon tys')
go (NoteTy (SynNote ty1) ty2) = go ty1 `thenM` \ ty1' ->
go ty2 `thenM` \ ty2' ->
returnM (NoteTy (SynNote ty1') ty2')
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations
go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
go (PredTy p) = go_pred p `thenM` \ p' ->
returnM (PredTy p')
......@@ -825,29 +821,6 @@ check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty)
check_tau_type rank ubx_tup (AppTy ty1 ty2)
= check_arg_type ty1 `thenM_` check_arg_type ty2
check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty)
-- Synonym notes are built only when the synonym is
-- saturated (see Type.mkSynTy)
= doptM Opt_GlasgowExts `thenM` \ gla_exts ->
(if gla_exts then
-- If -fglasgow-exts then don't check the 'note' part.
-- This allows us to instantiate a synonym defn with a
-- for-all type, or with a partially-applied type synonym.
-- e.g. type T a b = a
-- type S m = m ()
-- f :: S (T Int)
-- Here, T is partially applied, so it's illegal in H98.
-- But if you expand S first, then T we get just
-- f :: Int
-- which is fine.
returnM ()
else
-- For H98, do check the un-expanded part
check_tau_type rank ubx_tup syn
) `thenM_`
check_tau_type rank ubx_tup ty
check_tau_type rank ubx_tup (NoteTy other_note ty)
= check_tau_type rank ubx_tup ty
......@@ -856,8 +829,31 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
= -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated
-- synonym application, leaving it to checkValidType (i.e. right here)
-- to find the error
checkTc syn_arity_ok arity_msg `thenM_`
mappM_ check_arg_type tys
do { -- It's OK to have an *over-applied* type synonym
-- data Tree a b = ...
-- type Foo a = Tree [a]
-- f :: Foo a b -> ...
; case tcView ty of
Just ty' -> check_tau_type rank ubx_tup ty' -- Check expansion
Nothing -> failWithTc arity_msg
; gla_exts <- doptM Opt_GlasgowExts
; if gla_exts then
-- If -fglasgow-exts then don't check the type arguments
-- This allows us to instantiate a synonym defn with a
-- for-all type, or with a partially-applied type synonym.
-- e.g. type T a b = a
-- type S m = m ()
-- f :: S (T Int)
-- Here, T is partially applied, so it's illegal in H98.
-- But if you expand S first, then T we get just
-- f :: Int
-- which is fine.
returnM ()
else
-- For H98, do check the type args
mappM_ check_arg_type tys
}
| isUnboxedTupleTyCon tc
= doptM Opt_GlasgowExts `thenM` \ gla_exts ->
......@@ -872,11 +868,6 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
where
ubx_tup_ok gla_exts = case ubx_tup of { UT_Ok -> gla_exts; other -> False }
syn_arity_ok = tc_arity <= n_args
-- It's OK to have an *over-applied* type synonym
-- data Tree a b = ...
-- type Foo a = Tree [a]
-- f :: Foo a b -> ...
n_args = length tys
tc_arity = tyConArity tc
......
......@@ -1712,7 +1712,7 @@ reduceList (n,stack) try_me wanteds state
#ifdef DEBUG
(if n > 8 then
pprTrace "Interesting! Context reduction stack deeper than 8:"
(nest 2 (pprStack stack))
(int n $$ ifPprDebug (nest 2 (pprStack stack)))
else (\x->x))
#endif
go wanteds state
......
......@@ -22,7 +22,7 @@ module TcTyDecls(
import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
import RnHsSyn ( extractHsTyNames )
import Type ( predTypeRep )
import Type ( predTypeRep, tcView )
import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
getSynTyConDefn, isSynTyCon, isAlgTyCon,
......@@ -94,19 +94,14 @@ synTyConsOfType ty
where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go (TyVarTy v) = emptyNameEnv
go (TyConApp tc tys) = go_tc tc tys -- See note (a)
go (TyConApp tc tys) = go_tc tc tys
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
go (NoteTy other ty) = go ty
go (NoteTy _ ty) = go ty
go (ForAllTy _ ty) = go ty
-- Note (a): the unexpanded branch of a SynNote has a
-- TyConApp for the synonym, so the tc of
-- a TyConApp must be tested for possible synonyms
go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
| otherwise = go_s tys
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
......@@ -313,14 +308,14 @@ tcTyConsOfType ty
= nameEnvElts (go ty)
where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go (TyVarTy v) = emptyNameEnv
go (TyConApp tc tys) = go_tc tc tys
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
go (NoteTy _ ty) = go ty
go (ForAllTy _ ty) = go ty
go ty | Just ty' <- tcView ty = go ty'
go (TyVarTy v) = emptyNameEnv
go (TyConApp tc tys) = go_tc tc tys
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
go (ForAllTy _ ty) = go ty
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
......@@ -422,10 +417,6 @@ vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out
-> Type -- type to check for occ in
-> (Bool,Bool) -- (occurs positively, occurs negatively)
vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
-- SynTyCon doesn't neccessarily have vrcInfo at this point,
-- so don't try and use it
vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
then vrcInTy fao v ty
else (False,False)
......
<
......@@ -34,6 +34,7 @@ module TcType (
--------------------------------
-- Splitters
-- These are important because they do not look through newtypes
tcView,
tcSplitForAllTys, tcSplitPhiTy,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
......@@ -119,7 +120,7 @@ module TcType (
#include "HsVersions.h"
-- friends:
import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
import TypeRep ( Type(..), funTyCon ) -- friend
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
......@@ -140,7 +141,7 @@ import Type ( -- Re-exports
tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar,
tidyOpenTyVars, tidyKind,
isSubKind, deShadowTy,
isSubKind, deShadowTy, tcView,
tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
tcEqPred, tcCmpPred, tcEqTypeX,
......@@ -409,22 +410,22 @@ mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
\begin{code}
isTauTy :: Type -> Bool
isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
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 (PredTy p) = True -- Don't look through source types
isTauTy (NoteTy _ ty) = isTauTy ty
isTauTy other = False
\end{code}
\begin{code}
getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
-- construct a dictionary function name
getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
getDFunTyKey (TyVarTy tv) = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (NoteTy _ t) = getDFunTyKey t
getDFunTyKey (FunTy arg _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
......@@ -450,21 +451,21 @@ variables. It's up to you to make sure this doesn't matter.
tcSplitForAllTys :: Type -> ([TyVar], Type)
tcSplitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs
split orig_ty t tvs = (reverse tvs, orig_ty)
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
tcIsForAllTy (ForAllTy tv ty) = True
tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty
tcIsForAllTy t = False
tcSplitPhiTy :: Type -> ([PredType], Type)
tcSplitPhiTy ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
Just p -> split res res (p:ts)
Nothing -> (reverse ts, orig_ty)
split orig_ty (NoteTy n ty) ts = split orig_ty ty ts
split orig_ty ty ts = (reverse ts, orig_ty)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
......@@ -483,26 +484,24 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
-- Newtypes are opaque, so they may be split
-- However, predicates are not treated
-- as tycon applications by the type checker
tcSplitTyConApp_maybe other = Nothing
tcSplitTyConApp_maybe other = Nothing
tcValidInstHeadTy :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- These must not be type synonyms, but everywhere else type synonyms
-- are transparent, so we need a special function here
tcValidInstHeadTy ty
tcValidInstHeadTy ty
= case ty of
TyConApp tc tys -> ASSERT( not (isSynTyCon tc) ) ok tys
-- A synonym would be a NoteTy
FunTy arg res -> ok [arg, res]
NoteTy (SynNote _) _ -> False
NoteTy other_note ty -> tcValidInstHeadTy ty
other -> False
NoteTy _ ty -> tcValidInstHeadTy ty
TyConApp tc tys -> not (isSynTyCon tc) && ok tys
FunTy arg res -> ok [arg, res]
other -> False
where
-- Check that all the types are type variables,
-- and that each is distinct
......@@ -510,10 +509,9 @@ tcValidInstHeadTy ty
where
tvs = mapCatMaybes get_tv tys
get_tv (TyVarTy tv) = Just tv -- Again, do not look
get_tv (NoteTy (SynNote _) _) = Nothing -- through synonyms
get_tv (NoteTy other_note ty) = get_tv ty
get_tv other = Nothing
get_tv (NoteTy _ ty) = get_tv ty -- through synonyms
get_tv (TyVarTy tv) = Just tv -- Again, do not look
get_tv other = Nothing
tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
......@@ -523,8 +521,8 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
(args,res') = tcSplitFunTys res
tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty
tcSplitFunTy_maybe other = Nothing
tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
......@@ -532,9 +530,9 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
Just (tys', ty') -> Just (TyConApp tc tys', ty')
Nothing -> Nothing
......@@ -553,8 +551,8 @@ tcSplitAppTys ty
Nothing -> (ty,args)
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
tcGetTyVar_maybe (TyVarTy tv) = Just tv
tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
tcGetTyVar_maybe other = Nothing
tcGetTyVar :: String -> Type -> TyVar
......@@ -587,7 +585,7 @@ tcSplitDFunHead tau
\begin{code}
tcSplitPredTy_maybe :: Type -> Maybe PredType
-- Returns Just for predicates only
tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
tcSplitPredTy_maybe (PredTy p) = Just p
tcSplitPredTy_maybe other = Nothing
......@@ -624,8 +622,8 @@ mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = mkPredTy (ClassP clas tys)
isDictTy :: Type -> Bool
isDictTy ty | Just ty' <- tcView ty = isDictTy ty'
isDictTy (PredTy p) = isClassPred p
isDictTy (NoteTy _ ty) = isDictTy ty
isDictTy other = False
\end{code}
......@@ -687,20 +685,20 @@ any foralls. E.g.
\begin{code}
isSigmaTy :: Type -> Bool
isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
isSigmaTy (ForAllTy tyvar ty) = True
isSigmaTy (FunTy a b) = isPredTy a
isSigmaTy (NoteTy n ty) = isSigmaTy ty
isSigmaTy _ = False
isOverloadedTy :: Type -> Bool
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
isOverloadedTy (FunTy a b) = isPredTy a
isOverloadedTy (NoteTy n ty) = isOverloadedTy ty
isOverloadedTy _ = False
isPredTy :: Type -> Bool -- Belongs in TcType because it does
-- not look through newtypes, or predtypes (of course)
isPredTy (NoteTy _ ty) = isPredTy ty
isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
isPredTy (PredTy sty) = True
isPredTy _ = False
\end{code}
......@@ -753,28 +751,30 @@ tied.)
\begin{code}
hoistForAllTys :: Type -> Type
hoistForAllTys ty
= go (deShadowTy ty)
-- Running over ty with an empty substitution gives it the
-- no-shadowing property. This is important. For example:
-- type Foo r = forall a. a -> r
-- foo :: Foo (Foo ())