[commit: ghc] wip/T11028: Progress, but does not generate correct res_ty (2f831e3)

git at git.haskell.org git at git.haskell.org
Fri Nov 27 14:58:48 UTC 2015


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

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

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

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


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

2f831e3b10da094216f553f2865cb02909c4ef28
 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 6f2510b..0a629ac 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
@@ -1098,6 +1099,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 5b607d0..2a48490 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1253,7 +1253,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 634c6ed..fed0a2e 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -383,7 +383,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 })
@@ -1338,16 +1338,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:
@@ -1373,7 +1373,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