Commit 84923cc7 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Big tidy-up of deriving code

This tidy-up, triggered by Trac #1068, re-factors the way that 'deriving' 
happens.  It took me way longer than I had intended.  The main changes,
by far are to TcDeriv; everyting else is a minor consequence.

While I was at it, I changed the syntax for standalone deriving, so that
it goes
	derive instance Show (T a)

(instead of "derive Show for T").  However, there's still an implicit
context, generated by the deriving code, and I wonder if it shouldn't really
be
	derive instance (..) => Show (T a)
but I have left it simple for now.

I also added a function Type.substTyVars, and used it here and there, which
led to some one-line changes otherwise unrelated (sorry).

Loose ends:
  * 'deriving Typeable' for indexed data types is still not right
  * standalone deriving should be documented
parent 3ded6e65
......@@ -619,7 +619,7 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs,
mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
case tyConFamInst_maybe tycon of
Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs)
Nothing -> mkTyConApp tycon (substTyVars subst univ_tvs)
Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance
where
subst = mkTopTvSubst eq_spec
......
......@@ -218,7 +218,7 @@ mkDataConIds wrap_name wkr_name data_con
-- arguments to the universals of the data constructor
-- (crucial when type checking interfaces)
dict_tys = mkPredTys theta
result_ty_args = map (substTyVar subst) univ_tvs
result_ty_args = substTyVars subst univ_tvs
result_ty = case tyConFamInst_maybe tycon of
-- ordinary constructor
Nothing -> mkTyConApp tycon result_ty_args
......
......@@ -381,12 +381,20 @@ data TyClDecl name
| TyData { tcdND :: NewOrData,
tcdCtxt :: LHsContext name, -- Context
tcdLName :: Located name, -- Type constructor
tcdTyVars :: [LHsTyVarBndr name], -- Type variables
tcdTyPats :: Maybe [LHsType name], -- Type patterns
tcdKindSig:: Maybe Kind, -- Optional kind sig;
-- (only for the
-- 'where' form and
-- indexed type sigs)
-- Just [t1..tn] for data instance T t1..tn = ...
-- in this case tcdTyVars = fv( tcdTyPats )
-- Nothing for everything else
tcdKindSig:: Maybe Kind, -- Optional kind sig
-- (Just k) for
-- (a) GADT-style data type decls with user kind sig
-- (b) 'data instance' decls with user kind sig
-- (c) 'data family' decls, whether or not there is a kind sig
-- (this is how we distinguish a data family decl)
tcdCons :: [LConDecl name], -- Data constructors
-- For data T a = T1 | T2 a the LConDecls all have ResTyH98
......@@ -400,6 +408,9 @@ data TyClDecl name
-- Typically the foralls and ty args are empty, but they
-- are non-empty for the newtype-deriving case
}
-- data family: tcdPats = Nothing, tcdCons = [], tcdKindSig = Just k
-- data instance: tcdPats = Just tys
-- data: tcdPats = Nothing, tcdCons is non-empty
| TyFunction {tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
......@@ -410,8 +421,9 @@ data TyClDecl name
| TySynonym { tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdTyPats :: Maybe [LHsType name], -- Type patterns
-- 'Nothing' => vanilla
-- type synonym
-- See comments for tcdTyPats in TyData
-- 'Nothing' => vanilla type synonym
tcdSynRhs :: LHsType name -- synonym expansion
}
......@@ -740,12 +752,11 @@ instDeclATs (InstDecl _ _ _ ats) = ats
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
data DerivDecl name
= DerivDecl (LHsType name) (Located name)
data DerivDecl name = DerivDecl (LHsType name)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
ppr (DerivDecl ty n)
= hsep [ptext SLIT("deriving"), ppr ty, ptext SLIT("for"), ppr n]
ppr (DerivDecl ty)
= hsep [ptext SLIT("derived instance"), ppr ty]
\end{code}
%************************************************************************
......
......@@ -342,7 +342,6 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
= maybeParen ctxt_prec pREC_FUN $
sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
-- gaw 2004
ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppr b <> ppr ty
ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
......@@ -350,7 +349,7 @@ ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred)
ppr_mono_ty ctxt_prec (HsPredTy pred) = ppr pred
ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only
ppr_mono_ty ctxt_prec (HsSpliceTy s) = pprSplice s
......
......@@ -212,6 +212,8 @@ nlList exprs = noLoc (ExplicitList placeHolderType exprs)
nlHsAppTy f t = noLoc (HsAppTy f t)
nlHsTyVar x = noLoc (HsTyVar x)
nlHsFunTy a b = noLoc (HsFunTy a b)
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
\end{code}
......
......@@ -389,9 +389,9 @@ data Token
| ITdata
| ITdefault
| ITderiving
| ITderived
| ITdo
| ITelse
| ITfor
| IThiding
| ITif
| ITimport
......@@ -544,7 +544,7 @@ isSpecial :: Token -> Bool
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
isSpecial ITfor = True
isSpecial ITderived = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
......@@ -576,9 +576,9 @@ reservedWordsFM = listToUFM $
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
( "deriving", ITderiving, 0 ),
( "derived", ITderived, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
( "for", ITfor, 0 ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
( "import", ITimport, 0 ),
......
......@@ -178,9 +178,9 @@ incorrect.
'data' { L _ ITdata }
'default' { L _ ITdefault }
'deriving' { L _ ITderiving }
'derived' { L _ ITderived }
'do' { L _ ITdo }
'else' { L _ ITelse }
'for' { L _ ITfor }
'hiding' { L _ IThiding }
'if' { L _ ITif }
'import' { L _ ITimport }
......@@ -740,10 +740,7 @@ tycl_hdr :: { Located (LHsContext RdrName,
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
: 'deriving' qtycon 'for' qtycon {% do { p <- checkInstType (fmap HsTyVar $2)
; checkDerivDecl (LL (DerivDecl p $4)) } }
| 'deriving' '(' inst_type ')' 'for' qtycon {% checkDerivDecl (LL (DerivDecl $3 $6)) }
: 'derived' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) }
-----------------------------------------------------------------------------
-- Nested declarations
......@@ -1741,7 +1738,7 @@ special_id
: 'as' { L1 FSLIT("as") }
| 'qualified' { L1 FSLIT("qualified") }
| 'hiding' { L1 FSLIT("hiding") }
| 'for' { L1 FSLIT("for") }
| 'derived' { L1 FSLIT("derived") }
| 'export' { L1 FSLIT("export") }
| 'label' { L1 FSLIT("label") }
| 'dynamic' { L1 FSLIT("dynamic") }
......
......@@ -422,11 +422,10 @@ extendTyVarEnvForMethodBinds tyvars thing_inside
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty n)
rnSrcDerivDecl (DerivDecl ty)
= do ty' <- rnLHsType (text "a deriving decl") ty
n' <- lookupLocatedOccRn n
let fvs = extractHsTyNames ty' `addOneFV` unLoc n'
return (DerivDecl ty' n', fvs)
let fvs = extractHsTyNames ty'
return (DerivDecl ty', fvs)
\end{code}
%*********************************************************
......
......@@ -751,7 +751,7 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
(theta, _) = tcSplitPhiTy dfun_rho
src_loc = instLocSpan loc
dfun = HsVar dfun_id
tys = map (substTyVar tenv') tyvars
tys = substTyVars tenv' tyvars
; if null theta then
returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
......
This diff is collapsed.
......@@ -160,15 +160,22 @@ tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = addLocM tcLookupTyCon
-- Look up the representation tycon of a family instance.
--
tcLookupFamInst :: TyCon -> [Type] -> TcM TyCon
-- Return the rep tycon and the corresponding rep args
tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
tcLookupFamInst tycon tys
| not (isOpenTyCon tycon)
= return (tycon, tys)
| otherwise
= do { env <- getGblEnv
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
; case lookupFamInstEnvExact instEnv tycon tys of
Nothing -> famInstNotFound tycon tys
Just famInst -> return $ famInstTyCon famInst
; case lookupFamInstEnv instEnv tycon tys of
[(subst,fam_inst)] -> return (rep_tc, substTyVars subst (tyConTyVars rep_tc))
where -- NB: assumption is that (tyConTyVars rep_tc) is in
-- the domain of the substitution
rep_tc = famInstTyCon fam_inst
other -> famInstNotFound tycon tys other
}
\end{code}
......@@ -670,8 +677,10 @@ wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
ptext SLIT("used as a") <+> text expected)
famInstNotFound tycon tys
= failWithTc (quotes famInst <+> ptext SLIT("is not in scope"))
famInstNotFound tycon tys what
= failWithTc (msg <+> quotes (ppr tycon <+> hsep (map pprParendType tys)))
where
famInst = ppr tycon <+> hsep (map pprParendType tys)
msg = case what of
[] -> ptext SLIT("No instance for")
xs -> ptext SLIT("More than one instance for")
\end{code}
......@@ -749,7 +749,7 @@ instFun orig fun subst tv_theta_prs
; go True fun ty_theta_prs' }
where
subst_pr (tvs, theta)
= (map (substTyVar subst) tvs, substTheta subst theta)
= (substTyVars subst tvs, substTheta subst theta)
go _ fun [] = return fun
......
......@@ -1208,8 +1208,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
(nlHsApp (nlHsVar getTag_RDR) a_Expr)))
(noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
(map nlHsTyVar tvs)
con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
`nlHsFunTy`
nlHsTyVar (getRdrName intPrimTyCon)
......
......@@ -6,7 +6,8 @@
\begin{code}
module TcHsType (
tcHsSigType, tcHsDeriv,
tcHsSigType, tcHsDeriv,
tcHsInstHead, tcHsQuantifiedType,
UserTypeCtxt(..),
-- Kind checking
......@@ -143,6 +144,24 @@ tcHsSigType ctxt hs_ty
; checkValidType ctxt ty
; returnM ty }
tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type)
-- Typecheck an instance head. We can't use
-- tcHsSigType, because it's not a valid user type.
tcHsInstHead hs_ty
= do { kinded_ty <- kcHsSigType hs_ty
; poly_ty <- tcHsKindedType kinded_ty
; return (tcSplitSigmaTy poly_ty) }
tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
-- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
-- except that we want to keep the tvs separate
tcHsQuantifiedType tv_names hs_ty
= kcHsTyVars tv_names $ \ tv_names' ->
do { kc_ty <- kcHsSigType hs_ty
; tcTyVarBndrs tv_names' $ \ tvs ->
do { ty <- dsHsType kc_ty
; return (tvs, ty) } }
-- Used for the deriving(...) items
tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
tcHsDeriv = addLocM (tc_hs_deriv [])
......@@ -629,7 +648,7 @@ tcTyVarBndrs bndrs thing_inside
where
zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
; return (mkTyVar name kind') }
zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $
zonk (UserTyVar name) = WARN( True, ptext SLIT("Un-kinded tyvar") <+> ppr name )
return (mkTyVar name liftedTypeKind)
-----------------------------------
......@@ -725,16 +744,10 @@ tcHsPatSigType ctxt hs_ty
| n <- nameSetToList (extractHsTyVars hs_ty),
not (in_scope n) ]
-- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
-- except that we want to keep the tvs separate
; (kinded_tvs, kinded_ty) <- kcHsTyVars sig_tvs $ \ kinded_tvs -> do
{ kinded_ty <- kcTypeType hs_ty
; return (kinded_tvs, kinded_ty) }
; tcTyVarBndrs kinded_tvs $ \ tyvars -> do
{ sig_ty <- dsHsType kinded_ty
; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
; checkValidType ctxt sig_ty
; return (tyvars, sig_ty)
} }
}
tcPatSig :: UserTypeCtxt
-> LHsType Name
......
......@@ -240,11 +240,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
-- Typecheck the instance type itself. We can't use
-- tcHsSigType, because it's not a valid user type.
; kinded_ty <- kcHsSigType poly_ty
; poly_ty' <- tcHsKindedType kinded_ty
; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
; (tyvars, theta, tau) <- tcHsInstHead poly_ty
-- Next, process any associated types.
; idx_tycons <- mappM tcIdxTyInstDecl ats
......
......@@ -1169,7 +1169,7 @@ checkValidInstance tyvars theta clas inst_tys
-- Check that instance inference will terminate (if we care)
-- For Haskell 98, checkValidTheta has already done that
; when (gla_exts && not undecidable_ok) $
mapM_ failWithTc (checkInstTermination inst_tys theta)
mapM_ addErrTc (checkInstTermination inst_tys theta)
-- The Coverage Condition
; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
......
......@@ -28,11 +28,10 @@ import Inst
import TcEnv
import InstEnv
import TcGadt
import TcMType
import TcType
import TcMType
import TcIface
import Var
import TyCon
import Name
import NameSet
import Class
......@@ -2345,55 +2344,31 @@ instance declarations.
\begin{code}
tcSimplifyDeriv :: InstOrigin
-> TyCon
-> [TyVar]
-> ThetaType -- Wanted
-> TcM ThetaType -- Needed
-- Given instance (wanted) => C inst_ty
-- Simplify 'wanted' as much as possible
-- The inst_ty is needed only for the termination check
tcSimplifyDeriv orig tc tyvars theta
= tcInstTyVars tyvars `thenM` \ (tvs, _, tenv) ->
tcSimplifyDeriv orig tyvars theta
= do { (tvs, _, tenv) <- tcInstTyVars tyvars
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
newDictBndrsO orig (substTheta tenv theta) `thenM` \ wanteds ->
topCheckLoop doc wanteds `thenM` \ (irreds, _) ->
doptM Opt_GlasgowExts `thenM` \ gla_exts ->
doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
let
inst_ty = mkTyConApp tc (mkTyVarTys tvs)
(ok_insts, bad_insts) = partition is_ok_inst irreds
is_ok_inst inst
= isDict inst -- Exclude implication consraints
&& (isTyVarClassPred pred || (gla_exts && ok_gla_pred pred))
where
pred = dictPred inst
ok_gla_pred pred = null (checkInstTermination [inst_ty] [pred])
-- See Note [Deriving context]
tv_set = mkVarSet tvs
simpl_theta = map dictPred ok_insts
weird_preds = [pred | pred <- simpl_theta
, not (tyVarsOfPred pred `subVarSet` tv_set)]
-- Check for a bizarre corner case, when the derived instance decl should
-- have form instance C a b => D (T a) where ...
-- Note that 'b' isn't a parameter of T. This gives rise to all sorts
-- of problems; in particular, it's hard to compare solutions for
-- equality when finding the fixpoint. So I just rule it out for now.
rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
; wanteds <- newDictBndrsO orig (substTheta tenv theta)
; (irreds, _) <- topCheckLoop doc wanteds
; let (dicts, non_dicts) = partition isDict irreds
-- Exclude implication consraints
; addNoInstanceErrs non_dicts -- I'm not sure if these can really happen
; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
simpl_theta = substTheta rev_env (map dictPred dicts)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
in
-- In effect, the bad and wierd insts cover all of the cases that
-- would make checkValidInstance fail; if it were called right after tcSimplifyDeriv
-- * wierd_preds ensures unambiguous instances (checkAmbiguity in checkValidInstance)
-- * ok_gla_pred ensures termination (checkInstTermination in checkValidInstance)
addNoInstanceErrs bad_insts `thenM_`
mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
returnM (substTheta rev_env simpl_theta)
; return simpl_theta }
where
doc = ptext SLIT("deriving classes for a data type")
\end{code}
......@@ -2667,12 +2642,6 @@ warnDefault ups default_ty
quotes (ppr default_ty),
pprDictsInFull tidy_dicts]
-- Used for the ...Thetas variants; all top level
badDerivedPred pred
= vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
ptext SLIT("type variables that are not data type parameters"),
nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
......
......@@ -108,7 +108,7 @@ module TcType (
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
......
......@@ -6,13 +6,14 @@ FamInstEnv: Type checked family instance declarations
\begin{code}
module FamInstEnv (
FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts,
FamInst(..), famInstTyCon, famInstTyVars,
pprFamInst, pprFamInstHdr, pprFamInsts,
famInstHead, mkLocalFamInst, mkImportedFamInst,
FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
famInstEnvElts, familyInstances,
lookupFamInstEnvExact, lookupFamInstEnv, lookupFamInstEnvUnify
lookupFamInstEnv, lookupFamInstEnvUnify
) where
#include "HsVersions.h"
......@@ -32,7 +33,6 @@ import UniqFM
import Outputable
import Maybe
import Monad
\end{code}
......@@ -60,6 +60,8 @@ data FamInst
--
famInstTyCon :: FamInst -> TyCon
famInstTyCon = fi_tycon
famInstTyVars = fi_tvs
\end{code}
\begin{code}
......@@ -187,6 +189,7 @@ This is used when we want the @TyCon@ of a particular family instance (e.g.,
during deriving classes).
\begin{code}
{- NOT NEEDED ANY MORE
lookupFamInstEnvExact :: (FamInstEnv -- External package inst-env
,FamInstEnv) -- Home-package inst-env
-> TyCon -> [Type] -- What we are looking for
......@@ -224,6 +227,7 @@ lookupFamInstEnvExact (pkg_ie, home_ie) fam tys
-- No match => try next
| otherwise
= find rest
-}
\end{code}
@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
......
......@@ -837,7 +837,7 @@ isClassTyCon other_tycon = False
tyConClass_maybe :: TyCon -> Maybe Class
tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
tyConClass_maybe ther_tycon = Nothing
tyConClass_maybe other_tycon = Nothing
isFamInstTyCon :: TyCon -> Bool
isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
......@@ -846,13 +846,13 @@ isFamInstTyCon other_tycon = False
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =
Just (fam, instTys)
tyConFamInst_maybe ther_tycon =
tyConFamInst_maybe other_tycon =
Nothing
tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) =
Just coe
tyConFamilyCoercion_maybe ther_tycon =
tyConFamilyCoercion_maybe other_tycon =
Nothing
\end{code}
......
......@@ -92,7 +92,7 @@ module Type (
-- Performing substitution on types
substTy, substTys, substTyWith, substTheta,
substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar,
substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
-- Pretty-printing
pprType, pprParendType, pprTyThingCategory, pprForAll,
......@@ -411,7 +411,6 @@ splitNewTyConApp_maybe other = Nothing
newTyConInstRhs :: TyCon -> [Type] -> Type
newTyConInstRhs tycon tys =
let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
\end{code}
......@@ -1313,6 +1312,9 @@ substTyVar subst@(TvSubst in_scope env) tv
Just ty -> ty -- See Note [Apply Once]
}
substTyVars :: TvSubst -> [TyVar] -> [Type]
substTyVars subst tvs = map (substTyVar subst) tvs
lookupTyVar :: TvSubst -> TyVar -> Maybe Type
-- See Note [Extending the TvSubst]
lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
......
......@@ -12,7 +12,7 @@ module Util (
zipLazy, stretchZipWith,
mapFst, mapSnd,
mapAndUnzip, mapAndUnzip3,
nOfThem, filterOut, partitionWith,
nOfThem, filterOut, partitionWith, splitEithers,
lengthExceeds, lengthIs, lengthAtLeast,
listLengthCmp, atLength, equalLength, compareLength,
......@@ -177,6 +177,13 @@ partitionWith f (x:xs) = case f x of
where
(bs,cs) = partitionWith f xs
splitEithers :: [Either a b] -> ([a], [b])
splitEithers [] = ([],[])
splitEithers (e : es) = case e of
Left x -> (x:xs, ys)
Right y -> (xs, y:ys)
where
(xs,ys) = splitEithers es
\end{code}
A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment