[commit: ghc] wip/T11028: Progress, but getting "Record syntax is illegal here" (d73c000)

[git at git.haskell.org]

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

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

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

commit d73c00076c879a9e228fc9492067709348e8dcab
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date:   Thu Nov 26 10:21:10 2015 +0200

    Progress, but getting "Record syntax is illegal here"


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

d73c00076c879a9e228fc9492067709348e8dcab
 compiler/rename/RnSource.hs        |  3 +++
 compiler/typecheck/TcTyClsDecls.hs | 54 +++++++++++++++++++++++++++++++++++---
 2 files changed, 54 insertions(+), 3 deletions(-)

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 6e16234..b99fa3d 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1649,6 +1649,8 @@ rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs
       where
         (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys)
 -}
+
+-- AZ:TODO: remove this function, it is no longer used
 rnConResult :: HsDocContext -> [Name]
             -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
             -> ResType (LHsType RdrName)
@@ -1694,6 +1696,7 @@ rnConDeclDetails con doc (RecCon (L l fields))
         ; return (RecCon (L l new_fields), fvs) }
 
 -------------------------------------------------
+-- AZ:TODO: remove this when it is no longer used in RnSource
 badRecResTy :: HsDocContext -> SDoc
 badRecResTy ctxt = withHsDocContext ctxt $
                    ptext (sLit "Malformed constructor signature")
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index fed0a2e..fd6bc57 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -510,9 +510,26 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
        ; return () }
 
 kcConDecl (ConDeclGADT { con_names = names
-                       , con_type = res_ty })
+                       , con_type = ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = bty}) })
   = addErrCtxt (dataConCtxtName names) $
-      kcHsSigType names res_ty
+      kcHsSigType names ty
+    {-
+         -- the 'False' says that the existentials don't have a CUSK, as the
+         -- concept doesn't really apply here. We just need to bring the variables
+         -- into scope!
+    do { let ex_tvs = HsQTvs { hsq_kvs = kvs, hsq_tvs = map (noLoc . UserTyVar . noLoc) tvs }
+       ; let (details,res_ty,ex_cxt) = gadtDeclDetails ty
+       ; _ <- kcHsTyVarBndrs False ex_tvs $
+              do { traceTc "kcConDecl:ex_cxt" (ppr ex_cxt)
+                 ; _ <- tcHsContext ex_cxt
+                 ; traceTc "kcConDecl:after ex_cxt" (ppr ex_cxt)
+                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
+                 ; traceTc "kcConDecl:after ex_cxt2" (ppr ex_cxt)
+                 ; _ <- tcConRes (ResTyGADT undefined res_ty)
+                 ; traceTc "kcConDecl:after tcConRes" (ppr ex_cxt)
+                 ; return (panic "kcConDecl", ()) }
+       ; return () }
+    -}
 
 {- old
 kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs
@@ -1335,10 +1352,12 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
        ; let hs_tvs = HsQTvs { hsq_kvs = kvs, hsq_tvs = map (noLoc . UserTyVar . noLoc) tvs }
+       ; let (hs_details',res_ty',cxt) = gadtDeclDetails ty
+       ; let doc = ppr names -- AZ:TODO make this something reasonable
+       ; (hs_details,res_ty) <- tcUpdateConResult doc hs_details' res_ty'
        ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
            <- tcHsQTyVars hs_tvs $ \ _ ->
               do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs)
-                 ; 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
@@ -1457,6 +1476,35 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        }
 -}
 
+tcUpdateConResult :: SDoc
+            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+                    -- Original details
+            -> LHsType Name -- The original result type
+            -> TcM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
+                    LHsType Name)
+tcUpdateConResult doc details ty
+  = do {  let (arg_tys, res_ty) = splitHsFunType ty
+                -- We can finally split it up,
+                -- now the renamer has dealt with fixities
+                -- See Note [Sorting out the result type] in RdrHsSyn
+
+       ; case details of
+           InfixCon {}  -> pprPanic "tcUpdateConResult" (ppr ty)
+           -- See Note [Sorting out the result type] in RdrHsSyn
+
+           RecCon {}    -> do { unless (null arg_tys)
+                                       (failWithTc (badRecResTy doc))
+                                -- AZ: This error used to be reported during
+                                --     renaming, will now be reported in type
+                                --     checking. Is this a problem?
+                              ; return (details, res_ty) }
+
+           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
+    where
+        badRecResTy :: SDoc -> SDoc
+        badRecResTy ctxt = ctxt <+>
+                        ptext (sLit "Malformed constructor signature")
+
 tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
              -> TcM Bool