Commit 7a509660 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify the API for TcHsType.kcHsTyVarBndrs

Pass in a Bool rather than return a funcion!

No change in behaviour.
parent 99689492
......@@ -1262,16 +1262,15 @@ tcWildCardBindersX new_wc wc_names thing_inside
--
-- This function does not do telescope checking.
kcHsTyVarBndrs :: Name -- ^ of the thing being checked
-> Bool -- ^ True <=> the TyCon being kind-checked can be unsaturated
-> Bool -- ^ True <=> the decl being checked has a CUSK
-> Bool -- ^ True <=> the decl is an open type/data family
-> Bool -- ^ True <=> all the hsq_implicit are *kind* vars
-- (will give these kind * if -XNoTypeInType)
-> LHsQTyVars Name
-> TcM (Kind, r) -- ^ the result kind, possibly with other info
-> TcM (Bool -> TcTyCon, r)
-- ^ a way to make a TcTyCon, with the other info.
-- The Bool says whether the tycon can be unsaturated.
kcHsTyVarBndrs name cusk open_fam all_kind_vars
-> TcM (Kind, r) -- ^ The result kind, possibly with other info
-> TcM (TcTyCon, r) -- ^ A suitably-kinded TcTyCon
kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars
(HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs
, hsq_dependent = dep_names }) thing_inside
| cusk
......@@ -1310,13 +1309,13 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars
; let final_binders = map (mkNamedTyConBinder Specified) good_tvs
++ tc_binders
mk_tctc unsat = mkTcTyCon name final_binders res_kind
unsat (scoped_kvs ++ tc_tvs)
tycon = mkTcTyCon name final_binders res_kind
unsat (scoped_kvs ++ tc_tvs)
-- the tvs contain the binders already
-- in scope from an enclosing class, but
-- re-adding tvs to the env't doesn't cause
-- harm
; return ( mk_tctc, stuff ) }}
; return (tycon, stuff) }}
| otherwise
= do { kv_kinds <- mk_kv_kinds
......@@ -1327,9 +1326,9 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars
bind_telescope hs_tvs thing_inside
; let -- NB: Don't add scoped_kvs to tyConTyVars, because they
-- must remain lined up with the binders
mk_tctc unsat = mkTcTyCon name binders res_kind unsat
(scoped_kvs ++ binderVars binders)
; return (mk_tctc, stuff) }
tycon = mkTcTyCon name binders res_kind unsat
(scoped_kvs ++ binderVars binders)
; return (tycon, stuff) }
where
-- if -XNoTypeInType and we know all the implicits are kind vars,
-- just give the kind *. This prevents test
......
......@@ -437,12 +437,11 @@ getInitialKind :: TyClDecl Name
-- No family instances are passed to getInitialKinds
getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
= do { (mk_tctc, inner_prs) <-
kcHsTyVarBndrs name cusk False True ktvs $
= do { (tycon, inner_prs) <-
kcHsTyVarBndrs name True cusk False True ktvs $
do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats
; return (constraintKind, inner_prs) }
; let main_pr = mkTcTyConPair (mk_tctc True)
; return (main_pr : inner_prs) }
; return (mkTcTyConPair tycon : inner_prs) }
where
cusk = hsDeclHasCusk decl
......@@ -450,16 +449,15 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_cons = cons } })
= do { (mk_tctc, _) <-
kcHsTyVarBndrs name (hsDeclHasCusk decl) False True ktvs $
= do { (tycon, _) <-
kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
; return (res_k, ()) }
; let main_pr = mkTcTyConPair (mk_tctc True)
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
; let inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
| L _ con' <- cons, con <- getConNames con' ]
; return (main_pr : inner_prs) }
; return (mkTcTyConPair tycon : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
= getFamDeclInitialKind Nothing decl
......@@ -482,8 +480,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
, fdTyVars = ktvs
, fdResultSig = L _ resultSig
, fdInfo = info })
= do { (mk_tctc, _) <-
kcHsTyVarBndrs name cusk open True ktvs $
= do { (tycon, _) <-
kcHsTyVarBndrs name unsat cusk open True ktvs $
do { res_k <- case resultSig of
KindSig ki -> tcLHsKind ki
TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki
......@@ -493,7 +491,7 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
-- by default
| otherwise -> newMetaKindVar
; return (res_k, ()) }
; return [ mkTcTyConPair (mk_tctc unsat) ] }
; return [ mkTcTyConPair tycon ] }
where
cusk = famDeclHasCusk mb_cusk decl
(open, unsat) = case info of
......@@ -523,13 +521,13 @@ kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
, tcdRhs = rhs })
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
do { (mk_tctc, _) <-
kcHsTyVarBndrs name (hsDeclHasCusk decl) False True hs_tvs $
do { (tycon, _) <-
kcHsTyVarBndrs name False (hsDeclHasCusk decl) False True hs_tvs $
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
; (_, rhs_kind) <- tcLHsType rhs
; traceTc "kcd2" (ppr name)
; return (rhs_kind, ()) }
; return (mk_tctc False) }
; return tycon }
kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
------------------------------------------------------------------------
......@@ -588,7 +586,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
-- the 'False' says that the existentials don't have a CUSK, as the
-- concept doesn't really apply here. We just need to bring the variables
-- into scope.
do { _ <- kcHsTyVarBndrs (unLoc name) False False False
do { _ <- kcHsTyVarBndrs (unLoc name) False False False False
((fromMaybe emptyLHsQTvs ex_tvs)) $
do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
......
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