Commit 0390e4a0 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor to eliminate FamTyConShape

Consider this note (TcTyClsDecls)

  Note [Type-checking type patterns]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  When typechecking the patterns of a family instance declaration, we can't
  rely on using the family TyCon itself, because this is sometimes called
  from within a type-checking knot. (Specifically for closed type families.)
  The FamTyConShape gives just enough information to do the job.

I realised that this exact purpose can be served by TcTyCons, and
in fact rather better.  So this patch

* Refactors FamTyConShape out of existence, replacing it with TcTyCOn

* I also got rid Type.filterOutInvisibleTyVars, which was a very
  complex way to do something quite simple.  I replaced the calls
  with TyCon.tyConVisibleTyVars.

No change in behaviour.
parent 8bf865d3
......@@ -612,7 +612,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
-- (1) do the work of verifying the synonym group
; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo
; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
(L (getLoc fam_lname) eqn)
-- (2) check for validity
......@@ -648,7 +648,7 @@ tcDataFamInstDecl mb_clsinfo
-- Kind check type patterns
; let mb_kind_env = thdOf3 <$> mb_clsinfo
; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo tv_names pats
; tcFamTyPats fam_tc mb_clsinfo tv_names pats
(kcDataDefn mb_kind_env decl) $
\tvs pats res_kind ->
do { stupid_theta <- solveEqualities $ tcHsContext ctxt
......
......@@ -1357,7 +1357,7 @@ reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
; rhs' <- reifyType rhs
; return (TH.TySynEqn annot_th_lhs rhs') }
where
fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
fam_tvs = tyConVisibleTyVars fam_tc
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
......@@ -1391,7 +1391,7 @@ reifyTyCon tc
injRHS = map (reifyName . tyVarName)
(filterByList ms tvs)
in (sig, inj)
; tvs' <- reifyTyVars tvs (Just tc)
; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
; let tfHead =
TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
; if isOpenTypeFamilyTyCon tc
......@@ -1408,20 +1408,19 @@ reifyTyCon tc
[]) } }
| isDataFamilyTyCon tc
= do { let tvs = tyConTyVars tc
res_kind = tyConResKind tc
= do { let res_kind = tyConResKind tc
; kind' <- fmap Just (reifyKind res_kind)
; tvs' <- reifyTyVars tvs (Just tc)
; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
; fam_envs <- tcGetFamInstEnvs
; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
; return (TH.FamilyI
(TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
| Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
| Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
= do { rhs' <- reifyType rhs
; tvs' <- reifyTyVars tvs (Just tc)
; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
; return (TH.TyConI
(TH.TySynD (reifyName tc) tvs' rhs'))
}
......@@ -1432,7 +1431,7 @@ reifyTyCon tc
dataCons = tyConDataCons tc
isGadt = isGadtSyntaxTyCon tc
; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
; r_tvs <- reifyTyVars tvs (Just tc)
; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
; let name = reifyName tc
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc =
......@@ -1497,7 +1496,7 @@ reifyDataCon isGadtDataCon tys dc
ret_con | null ex_tvs' && null theta' = return main_con
| otherwise = do
{ cxt <- reifyCxt theta'
; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
; ex_tvs'' <- reifyTyVars ex_tvs'
; return (TH.ForallC ex_tvs'' cxt main_con) }
; ASSERT( arg_tys `equalLength` dcdBangs )
ret_con }
......@@ -1535,7 +1534,7 @@ reifyClass cls
; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
; assocTys <- concatMapM reifyAT ats
; ops <- concatMapM reify_op op_stuff
; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)
; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
; return (TH.ClassI dec insts) }
where
......@@ -1607,7 +1606,7 @@ reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
reifyClassInstances cls insts
= mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
where
tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)
tvs = tyConVisibleTyVars (classTyCon cls)
reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
-- includes only *visible* tvs
......@@ -1635,7 +1634,7 @@ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
reifyFamilyInstances fam_tc fam_insts
= mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
where
fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
fam_tvs = tyConVisibleTyVars fam_tc
reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
-- includes only *visible* tvs
......@@ -1703,7 +1702,7 @@ reify_for_all :: TyCoRep.Type -> TcM TH.Type
reify_for_all ty
= do { cxt' <- reifyCxt cxt;
; tau' <- reifyType tau
; tvs' <- reifyTyVars tvs Nothing
; tvs' <- reifyTyVars tvs
; return (TH.ForallT tvs' cxt' tau') }
where
(tvs, cxt, tau) = tcSplitSigmaTy ty
......@@ -1721,9 +1720,9 @@ reifyPatSynType
-- signature; see NOTE [Pattern synonym signatures and Template
-- Haskell]
reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
= do { univTyVars' <- reifyTyVars univTyVars Nothing
= do { univTyVars' <- reifyTyVars univTyVars
; req' <- reifyCxt req
; exTyVars' <- reifyTyVars exTyVars Nothing
; exTyVars' <- reifyTyVars exTyVars
; prov' <- reifyCxt prov
; tau' <- reifyType (mkFunTys argTys resTy)
; return $ TH.ForallT univTyVars' req'
......@@ -1738,16 +1737,9 @@ reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyTyVars :: [TyVar]
-> Maybe TyCon -- the tycon if the tycovars are from a tycon.
-- Used to detect which tvs are implicit.
-> TcM [TH.TyVarBndr]
reifyTyVars tvs m_tc = mapM reify_tv tvs'
reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
reifyTyVars tvs = mapM reify_tv tvs
where
tvs' = case m_tc of
Just tc -> filterOutInvisibleTyVars tc tvs
Nothing -> tvs
-- even if the kind is *, we need to include a kind annotation,
-- in case a poly-kind would be inferred without the annotation.
-- See #8953 or test th/T8953
......
......@@ -15,7 +15,7 @@ module TcTyClsDecls (
-- Functions used by TcInstDcls to check
-- data/type family instance declarations
kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn, famTyConShape,
tcFamTyPats, tcTyFamInstEqn,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
wrongKindOfFamily, dataConCtxt
) where
......@@ -372,7 +372,6 @@ kcTyClGroup decls
kc_binders = tyConBinders tc
kc_res_kind = tyConResKind tc
kc_tyvars = tyConTyVars tc
kc_flav = tyConFlavour tc
; kvs <- kindGeneralize (mkTyConKind kc_binders kc_res_kind)
; let all_binders = mkNamedTyConBinders Inferred kvs ++ kc_binders
......@@ -388,7 +387,7 @@ kcTyClGroup decls
; return (mkTcTyCon name all_binders' kc_res_kind'
(tcTyConScopedTyVars tc)
kc_flav) }
(tyConFlavour tc)) }
generaliseTCD :: TcTypeEnv
-> LTyClDecl GhcRn -> TcM [TcTyCon]
......@@ -617,7 +616,7 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
= case fd_info of
ClosedTypeFamily (Just eqns) ->
do { fam_tc <- kcLookupTcTyCon fam_tc_name
; mapM_ (kcTyFamInstEqn (famTyConShape fam_tc)) eqns }
; mapM_ (kcTyFamInstEqn fam_tc) eqns }
_ -> return ()
-------------------
......@@ -824,7 +823,7 @@ tcTyClDecl1 _parent roles_info
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name)
, fdTyVars = tvs, fdResultSig = L _ sig
, fdResultSig = L _ sig
, fdInjectivityAnn = inj })
| DataFamily <- fam_info
= tcTyClTyVars tc_name $ \ binders res_kind -> do
......@@ -874,13 +873,10 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
Just eqns -> do {
-- Process the equations, creating CoAxBranches
; let fam_tc_shape = FamTyConShape { fs_name = tc_name
, fs_arity = length $ hsQTvExplicit tvs
, fs_flavor = TypeFam
, fs_binders = binders
, fs_res_kind = res_kind }
; let tc_fam_tc = mkTcTyCon tc_name binders res_kind
[] ClosedTypeFamilyFlavour
; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns
; branches <- mapM (tcTyFamInstEqn tc_fam_tc Nothing) eqns
-- Do not attempt to drop equations dominated by earlier
-- ones here; in the case of mutual recursion with a data
-- type, we get a knot-tying failure. Instead we check
......@@ -1099,8 +1095,8 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = lname@(L _ tc_name)
setSrcSpan loc $
tcAddFamInstCtxt (text "default type instance") tc_name $
do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
; let shape@(FamTyConShape { fs_name = fam_tc_name
, fs_arity = fam_arity }) = famTyConShape fam_tc
; let fam_tc_name = tyConName fam_tc
fam_arity = length (tyConVisibleTyVars fam_tc)
-- Kind of family check
; ASSERT( fam_tc_name == tc_name )
......@@ -1124,7 +1120,7 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = lname@(L _ tc_name)
-- type default LHS can mention *different* type variables than the
-- enclosing class. So it's treated more as a freestanding beast.
; (pats', rhs_ty)
<- tcFamTyPats shape Nothing all_vars pats
<- tcFamTyPats fam_tc Nothing all_vars pats
(kcTyFamEqnRhs Nothing pp_lhs rhs) $
\tvs pats rhs_kind ->
do { rhs_ty <- solveEqualities $
......@@ -1166,20 +1162,21 @@ message isn't great, mind you. (Trac #11361 was caused by not doing a
proper tcMatchTys here.) -}
-------------------------
kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name })
kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn tc_fam_tc
(L loc (HsIB { hsib_vars = tv_names
, hsib_body = FamEqn { feqn_tycon = lname@(L _ eqn_tc_name)
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = hs_ty }}))
= setSrcSpan loc $
do { checkTc (fam_tc_name == eqn_tc_name)
(wrongTyFamName fam_tc_name eqn_tc_name)
do { checkTc (fam_name == eqn_tc_name)
(wrongTyFamName fam_name eqn_tc_name)
; discardResult $
tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
tc_fam_ty_pats tc_fam_tc Nothing -- not an associated type
tv_names pats (kcTyFamEqnRhs Nothing pp_lhs hs_ty) }
where
fam_name = tyConName tc_fam_tc
pp_lhs = pprFamInstLHS lname pats fixity [] Nothing
-- Infer the kind of the type on the RHS of a type family eqn. Then use
......@@ -1203,19 +1200,19 @@ kcTyFamEqnRhs mb_clsinfo pp_lhs_ty rhs_hs_ty lhs_ki
bogus_ty = pprPanic "kcTyFamEqnRhs" (pp_lhs_ty $$ ppr rhs_hs_ty)
tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
-> TcM CoAxBranch
-- Needs to be here, not in TcInstDcls, because closed families
-- (typechecked here) have TyFamInstEqns
tcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name }) mb_clsinfo
tcTyFamInstEqn fam_tc mb_clsinfo
(L loc (HsIB { hsib_vars = tv_names
, hsib_body = FamEqn { feqn_tycon = lname@(L _ eqn_tc_name)
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = hs_ty }}))
= ASSERT( fam_tc_name == eqn_tc_name )
= ASSERT( getName fam_tc == eqn_tc_name )
setSrcSpan loc $
tcFamTyPats fam_tc_shape mb_clsinfo tv_names pats
tcFamTyPats fam_tc mb_clsinfo tv_names pats
(kcTyFamEqnRhs mb_clsinfo pp_lhs hs_ty) $
\tvs pats res_kind ->
do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
......@@ -1223,7 +1220,7 @@ tcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name }) mb_clsinfo
; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs
; pats' <- zonkTcTypeToTypes ze pats
; rhs_ty' <- zonkTcTypeToType ze rhs_ty
; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTyVars tvs')
; traceTc "tcTyFamInstEqn" (ppr fam_tc <+> pprTyVars tvs')
-- don't print out the pats here, as they might be zonked inside the knot
; return (mkCoAxBranch tvs' [] pats' rhs_ty'
(map (const Nominal) tvs')
......@@ -1313,9 +1310,9 @@ to generate a desugaring. It is used during type-checking (not kind-checking).
Note [Type-checking type patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When typechecking the patterns of a family instance declaration, we can't
rely on using the family TyCon, because this is sometimes called
rely on using the family TyCon itself, because this is sometimes called
from within a type-checking knot. (Specifically for closed type families.)
The type FamTyConShape gives just enough information to do the job.
The TcTyCon gives just enough information to do the job.
See also Note [tc_fam_ty_pats vs tcFamTyPats]
......@@ -1355,27 +1352,8 @@ two bad things could happen:
-}
-----------------
data TypeOrDataFamily = TypeFam | DataFam
data FamTyConShape = FamTyConShape { fs_name :: Name
, fs_arity :: Arity -- the visible args
, fs_flavor :: TypeOrDataFamily
, fs_binders :: [TyConBinder]
, fs_res_kind :: Kind }
-- See Note [Type-checking type patterns]
famTyConShape :: TyCon -> FamTyConShape
famTyConShape fam_tc
= FamTyConShape { fs_name = tyConName fam_tc
, fs_arity = length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
, fs_flavor = flav
, fs_binders = tyConBinders fam_tc
, fs_res_kind = tyConResKind fam_tc }
where
flav
| isTypeFamilyTyCon fam_tc = TypeFam
| otherwise = DataFam
tc_fam_ty_pats :: FamTyConShape
tc_fam_ty_pats :: TcTyCon -- The family TcTyCon
-- See Note [Type-checking type patterns]
-> Maybe ClsInstInfo
-> [Name] -- Bound kind/type variable names
-> HsTyPats GhcRn -- Type patterns
......@@ -1394,23 +1372,20 @@ tc_fam_ty_pats :: FamTyConShape
-- In that case, the type variable 'a' will *already be in scope*
-- (and, if C is poly-kinded, so will its kind parameter).
tc_fam_ty_pats (FamTyConShape { fs_name = name, fs_arity = arity
, fs_flavor = flav, fs_binders = binders
, fs_res_kind = res_kind })
mb_clsinfo tv_names arg_pats
tc_fam_ty_pats tc_fam_tc mb_clsinfo tv_names arg_pats
kind_checker
= do { -- First, check the arity.
-- If we wait until validity checking, we'll get kind
-- errors below when an arity error will be much easier to
-- understand.
let should_check_arity
| TypeFam <- flav = True
| DataFamilyFlavour <- flav = False
-- why not check data families? See [Arity of data families] in FamInstEnv
| otherwise = False
| otherwise = True
; when should_check_arity $
checkTc (arg_pats `lengthIs` arity) $
wrongNumberOfParmsErr arity
checkTc (arg_pats `lengthIs` vis_arity) $
wrongNumberOfParmsErr vis_arity
-- report only explicit arguments
-- Kind-check and quantify
......@@ -1418,22 +1393,26 @@ tc_fam_ty_pats (FamTyConShape { fs_name = name, fs_arity = arity
; (arg_tvs, (args, stuff)) <- tcImplicitTKBndrs tv_names $
do { let loc = nameSrcSpan name
lhs_fun = L loc (HsTyVar NotPromoted (L loc name))
bogus_fun_ty = pprPanic "tc_fam_ty_pats" (ppr name $$ ppr arg_pats)
fun_kind = mkTyConKind binders res_kind
fun_ty = mkTyConApp tc_fam_tc []
fun_kind = tyConKind tc_fam_tc
mb_kind_env = thdOf3 <$> mb_clsinfo
; (_, args, res_kind_out)
<- tcInferApps typeLevelMode mb_kind_env
lhs_fun bogus_fun_ty fun_kind arg_pats
lhs_fun fun_ty fun_kind arg_pats
; stuff <- kind_checker res_kind_out
; return ((args, stuff), emptyVarSet) }
; return (arg_tvs, args, stuff) }
where
name = tyConName tc_fam_tc
vis_arity = length (tyConVisibleTyVars tc_fam_tc)
flav = tyConFlavour tc_fam_tc
-- See Note [tc_fam_ty_pats vs tcFamTyPats]
tcFamTyPats :: FamTyConShape
tcFamTyPats :: TcTyCon
-> Maybe ClsInstInfo
-> [Name] -- Implicitly bound kind/type variable names
-> HsTyPats GhcRn -- Type patterns
......@@ -1445,11 +1424,11 @@ tcFamTyPats :: FamTyConShape
-> TcKind
-> TcM a) -- NB: You can use solveEqualities here.
-> TcM a
tcFamTyPats fam_shape@(FamTyConShape { fs_name = name, fs_flavor = fam_flav })
mb_clsinfo tv_names arg_pats kind_checker thing_inside
tcFamTyPats tc_fam_tc mb_clsinfo
tv_names arg_pats kind_checker thing_inside
= do { (fam_used_tvs, typats, (more_typats, res_kind))
<- solveEqualities $ -- See Note [Constraints in patterns]
tc_fam_ty_pats fam_shape mb_clsinfo
tc_fam_ty_pats tc_fam_tc mb_clsinfo
tv_names arg_pats kind_checker
{- TODO (RAE): This should be cleverer. Consider this:
......@@ -1482,13 +1461,12 @@ tcFamTyPats fam_shape@(FamTyConShape { fs_name = name, fs_flavor = fam_flav })
-- above would fail. TODO (RAE): Update once the solveEqualities
-- bit is cleverer.
; traceTc "tcFamTyPats" (ppr name $$ ppr all_pats $$ ppr qtkvs)
; traceTc "tcFamTyPats" (ppr (getName tc_fam_tc)
$$ ppr all_pats $$ ppr qtkvs)
-- Don't print out too much, as we might be in the knot
-- See Note [Free-floating kind vars] in TcHsType
; let tc_flav = case fam_flav of
TypeFam -> OpenTypeFamilyFlavour
DataFam -> DataFamilyFlavour
; let tc_flav = tyConFlavour tc_fam_tc
all_mentioned_tvs = mkVarSet qtkvs
-- qtkvs has all the tyvars bound by LHS
-- type patterns
......@@ -1497,7 +1475,8 @@ tcFamTyPats fam_shape@(FamTyConShape { fs_name = name, fs_flavor = fam_flav })
-- If there are tyvars left over, we can
-- assume they're free-floating, since they
-- aren't bound by a type pattern
; checkNoErrs $ reportFloatingKvs name tc_flav qtkvs unmentioned_tvs
; checkNoErrs $ reportFloatingKvs (getName tc_fam_tc) tc_flav
qtkvs unmentioned_tvs
; tcExtendTyVarEnv qtkvs $
-- Extend envt with TcTyVars not TyVars, because the
......@@ -2457,7 +2436,7 @@ checkValidTyConTyVars tc
= reverse $ nub $ reverse tvs
| otherwise
= tvs
vis_tvs = filterOutInvisibleTyVars tc tvs
vis_tvs = tyConVisibleTyVars tc
extra | not (vis_tvs `equalLength` stripped_tvs)
= text "NB: Implicitly declared kind variables are put first."
| otherwise
......@@ -2649,7 +2628,7 @@ checkValidClass cls
; mapM_ check_at at_stuff }
where
(tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
cls_arity = length $ filterOutInvisibleTyVars (classTyCon cls) tyvars
cls_arity = length (tyConVisibleTyVars (classTyCon cls))
-- Ignore invisible variables
cls_tv_set = mkVarSet tyvars
mini_env = zipVarEnv tyvars (mkTyVarTys tyvars)
......
......@@ -73,7 +73,7 @@ module TyCon(
tyConSkolem,
tyConKind,
tyConUnique,
tyConTyVars,
tyConTyVars, tyConVisibleTyVars,
tyConCType, tyConCType_maybe,
tyConDataCons, tyConDataCons_maybe,
tyConSingleDataCon_maybe, tyConSingleDataCon,
......@@ -418,8 +418,11 @@ isNamedTyConBinder _ = False
isVisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool
-- Works for IfaceTyConBinder too
isVisibleTyConBinder (TvBndr _ (NamedTCB vis)) = isVisibleArgFlag vis
isVisibleTyConBinder (TvBndr _ AnonTCB) = True
isVisibleTyConBinder (TvBndr _ tcb_vis) = isVisibleTcbVis tcb_vis
isVisibleTcbVis :: TyConBndrVis -> Bool
isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis
isVisibleTcbVis AnonTCB = True
isInvisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool
-- Works for IfaceTyConBinder too
......@@ -445,6 +448,11 @@ tyConTyVarBinders tc_bndrs
NamedTCB Required -> Specified
NamedTCB vis -> vis
tyConVisibleTyVars :: TyCon -> [TyVar]
tyConVisibleTyVars tc
= [ tv | TvBndr tv vis <- tyConBinders tc
, isVisibleTcbVis vis ]
{- Note [Building TyVarBinders from TyConBinders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We sometimes need to build the quantified type of a value from
......
......@@ -58,7 +58,7 @@ module Type (
stripCoercionTy, splitCoercionType_maybe,
splitPiTysInvisible, filterOutInvisibleTypes,
filterOutInvisibleTyVars, partitionInvisibles,
partitionInvisibles,
synTyConResKind,
modifyJoinResTy, setJoinResTy,
......@@ -1430,10 +1430,6 @@ splitPiTysInvisible ty = split ty ty []
filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]
filterOutInvisibleTypes tc tys = snd $ partitionInvisibles tc id tys
-- | Like 'filterOutInvisibles', but works on 'TyVar's
filterOutInvisibleTyVars :: TyCon -> [TyVar] -> [TyVar]
filterOutInvisibleTyVars tc tvs = snd $ partitionInvisibles tc mkTyVarTy tvs
-- | Given a tycon and a list of things (which correspond to arguments),
-- partitions the things into
-- Inferred or Specified ones and
......
......@@ -15,8 +15,6 @@ piResultTy :: HasDebugCallStack => Type -> Type -> Type
eqType :: Type -> Type -> Bool
partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])
coreView :: Type -> Maybe Type
tcView :: Type -> Maybe Type
......
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