[commit: ghc] master: Simplify the API for TcHsType.kcHsTyVarBndrs (7a50966)
git at git.haskell.org
git at git.haskell.org
Wed Nov 2 12:34:02 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/7a509660b5ea3d0c387c8fa32146b60955364b17/ghc
>---------------------------------------------------------------
commit 7a509660b5ea3d0c387c8fa32146b60955364b17
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Nov 2 11:48:51 2016 +0000
Simplify the API for TcHsType.kcHsTyVarBndrs
Pass in a Bool rather than return a funcion!
No change in behaviour.
>---------------------------------------------------------------
7a509660b5ea3d0c387c8fa32146b60955364b17
compiler/typecheck/TcHsType.hs | 21 ++++++++++-----------
compiler/typecheck/TcTyClsDecls.hs | 30 ++++++++++++++----------------
2 files changed, 24 insertions(+), 27 deletions(-)
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index a9d90f2..3b19298 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -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
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index fefe1e9..0b471d2 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -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)
More information about the ghc-commits
mailing list