[commit: ghc] wip/T11028: Next problem: strictness annotation not stripped out (2e7bc34)

git at git.haskell.org git at git.haskell.org
Thu Nov 26 15:34:39 UTC 2015


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T11028
Link       : http://ghc.haskell.org/trac/ghc/changeset/2e7bc34e5ee43d4ce3f722545016e99e89ffb703/ghc

>---------------------------------------------------------------

commit 2e7bc34e5ee43d4ce3f722545016e99e89ffb703
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’


>---------------------------------------------------------------

2e7bc34e5ee43d4ce3f722545016e99e89ffb703
 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