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

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