Commit 77bb0927 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Re-add FunTy (big patch)

With TypeInType Richard combined ForAllTy and FunTy, but that was often
awkward, and yielded little benefit becuase in practice the two were
always treated separately.  This patch re-introduces FunTy.  Specfically

* New type
    data TyVarBinder = TvBndr TyVar VisibilityFlag
  This /always/ has a TyVar it.  In many places that's just what
  what we want, so there are /lots/ of TyBinder -> TyVarBinder changes

* TyBinder still exists:
    data TyBinder = Named TyVarBinder | Anon Type

* data Type = ForAllTy TyVarBinder Type
            | FunTy Type Type
            |  ....

There are a LOT of knock-on changes, but they are all routine.

The Haddock submodule needs to be updated too
parent e33ca0e5
This diff is collapsed.
......@@ -6,18 +6,18 @@ import FieldLabel ( FieldLabel )
import Unique ( Uniquable )
import Outputable ( Outputable, OutputableBndr )
import BasicTypes (Arity)
import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyBinder)
import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyVarBinder)
data DataCon
data DataConRep
data EqSpec
filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder]
filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder]
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
dataConUnivTyBinders :: DataCon -> [TyBinder]
dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyBinders :: DataCon -> [TyBinder]
dataConExTyVarBinders :: DataCon -> [TyVarBinder]
dataConSourceArity :: DataCon -> Arity
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
......
......@@ -274,13 +274,13 @@ mkDictSelId name clas
sel_names = map idName (classAllSelIds clas)
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
binders = dataConUnivTyBinders data_con
tyvars = dataConUnivTyVars data_con
tyvars = dataConUnivTyVarBinders data_con
n_ty_args = length tyvars
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkForAllTys binders $
mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) $
sel_ty = mkForAllTys tyvars $
mkFunTy (mkClassPred clas (mkTyVarTys (map binderVar tyvars))) $
getNth arg_tys val_index
base_info = noCafIdInfo
......@@ -299,8 +299,6 @@ mkDictSelId name clas
-- so that the rule is always available to fire.
-- See Note [ClassOp/DFun selection] in TcInstDcls
n_ty_args = length tyvars
-- This is the built-in rule that goes
-- op (dfT d1 d2) ---> opT d1 d2
rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
......@@ -971,10 +969,9 @@ mkFCallId dflags uniq fcall ty
`setArityInfo` arity
`setStrictnessInfo` strict_sig
(bndrs, _) = tcSplitPiTys ty
arity = count isIdLikeBinder bndrs
strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
(bndrs, _) = tcSplitPiTys ty
arity = count isAnonTyBinder bndrs
strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
-- the call does not claim to be strict in its arguments, since they
-- may be lifted (foreign import prim) and the called code doesn't
-- necessarily force them. See Trac #11076.
......
......@@ -15,7 +15,7 @@ module PatSyn (
patSynName, patSynArity, patSynIsInfix,
patSynArgs,
patSynMatcher, patSynBuilder,
patSynUnivTyBinders, patSynExTyVars, patSynExTyBinders, patSynSig,
patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
......@@ -63,15 +63,13 @@ data PatSyn
-- psArgs
-- Universially-quantified type variables
psUnivTyVars :: [TyVar], -- Two linked fields; see DataCon
psUnivTyBinders :: [TyBinder], -- Note [TyBinders in DataCons]
psUnivTyVars :: [TyVarBinder],
-- Required dictionaries (may mention psUnivTyVars)
psReqTheta :: ThetaType,
-- Existentially-quantified type vars
psExTyVars :: [TyVar], -- Two linked fields; see DataCon
psExTyBinders :: [TyBinder], -- Note [TyBinders in DataCons]
psExTyVars :: [TyVarBinder],
-- Provided dictionaries (may mention psUnivTyVars or psExTyVars)
psProvTheta :: ThetaType,
......@@ -300,11 +298,9 @@ instance Data.Data PatSyn where
-- | Build a new pattern synonym
mkPatSyn :: Name
-> Bool -- ^ Is the pattern synonym declared infix?
-> ([TyVar], [TyBinder], ThetaType)
-- ^ Universially-quantified type variables
-> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables
-- and required dicts
-> ([TyVar], [TyBinder], ThetaType)
-- ^ Existentially-quantified type variables
-> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables
-- and provided dicts
-> [Type] -- ^ Original arguments
-> Type -- ^ Original result type
......@@ -316,14 +312,14 @@ mkPatSyn :: Name
-- NB: The univ and ex vars are both in TyBinder form and TyVar form for
-- convenience. All the TyBinders should be Named!
mkPatSyn name declared_infix
(univ_tvs, univ_bndrs, req_theta)
(ex_tvs, ex_bndrs, prov_theta)
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
orig_args
orig_res_ty
matcher builder field_labels
= MkPatSyn {psName = name, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psUnivTyBinders = univ_bndrs,
psExTyVars = ex_tvs, psExTyBinders = ex_bndrs,
psUnivTyVars = univ_tvs,
psExTyVars = ex_tvs,
psProvTheta = prov_theta, psReqTheta = req_theta,
psInfix = declared_infix,
psArgs = orig_args,
......@@ -359,20 +355,20 @@ patSynFieldType ps label
Just (_, ty) -> ty
Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
patSynUnivTyBinders :: PatSyn -> [TyBinder]
patSynUnivTyBinders = psUnivTyBinders
patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]
patSynUnivTyVarBinders = psUnivTyVars
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
patSynExTyVars ps = map binderVar (psExTyVars ps)
patSynExTyBinders :: PatSyn -> [TyBinder]
patSynExTyBinders = psExTyBinders
patSynExTyVarBinders :: PatSyn -> [TyVarBinder]
patSynExTyVarBinders = psExTyVars
patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req
, psArgs = arg_tys, psOrigResTy = res_ty })
= (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty)
= (map binderVar univ_tvs, req, map binderVar ex_tvs, prov, arg_tys, res_ty)
patSynMatcher :: PatSyn -> (Id,Bool)
patSynMatcher = psMatcher
......@@ -401,7 +397,7 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
, text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = univ_tvs ++ ex_tvs
tyvars = map binderVar (univ_tvs ++ ex_tvs)
patSynInstResTy :: PatSyn -> [Type] -> Type
-- Return the type of whole pattern
......@@ -414,19 +410,19 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
inst_tys
= ASSERT2( length univ_tvs == length inst_tys
, text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
substTyWith univ_tvs inst_tys res_ty
substTyWith (map binderVar univ_tvs) inst_tys res_ty
-- | Print the type of a pattern synonym. The foralls are printed explicitly
pprPatSynType :: PatSyn -> SDoc
pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psOrigResTy = orig_res_ty })
= sep [ pprForAllImplicit univ_tvs
= sep [ pprForAll univ_tvs
, pprThetaArrowTy req_theta
, ppWhen insert_empty_ctxt $ parens empty <+> darrow
, pprType sigma_ty ]
where
sigma_ty = mkForAllTys (mkNamedBinders Specified ex_tvs) $
sigma_ty = mkForAllTys ex_tvs $
mkFunTys prov_theta $
mkFunTys orig_args orig_res_ty
insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
......@@ -970,15 +970,15 @@ getTyDescription ty
TyVarTy _ -> "*"
AppTy fun _ -> getTyDescription fun
TyConApp tycon _ -> getOccString tycon
ForAllTy (Anon _) res -> '-' : '>' : fun_result res
ForAllTy (Named {}) ty -> getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n
CastTy ty _ -> getTyDescription ty
CoercionTy co -> pprPanic "getTyDescription" (ppr co)
}
where
fun_result (ForAllTy (Anon _) res) = '>' : fun_result res
fun_result other = getTyDescription other
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
......
......@@ -106,10 +106,11 @@ typeArity ty
= go initRecTc ty
where
go rec_nts ty
| Just (bndr, ty') <- splitPiTy_maybe ty
= if isIdLikeBinder bndr
then typeOneShot (binderType bndr) : go rec_nts ty'
else go rec_nts ty'
| Just (_, ty') <- splitForAllTy_maybe ty
= go rec_nts ty'
| Just (arg,res) <- splitFunTy_maybe ty
= typeOneShot arg : go rec_nts res
| Just (tc,tys) <- splitTyConApp_maybe ty
, Just (ty', _) <- instNewTyCon_maybe tc tys
......@@ -970,13 +971,15 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
| n == 0
= (getTCvInScope subst, reverse eis)
| Just (bndr,ty') <- splitPiTy_maybe ty
= let ((subst', eta_id'), new_n) = caseBinder bndr
(\tv -> (Type.substTyVarBndr subst tv, n))
(\arg_ty -> (freshEtaVar n subst arg_ty, n-1))
in
-- Avoid free vars of the original expression
go new_n subst' ty' (EtaVar eta_id' : eis)
| Just (tv,ty') <- splitForAllTy_maybe ty
, let (subst', tv') = Type.substTyVarBndr subst tv
-- Avoid free vars of the original expression
= go n subst' ty' (EtaVar tv' : eis)
| Just (arg_ty, res_ty) <- splitFunTy_maybe ty
, let (subst', eta_id') = freshEtaId n subst arg_ty
-- Avoid free vars of the original expression
= go (n-1) subst' res_ty (EtaVar eta_id' : eis)
| Just (co, ty') <- topNormaliseNewType_maybe ty
= -- Given this:
......@@ -1009,7 +1012,7 @@ subst_bind = substBindSC
--------------
freshEtaVar :: Int -> TCvSubst -> Type -> (TCvSubst, Var)
freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id)
-- Make a fresh Id, with specified type (after applying substitution)
-- It should be "fresh" in the sense that it's not in the in-scope set
-- of the TvSubstEnv; and it should itself then be added to the in-scope
......@@ -1017,7 +1020,7 @@ freshEtaVar :: Int -> TCvSubst -> Type -> (TCvSubst, Var)
--
-- The Int is just a reasonable starting point for generating a unique;
-- it does not necessarily have to be unique itself.
freshEtaVar n subst ty
freshEtaId n subst ty
= (subst', eta_id')
where
ty' = Type.substTy subst ty
......
......@@ -352,8 +352,10 @@ orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = unitNameSet funTyConName -- NB! See Trac #8535
`unionNameSet` orphNamesOfType (binderType bndr)
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
`unionNameSet` orphNamesOfType res
orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535
`unionNameSet` orphNamesOfType arg
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
......
......@@ -558,9 +558,10 @@ lintRhs rhs
, length args == 5
= flip fix binders0 $ \loopBinders binders -> case binders of
-- imitate @lintCoreExpr (Lam ...)@
var : vars -> addLoc (LambdaBodyOf var) $ lintBinder var $ \var' -> do
body_ty <- loopBinders vars
return $ mkPiType var' body_ty
var : vars -> addLoc (LambdaBodyOf var) $
lintBinder var $ \var' ->
do { body_ty <- loopBinders vars
; return $ mkLamType var' body_ty }
-- imitate @lintCoreExpr (App ...)@
[] -> do
fun_ty <- lintCoreExpr fun
......@@ -703,7 +704,7 @@ lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
lintBinder var $ \ var' ->
do { body_ty <- lintCoreExpr expr
; return $ mkPiType var' body_ty }
; return $ mkLamType var' body_ty }
lintCoreExpr e@(Case scrut var alt_ty alts) =
-- Check the scrutinee
......@@ -1097,12 +1098,12 @@ lintType ty@(TyConApp tc tys)
-- arrows can related *unlifted* kinds, so this has to be separate from
-- a dependent forall.
lintType ty@(ForAllTy (Anon t1) t2)
lintType ty@(FunTy t1 t2)
= do { k1 <- lintType t1
; k2 <- lintType t2
; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
lintType t@(ForAllTy (Named tv _vis) ty)
lintType t@(ForAllTy (TvBndr tv _vis) ty)
= do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t)
; lintTyBndr tv $ \tv' ->
do { k <- lintType ty
......@@ -1192,11 +1193,11 @@ lint_app doc kfn kas
| Just kfn' <- coreView kfn
= go_app in_scope kfn' ka
go_app _ (ForAllTy (Anon kfa) kfb) (_,ka)
go_app _ (FunTy kfa kfb) (_,ka)
= do { unless (ka `eqType` kfa) (addErrL fail_msg)
; return kfb }
go_app in_scope (ForAllTy (Named kv _vis) kfn) (ta,ka)
go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka)
= do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg)
; return (substTyWithInScope in_scope [kv] [ta] kfn) }
......@@ -1346,7 +1347,7 @@ lintCoercion (ForAllCo tv1 kind_co co)
do {
; (k3, k4, t1, t2, r) <- lintCoercion co
; in_scope <- getInScope
; let tyl = mkNamedForAllTy tv1 Invisible t1
; let tyl = mkInvForAllTy tv1 t1
subst = mkTvSubst in_scope $
-- We need both the free vars of the `t2` and the
-- free vars of the range of the substitution in
......@@ -1355,7 +1356,7 @@ lintCoercion (ForAllCo tv1 kind_co co)
-- linted and `tv2` has the same unique as `tv1`.
-- See Note [The substitution invariant]
unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)
tyr = mkNamedForAllTy tv2 Invisible $
tyr = mkInvForAllTy tv2 $
substTy subst t2
; return (k3, k4, tyl, tyr, r) } }
......
......@@ -103,7 +103,7 @@ exprType (Let bind body)
exprType (Case _ _ ty _) = ty
exprType (Cast _ co) = pSnd (coercionKind co)
exprType (Tick _ e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType (Lam binder expr) = mkLamType binder (exprType expr)
exprType e@(App _ _)
= case collectArgs e of
(fun, args) -> applyTypeToArgs e (exprType fun) args
......
......@@ -793,7 +793,7 @@ data TypeMapX a
trieMapView :: Type -> Maybe Type
trieMapView ty | Just ty' <- coreViewOneStarKind ty = Just ty'
trieMapView (TyConApp tc tys@(_:_)) = Just $ foldl AppTy (TyConApp tc []) tys
trieMapView (ForAllTy (Anon arg) res)
trieMapView (FunTy arg res)
= Just ((TyConApp funTyCon [] `AppTy` arg) `AppTy` res)
trieMapView _ = Nothing
......@@ -824,13 +824,13 @@ instance Eq (DeBruijn Type) where
-> D env t1 == D env' t1' && D env t2 == D env' t2'
(s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s
-> D env t1 == D env' t1' && D env t2 == D env' t2'
(ForAllTy (Anon t1) t2, ForAllTy (Anon t1') t2')
(FunTy t1 t2, FunTy t1' t2')
-> D env t1 == D env' t1' && D env t2 == D env' t2'
(TyConApp tc tys, TyConApp tc' tys')
-> tc == tc' && D env tys == D env' tys'
(LitTy l, LitTy l')
-> l == l'
(ForAllTy (Named tv _) ty, ForAllTy (Named tv' _) ty')
(ForAllTy (TvBndr tv _) ty, ForAllTy (TvBndr tv' _) ty')
-> D env (tyVarKind tv) == D env' (tyVarKind tv') &&
D (extendCME env tv) ty == D (extendCME env' tv') ty'
(CoercionTy {}, CoercionTy {})
......@@ -870,9 +870,9 @@ lkT (D env ty) m = go ty m
go (TyConApp tc []) = tm_tycon >.> lkDNamed tc
go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty)
go (LitTy l) = tm_tylit >.> lkTyLit l
go (ForAllTy (Named tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty)
go (ForAllTy (TvBndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty)
>=> lkBndr env tv
go ty@(ForAllTy (Anon _) _) = pprPanic "lkT FunTy" (ppr ty)
go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty)
go (CastTy t _) = go t
go (CoercionTy {}) = tm_coerce
......@@ -887,11 +887,11 @@ xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f
xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f }
xtT (D env (CastTy t _)) f m = xtT (D env t) f m
xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f }
xtT (D env (ForAllTy (Named tv _) ty)) f m
xtT (D env (ForAllTy (TvBndr tv _) ty)) f m
= m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)
|>> xtBndr env tv f }
xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)
xtT (D _ ty@(ForAllTy (Anon _) _)) _ _ = pprPanic "xtT FunTy" (ppr ty)
xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)
xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty)
fdT :: (a -> b -> b) -> TypeMapX a -> b -> b
fdT k m = foldTM k (tm_var m)
......
......@@ -624,7 +624,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
; (bndrs, ds_lhs) <- liftM collectBinders
(dsHsWrapper spec_co (Var poly_id))
; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; let spec_ty = mkLamTypes bndrs (exprType ds_lhs)
; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
-- , text "spec_co:" <+> ppr spec_co
-- , text "ds_rhs:" <+> ppr ds_lhs ]) $
......
......@@ -195,15 +195,9 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall mDeclHeader = do
let
ty = pFst $ coercionKind co
(all_bndrs, io_res_ty) = tcSplitPiTys ty
(named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs
tvs = ASSERT( fst (span isNamedBinder all_bndrs)
`equalLength` named_bndrs )
-- ensure that the named binders all come first
map (binderVar "dsFCall") named_bndrs
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
ty = pFst $ coercionKind co
(tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty
(arg_tys, io_res_ty) = tcSplitFunTys rho
args <- newSysLocalsDs arg_tys
(val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
......@@ -266,7 +260,8 @@ dsFCall fn_id co fcall mDeclHeader = do
return (fcall, empty)
let
-- Build the worker
worker_ty = mkForAllTys named_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
worker_ty = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
tvs = map binderVar tv_bndrs
the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
......@@ -300,12 +295,9 @@ dsPrimCall :: Id -> Coercion -> ForeignCall
dsPrimCall fn_id co fcall = do
let
ty = pFst $ coercionKind co
(bndrs, io_res_ty) = tcSplitPiTys ty
(tvs, arg_tys) = partitionBinders bndrs
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
(tvs, fun_ty) = tcSplitForAllTys ty
(arg_tys, io_res_ty) = tcSplitFunTys fun_ty
MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
args <- newSysLocalsDs arg_tys
ccall_uniq <- newUnique
......@@ -416,8 +408,6 @@ dsFExportDynamic :: Id
-> CCallConv
-> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic id co0 cconv = do
MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
-- make sure that the named binders all come first
fe_id <- newSysLocalDs ty
mod <- getModule
dflags <- getDynFlags
......@@ -481,8 +471,8 @@ dsFExportDynamic id co0 cconv = do
where
ty = pFst (coercionKind co0)
(bndrs, fn_res_ty) = tcSplitPiTys ty
(tvs, [arg_ty]) = partitionBinders bndrs
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
-- Must have an IO type; hence Just
......
......@@ -586,12 +586,12 @@ toLHsSigWcType ty
= mkLHsSigWcType (go ty)
where
go :: Type -> LHsType RdrName
go ty@(ForAllTy (Anon arg) _)
go ty@(FunTy arg _)
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
, hst_body = go tau })
go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res)
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
......
......@@ -29,7 +29,7 @@ import MkId
import Class
import TyCon
import Type
import TyCoRep( TyBinder(..) )
import TyCoRep( TyBinder(..), TyVarBinder(..) )
import Id
import TcType
......@@ -112,9 +112,8 @@ buildDataCon :: FamInstEnvs
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
-> [TyVar] -> [TyBinder] -- Universals; see
-- Note [TyBinders in DataCons] in DataCon
-> [TyVar] -> [TyBinder] -- existentials
-> [TyVar] -> [TyBinder] -- Universals
-> [TyVarBinder] -- existentials
-> [EqSpec] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
......@@ -125,9 +124,9 @@ buildDataCon :: FamInstEnvs
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
-- c) Sorts out the TyBinders. See Note [TyBinders in DataCons] in DataCon
-- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
univ_tvs univ_bndrs ex_tvs ex_bndrs eq_spec ctxt arg_tys res_ty rep_tycon
univ_tvs univ_bndrs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
......@@ -137,11 +136,11 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; let dc_bndrs = mkDataConUnivTyBinders univ_bndrs univ_tvs
; let dc_bndrs = mkDataConUnivTyVarBinders univ_tvs univ_bndrs
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs dc_bndrs ex_tvs ex_bndrs eq_spec ctxt
dc_bndrs ex_tvs eq_spec ctxt
arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
......@@ -171,25 +170,25 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
tyCoVarsOfType pred `intersectVarSet` arg_tyvars
mkDataConUnivTyBinders :: [TyBinder] -> [TyVar] -- From the TyCon
-> [TyBinder] -- For the DataCon
mkDataConUnivTyVarBinders :: [TyVar] -> [TyBinder] -- From the TyCon
-> [TyVarBinder] -- For the DataCon
-- See Note [Building the TyBinders for a DataCon]
mkDataConUnivTyBinders bndrs tvs
= zipWith mk_binder bndrs tvs
mkDataConUnivTyVarBinders tvs bndrs
= zipWith mk_binder tvs bndrs
where
mk_binder bndr tv = mkNamedBinder vis tv
mk_binder tv bndr = mkTyVarBinder vis tv
where
vis = case bndr of
Anon _ -> Specified
Named _ Visible -> Specified
Named _ vis -> vis
Anon _ -> Specified
Named (TvBndr _ Visible) -> Specified
Named (TvBndr _ vis) -> vis
{- Note [Building the TyBinders for a DataCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A DataCon needs to keep track of the visibility of its universals and
existentials, so that visible type application can work properly. This
is done by storing the universal and existential TyBinders, along with
the TyVars. See Note [TyBinders in DataCons] in DataCon.
is done by storing the universal and existential TyVarBinders.
See Note [TyVarBinders in DataCons] in DataCon.
During construction of a DataCon, we often start from the TyBinders of
the parent TyCon. For example
......@@ -203,8 +202,8 @@ of the DataCon. Here is an example:
The TyCon has
tyConTyVars = [ k:*, a:k->*, b:k]
tyConTyBinders = [ Named (k :: *) Invisible, Anon (k->*), Anon k ]
tyConTyVars = [ k:*, a:k->*, b:k]
tyConTyBinders = [ Named (TvBndr (k :: *) Invisible), Anon (k->*), Anon k ]
The TyBinders for App line up with App's kind, given above.
......@@ -213,9 +212,9 @@ But the DataCon MkApp has the type
That is, its TyBinders should be
dataConUnivTyVars = [ Named (k:*) Invisible
, Named (a:k->*) Specified
, Named (b:k) Specified ]
dataConUnivTyVarBinders = [ TvBndr (k:*) Invisible
, TvBndr (a:k->*) Specified
, TvBndr (b:k) Specified ]
So we want to take the TyCon's TyBinders and the TyCon's TyVars and
merge them, pulling
......@@ -237,15 +236,15 @@ DataCon (mkDataCon does no further work).
------------------------------------------------------
buildPatSyn :: Name -> Bool
-> (Id,Bool) -> Maybe (Id, Bool)
-> ([TyVar], [TyBinder], ThetaType) -- ^ Univ and req
-> ([TyVar], [TyBinder], ThetaType) -- ^ Ex and prov
-> ([TyVarBinder], ThetaType) -- ^ Univ and req
-> ([TyVarBinder], ThetaType) -- ^ Ex and prov
-> [Type] -- ^ Argument types
-> Type -- ^ Result type
-> [FieldLabel] -- ^ Field labels for
-- a record pattern synonym
-> PatSyn
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(univ_tvs, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta) arg_tys
(univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
pat_ty field_labels
= -- The assertion checks that the matcher is
-- compatible with the pattern synonym
......@@ -263,17 +262,17 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
, ppr req_theta <+> twiddle <+> ppr req_theta1
, ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
mkPatSyn src_name declared_infix
(univ_tvs, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta)
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty
matcher builder field_labels
where
((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
(ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
(ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
(arg_tys1, _) = tcSplitFunTys cont_tau
twiddle = char '~'
subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
(mkTyVarTys (univ_tvs ++ ex_tvs))
(mkTyVarTys (map binderVar (univ_tvs ++ ex_tvs)))
------------------------------------------------------
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
......@@ -342,7 +341,6 @@ buildClass tycon_name tvs roles sc_theta binders
[{- No fields -}]
tvs binders
[{- no existentials -}]
[{- no existentials -}]
[{- No GADT equalities -}]
[{- No theta -}]
arg_tys
......
......@@ -1314,8 +1314,8 @@ freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet
freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv
freeNamesIfTyBinder :: IfaceTyConBinder -> NameSet
freeNamesIfTyBinder (IfaceAnon _ ty) = freeNamesIfType ty
freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b
freeNamesIfTyBinder (IfaceAnon b) =