[commit: ghc] wip/T11028: All test pass except T5331 and T7064 (23c3317)
git at git.haskell.org
git at git.haskell.org
Sun Nov 29 20:20:42 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T11028
Link : http://ghc.haskell.org/trac/ghc/changeset/23c3317c26709ccc6251d90720320a98e53d05b4/ghc
>---------------------------------------------------------------
commit 23c3317c26709ccc6251d90720320a98e53d05b4
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date: Sun Nov 29 22:20:21 2015 +0200
All test pass except T5331 and T7064
>---------------------------------------------------------------
23c3317c26709ccc6251d90720320a98e53d05b4
compiler/hsSyn/HsDecls.hs | 11 ++++++++---
compiler/rename/RnTypes.hs | 7 +++----
compiler/typecheck/TcHsType.hs | 5 ++---
compiler/typecheck/TcTyClsDecls.hs | 12 ++++++------
testsuite/tests/rename/should_fail/T7943.stderr | 6 +++++-
5 files changed, 24 insertions(+), 17 deletions(-)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 5bd8bd7..5356059 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -107,6 +107,7 @@ import SrcLoc
import FastString
import Bag
+import Data.Maybe ( fromMaybe )
import Data.Data hiding (TyCon,Fixity)
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
@@ -1161,17 +1162,21 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con
- -- , con_qvars = tvs
- -- , con_cxt = cxt
+ , con_qvars = mtvs
+ , con_cxt = mcxt
, con_details = details
, con_doc = doc })
- = sep [ppr_mbDoc doc, ppr_details details]
+ = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details]
where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprParendHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
+ tvs = case mtvs of
+ Nothing -> []
+ Just (HsQTvs { hsq_tvs = tvs}) -> tvs
+ cxt = fromMaybe (noLoc []) mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
= sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index c56857f..31f30f9 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -385,11 +385,10 @@ rnHsTyKi _ doc (HsBangTy b ty)
= do { (ty', fvs) <- rnLHsType doc ty
; return (HsBangTy b ty', fvs) }
-rnHsTyKi _ doc@(ConDeclCtx names) ty@(HsRecTy flds)
- = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
- 2 (ppr ty))
+rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
+ = do {
-- AZ:reviewers: is there a monadic version of concatMap?
- ; flss <- mapM (lookupConstructorFields . unLoc) names
+ flss <- mapM (lookupConstructorFields . unLoc) names
; let fls = concat flss
; (flds', fvs) <- rnConDeclFields fls doc flds
; return (HsRecTy flds', fvs) }
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 303cd57..73cc674 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -387,11 +387,10 @@ tc_hs_type ty@(HsBangTy {}) _
-- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-- bangs are invalid, so fail. (#7210)
= failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
-tc_hs_type ty@(HsRecTy _) _ -- = panic "tc_hs_type: record" -- Unwrapped by con decls
+tc_hs_type ty@(HsRecTy _) _
-- Record types (which only show up temporarily in constructor
-- signatures) should have been removed by now
- -- = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty)
- = failWithTc (ptext (sLit "Record syntax is illegal here(tc):") <+> ppr ty)
+ = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty)
---------- Functions and applications
tc_hs_type hs_ty@(HsTyVar (L _ name)) exp_kind
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 274ab4c..ff315bd 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1331,7 +1331,7 @@ tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
-- ResTyGADT: *all* the quantified type variables
-- c.f. the comment on con_qvars in HsDecls
-}
- ; (ctxt, stricts, field_lbls, arg_tys, res_ty)
+ ; (ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
<- tcGadtSigType (ppr names) (unLoc $ head names) ty
; tkvs <- quantifyTyVars emptyVarSet (tyVarsOfTypes (res_ty:ctxt++arg_tys))
@@ -1352,8 +1352,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,_,_,_tvs) = gadtDeclDetails ty
- ; is_infix <- tcConIsInfixGADT name hs_details
+ { is_infix <- tcConIsInfixGADT name hs_details
; rep_nm <- newTyConRepName name
; buildDataCon fam_envs name is_infix
@@ -1372,7 +1371,8 @@ tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
tcGadtSigType :: SDoc -> Name -> LHsSigType Name
- -> TcM ([PredType],[HsSrcBang], [FieldLabel], [Type], Type)
+ -> TcM ([PredType],[HsSrcBang], [FieldLabel], [Type], Type
+ ,HsConDetails (LHsType Name) (Located [LConDeclField Name]))
tcGadtSigType doc name ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = _bty})
= do { let (hs_details',res_ty',cxt,gtvs) = gadtDeclDetails ty
; (hs_details,res_ty) <- tcUpdateConResult doc hs_details' res_ty'
@@ -1386,7 +1386,7 @@ tcGadtSigType doc name ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = _b
; let (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, ty', field_lbls, stricts)
}
- ; return (ctxt,stricts,field_lbls,arg_tys,res_ty)
+ ; return (ctxt,stricts,field_lbls,arg_tys,res_ty,hs_details)
}
tcUpdateConResult :: SDoc
@@ -1433,7 +1433,7 @@ tcConIsInfixGADT con details
= case details of
InfixCon {} -> return True
RecCon {} -> return False
- PrefixCon arg_tys -- See Note [Infix GADT cons]
+ PrefixCon arg_tys -- See Note [Infix GADT constructors]
| isSymOcc (getOccName con)
, [_ty1,_ty2] <- arg_tys
-> do { fix_env <- getFixityEnv
diff --git a/testsuite/tests/rename/should_fail/T7943.stderr b/testsuite/tests/rename/should_fail/T7943.stderr
index 8594a25..c6bf7ae 100644
--- a/testsuite/tests/rename/should_fail/T7943.stderr
+++ b/testsuite/tests/rename/should_fail/T7943.stderr
@@ -1,2 +1,6 @@
-T7943.hs:4:22: Record syntax is illegal here: {bar :: String}
+T7943.hs:4:22:
+ Record syntax is illegal here: {bar :: String}
+ In the type ‘{bar :: String}’
+ In the definition of data constructor ‘B’
+ In the data declaration for ‘Foo’
\ No newline at end of file
More information about the ghc-commits
mailing list