[commit: ghc] wip/T11028: Next problem: strictness annotation not stripped out (76bda99)
git at git.haskell.org
git at git.haskell.org
Fri Nov 27 14:58:51 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T11028
Link : http://ghc.haskell.org/trac/ghc/changeset/76bda99d0e9e271bcb6618b13a659420126831e6/ghc
>---------------------------------------------------------------
commit 76bda99d0e9e271bcb6618b13a659420126831e6
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date: Thu Nov 26 17:34:06 2015 +0200
Next problem: strictness annotation not stripped out
Fails with
compiler/cmm/CmmNode.hs:47:15: error:
• Unexpected strictness annotation: {-# UNPACK #-} !Label
• In the type signature:
CmmEntry :: {-# UNPACK #-} !Label -> CmmTickScope -> CmmNode C O
In the definition of data constructor ‘CmmEntry’
In the data declaration for ‘CmmNode’
>---------------------------------------------------------------
76bda99d0e9e271bcb6618b13a659420126831e6
compiler/rename/RnEnv.hs | 4 +++-
compiler/rename/RnNames.hs | 4 +++-
compiler/rename/RnSource.hs | 9 ++++++---
compiler/rename/RnTypes.hs | 25 +++++++++++++++++++++----
4 files changed, 33 insertions(+), 9 deletions(-)
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index c90b556..57890aa 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -2123,6 +2123,8 @@ checkTupSize tup_size
************************************************************************
-}
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+-- Merge TcType.UserTypeContext in to it.
data HsDocContext
= TypeSigCtx SDoc
| PatCtx
@@ -2135,7 +2137,7 @@ data HsDocContext
| TySynCtx (Located RdrName)
| TyFamilyCtx (Located RdrName)
| FamPatCtx (Located RdrName) -- The patterns of a type/data family instance
- | ConDeclCtx [Located RdrName]
+ | ConDeclCtx [Located Name]
| ClassDeclCtx (Located RdrName)
| ExprWithTySigCtx
| TypBrCtx
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 4153b08..de2704b 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -615,11 +615,13 @@ getLocalNonValBinders fixity_env
= map (\ (L _ rdr) -> ( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds)))
[rdrs] -- AZ:TODO remove map
- find_con_flds (L _ (ConDeclGADT { con_names = rdrs, con_type = HsIB { hsib_body = res_ty}}))
+ find_con_flds (L _ (ConDeclGADT { con_names = rdrs, con_type = ty@(HsIB { hsib_body = res_ty})}))
= map (\ (L _ rdr) -> ( find_con_name rdr
, concatMap find_con_decl_flds cdflds))
rdrs
where
+ -- (hs_details',res_ty',_cxt) = gadtDeclDetails ty
+ -- (arg_tys, res_ty) = splitHsFunType ty
-- AZ:TODO: extract a function to pull fields out of a ConDecl
(tvs, cxt, tau) = splitLHsSigmaTy res_ty
cdflds = case tau of
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index b99fa3d..5ef76b8 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1548,6 +1548,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
, con_doc = mb_doc })
= do { _ <- addLocM checkConName name
; new_name <- lookupLocatedTopBndrRn name
+ ; let doc = ConDeclCtx [new_name]
; mb_doc' <- rnMbLHsDoc mb_doc
; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details)
@@ -1572,7 +1573,6 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
, con_doc = mb_doc' },
all_fvs) }}
where
- doc = ConDeclCtx [name]
cxt = maybe [] unLoc mcxt
get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
@@ -1589,6 +1589,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
, con_doc = mb_doc })
= do { mapM_ (addLocM checkConName) names
; new_names <- mapM lookupLocatedTopBndrRn names
+ ; let doc = ConDeclCtx new_names
; mb_doc' <- rnMbLHsDoc mb_doc
; (ty', fvs) <- rnHsSigType doc ty
@@ -1597,8 +1598,6 @@ rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
; return (decl { con_names = new_names, con_type = ty'
, con_doc = mb_doc' },
fvs) }
- where
- doc = ConDeclCtx names
{- old
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
@@ -1681,18 +1680,22 @@ rnConDeclDetails
-> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
rnConDeclDetails _ doc (PrefixCon tys)
= do { (new_tys, fvs) <- rnLHsTypes doc tys
+ ; traceRn (text "rnConDeclDetails:PrefixCon:" <+> ppr tys)
; return (PrefixCon new_tys, fvs) }
rnConDeclDetails _ doc (InfixCon ty1 ty2)
= do { (new_ty1, fvs1) <- rnLHsType doc ty1
; (new_ty2, fvs2) <- rnLHsType doc ty2
+ ; traceRn (text "rnConDeclDetails:InfixCon:" <+> ppr [ty1,ty2])
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
rnConDeclDetails con doc (RecCon (L l fields))
= do { fls <- lookupConstructorFields con
+ ; traceRn (text "rnConDeclDetails:RecCon fields:" <+> ppr (map (cd_fld_names . unLoc) fields))
; (new_fields, fvs) <- rnConDeclFields fls doc fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
+ ; traceRn (text "rnConDeclDetails:RecCon new_fields:" <+> ppr (map (cd_fld_names . unLoc) new_fields))
; return (RecCon (L l new_fields), fvs) }
-------------------------------------------------
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index ee9abd9..56f86ee 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -385,10 +385,25 @@ rnHsTyKi _ doc (HsBangTy b ty)
= do { (ty', fvs) <- rnLHsType doc ty
; return (HsBangTy b ty', fvs) }
+rnHsTyKi _ doc@(ConDeclCtx names) ty@(HsRecTy flds)
+ = do { -- AZ:TODO: move this test into the type checker
+ -- addErr (hang (ptext (sLit "Record syntax is illegal here:"))
+ -- 2 (ppr ty))
+ traceRn (text "rnHsTyKi:HsRecTy:flds" <+> (ppr ty) <+> text "doc:" <+> pprHsDocContext doc)
+ ; flss <- mapM (lookupConstructorFields . unLoc) names
+ ; let fls = concat flss
+ ; (flds', fvs) <- rnConDeclFields fls doc flds
+ ; traceRn (text "rnHsTyKi:HsRecTy:flds'" <+> (ppr $ HsRecTy flds'))
+ ; return (HsRecTy flds', fvs) }
+
rnHsTyKi _ doc ty@(HsRecTy flds)
- = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
- 2 (ppr ty))
+ = do { -- AZ:TODO: move this test into the type checker
+ -- addErr (hang (ptext (sLit "Record syntax is illegal here:"))
+ -- 2 (ppr ty))
+ traceRn (text "rnHsTyKi:HsRecTy:flds" <+> (ppr ty) <+> text "doc:" <+> pprHsDocContext doc)
+ -- ; fls <- lookupConstructorFields con
; (flds', fvs) <- rnConDeclFields [] doc flds
+ ; traceRn (text "rnHsTyKi:HsRecTy:flds'" <+> (ppr $ HsRecTy flds'))
; return (HsRecTy flds', fvs) }
rnHsTyKi what doc (HsFunTy ty1 ty2)
@@ -765,7 +780,8 @@ rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
-> RnM (LConDeclField Name, FreeVars)
rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
- = do { let new_names = map (fmap lookupField) names
+ = do { traceRn (text "rnField:names:" <+> ppr names <+> text ",fl_env:" <+> ppr fl_env)
+ ; let new_names = map (fmap lookupField) names
; (new_ty, fvs) <- rnLHsType doc ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
@@ -774,7 +790,8 @@ rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
where
lbl = occNameFS $ rdrNameOcc rdr
- fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
+ -- fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
+ fl = expectJust ("rnField:" ++ (showSDocUnsafe $ ppr rdr)) $ lookupFsEnv fl_env lbl
{-
More information about the ghc-commits
mailing list