[commit: ghc] wip/T11028: Progress, but does not generate correct res_ty (ff2978c)
git at git.haskell.org
git at git.haskell.org
Wed Nov 25 19:56:16 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T11028
Link : http://ghc.haskell.org/trac/ghc/changeset/ff2978cac0cd133c2434480e311bed6aea72c6f1/ghc
>---------------------------------------------------------------
commit ff2978cac0cd133c2434480e311bed6aea72c6f1
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date: Wed Nov 25 21:53:37 2015 +0200
Progress, but does not generate correct res_ty
This commit fails with
libraries/hoopl/src/Compiler/Hoopl/Block.hs:66:3: error:
• Data constructor ‘JustO’ returns type ‘t -> MaybeO O t’
instead of an instance of its parent type ‘MaybeO ex t’
• In the definition of data constructor ‘JustO’
In the data type declaration for ‘MaybeO’
>---------------------------------------------------------------
ff2978cac0cd133c2434480e311bed6aea72c6f1
compiler/deSugar/DsMeta.hs | 4 ++--
compiler/hsSyn/HsDecls.hs | 5 +++++
compiler/parser/RdrHsSyn.hs | 10 +++++-----
compiler/rename/RnSource.hs | 2 +-
compiler/typecheck/TcRnDriver.hs | 2 +-
compiler/typecheck/TcTyClsDecls.hs | 12 ++++++------
6 files changed, 20 insertions(+), 15 deletions(-)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index caff5c4..74f066b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -304,7 +304,7 @@ repDataDefn tc bndrs opt_tys tv_names
_cs -> failWithDs (ptext
(sLit "Multiple constructors for newtype:")
<+> pprQuotedList
- (con_names $ unLoc $ head cons))
+ (getConNames $ unLoc $ head cons))
}
DataType -> do { consL <- concatMapM (repC tv_names) cons
; cons1 <- coreList conQTyConName consL
@@ -658,7 +658,7 @@ repC tvs (L _ (ConDeclGADT { con_names = cons
; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
- ; let details = gadtDeclDetails res_ty
+ ; let (details,_,_) = gadtDeclDetails res_ty
; c' <- mapM (\c -> repConstr c details) cons1
; ctxt' <- repContext eq_ctxt
; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 63d8d90..ef4ae8f 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -62,6 +62,7 @@ module HsDecls (
-- ** Data-constructor declarations
ConDecl(..), LConDecl, ResType(..),
HsConDeclDetails, hsConDeclArgTys,
+ getConNames,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -1097,6 +1098,10 @@ deriving instance (DataId name) => Data (ConDecl name)
type HsConDeclDetails name
= HsConDetails (LBangType name) (Located [LConDeclField name])
+getConNames :: ConDecl name -> [Located name]
+getConNames (ConDeclH98 {con_name = name}) = [name]
+getConNames (ConDeclGADT {con_names = names}) = names
+
hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 0ff5c31..9678735 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -542,15 +542,15 @@ mkGadtDecl' names lbody_ty@(L loc body_ty)
-}
-- AZ:TODO: this probably belongs in a different module
-gadtDeclDetails :: LHsSigType name -> HsConDeclDetails name
-gadtDeclDetails (HsIB {hsib_body = lbody_ty}) = details
+gadtDeclDetails :: LHsSigType name -> (HsConDeclDetails name,LHsType name,LHsContext name)
+gadtDeclDetails (HsIB {hsib_body = lbody_ty}) = (details,res_ty,cxt)
where
(tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
- details -- See Note [Sorting out the result type]
+ (details, res_ty) -- See Note [Sorting out the result type]
= case tau of
L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
- -> RecCon (L l flds)
- _other -> PrefixCon []
+ -> (RecCon (L l flds), res_ty)
+ _other -> (PrefixCon [], tau)
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 450ad82..6e16234 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1454,7 +1454,7 @@ depAnalTyClDecls ds_w_fvs
DataDecl { tcdLName = L _ data_name
, tcdDataDefn = HsDataDefn { dd_cons = cons } }
-> do L _ dc <- cons
- return $ zip (map unLoc $ con_names dc) (repeat data_name)
+ return $ zip (map unLoc $ getConNames dc) (repeat data_name)
_ -> []
{-
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index b7af287..593170b 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1249,7 +1249,7 @@ tcTyClsInstDecls tycl_decls inst_decls deriv_decls
get_fi_cons :: DataFamInstDecl Name -> [Name]
get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
- = map unLoc $ concatMap (con_names . unLoc) cons
+ = map unLoc $ concatMap (getConNames . unLoc) cons
{-
Note [AFamDataCon: not promoting data family constructors]
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 592f279..55619e7 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -389,7 +389,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
; return (res_k, ()) }
; let main_pr = (name, AThing decl_kind)
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
- | L _ con' <- cons, con <- con_names con' ]
+ | L _ con' <- cons, con <- getConNames con' ]
; return (main_pr : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
@@ -1351,16 +1351,16 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
; (ctxt, arg_tys, res_ty, field_lbls, stricts)
<- tcHsQTyVars hs_tvs $ \ _ ->
do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs)
- ; ctxt <- tcHsContext (noLoc []) -- AZ: can remove this, in time
- ; let hs_details = gadtDeclDetails ty
+ ; let (hs_details,res_ty,cxt) = gadtDeclDetails ty
+ ; traceTc "tcConDecl:" (text "res_ty:" <+> ppr res_ty)
+ ; ctxt <- tcHsContext cxt
; btys <- tcConArgs new_or_data hs_details
-- ; res_ty <- tcConRes hs_res_ty
- ; ty' <- tcHsLiftedType bty
+ ; ty' <- tcHsLiftedType res_ty
; field_lbls <- lookupConstructorFields (unLoc $ head names)
; let (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, ty', field_lbls, stricts)
}
-
-- Generalise the kind variables (returning quantified TcKindVars)
-- and quantify the type variables (substituting their kinds)
-- REMEMBER: 'tkvs' are:
@@ -1386,7 +1386,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
; let
buildOneDataCon (L _ name) = do
- { let hs_details = gadtDeclDetails ty
+ { let (hs_details,_,_) = gadtDeclDetails ty
; is_infix <- tcConIsInfixGADT name hs_details
; rep_nm <- newTyConRepName name
More information about the ghc-commits
mailing list