Refactor ConDeclwip/T11028

The ConDecl type in HsDecls is an uneasy compromise. For the most part,
HsSyn directly reflects the syntax written by the programmer; and that
gives just the right "pegs" on which to hang Alan's API annotations. But
ConDecl doesn't properly reflect the syntax of Haskell-98 and GADT-style
data type declarations.

To be concrete, here's a draft new data type

data ConDecl name
  | ConDeclGADT
      { con_names   :: [Located name]
      , con_type    :: LHsSigType name  -- The type after the ‘::’
      , con_doc     :: Maybe LHsDocString }

  | ConDeclH98
      { con_name    :: Located name

      , con_qvars     :: Maybe (LHsQTyVars name)
        -- User-written forall (if any), and its implicit
        -- kind variables
        -- Non-Nothing needs -XExistentialQuantification

      , con_cxt       :: Maybe (LHsContext name)
        -- ^ User-written context (if any)

      , con_details   :: HsConDeclDetails name
          -- ^ Arguments

      , con_doc       :: Maybe LHsDocString
          -- ^ A possible Haddock comment.
      } deriving (Typeable)

Note that

    For GADTs, just keep a type. That's what the user writes.
    NB:HsType can represent records on the LHS of an arrow:

      { x:Int,y:Bool} -> T

    con_qvars and con_cxt are both Maybe because they are both
    optional (the forall and the context of an existential data type

    For ConDeclGADT the type variables of the data type do not scope
    over the con_type; whereas for ConDeclH98 they do scope over con_cxt
    and con_details.

Trac issue: #11028

2 files changed, 31 insertions, 53 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index fb5c8dbd45..bbde989293 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1895,10 +1895,9 @@ gadt_constr_with_doc
 gadt_constr :: { LConDecl RdrName }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
-        : con_list '::' ctype
-                {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 }
-                      ; ams (sLL $1 $> gadtDecl)
-                            (mu AnnDcolon $2:anns) } }
+        : con_list '::' sigtype
+                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
+                       [mu AnnDcolon $2] }
 
 {- Note [Difference in parsing GADT and data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1925,13 +1924,13 @@ constrs1 :: { Located [LConDecl RdrName] }
 constr :: { LConDecl RdrName }
         : maybe_docnext forall context '=>' constr_stuff maybe_docprev
                 {% ams (let (con,details) = unLoc $5 in
-                  addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con
+                  addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
                                                    (snd $ unLoc $2) $3 details))
                             ($1 `mplus` $6))
                         (mu AnnDarrow $4:(fst $ unLoc $2)) }
         | maybe_docnext forall constr_stuff maybe_docprev
                 {% ams ( let (con,details) = unLoc $3 in
-                  addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con
+                  addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
                                            (snd $ unLoc $2) (noLoc []) details))
                             ($1 `mplus` $4))
                        (fst $ unLoc $2) }
@@ -2671,7 +2670,6 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
 -- here, because we need too much lookahead if we see do { e ; }
 -- So we use BodyStmts throughout, and switch the last one over
 -- in ParseUtils.checkDo instead
--- AZ: TODO check that we can retrieve multiple semis.
 
 stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
         : stmts ';' stmt  {% if null (snd $ unLoc $1)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 4b744fe69a..70be8e5d0e 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -35,7 +35,8 @@ module RdrHsSyn (
         mkExport,
         mkExtName,           -- RdrName -> CLabelString
         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
-        mkSimpleConDecl,
+        gadtDeclDetails,
+        mkConDeclH98,
         mkATDefault,
 
         -- Bunch of functions in the parser monad for
@@ -487,38 +488,30 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
         quotes (ppr patsyn_name) $$ ppr decl
 
-mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
+mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
                 -> LHsContext RdrName -> HsConDeclDetails RdrName
                 -> ConDecl RdrName
 
-mkSimpleConDecl name mb_forall cxt details
-  = ConDecl { con_names    = [name]
-            , con_explicit = explicit
-            , con_qvars    = qvars
-            , con_cxt      = cxt
-            , con_details  = details
-            , con_res      = ResTyH98
-            , con_doc      = Nothing }
-  where
-    (explicit, qvars) = case mb_forall of
-                          Nothing  -> (False, mkHsQTvs [])
-                          Just tvs -> (True,  mkHsQTvs tvs)
+mkConDeclH98 name mb_forall cxt details
+  = ConDeclH98 { con_name     = name
+               , con_qvars    = fmap mkHsQTvs mb_forall
+               , con_cxt      = Just cxt
+                                -- AZ:TODO: when can cxt be Nothing?
+                                --          remembering that () is a valid context.
+               , con_details  = details
+               , con_doc      = Nothing }
 
 mkGadtDecl :: [Located RdrName]
-           -> LHsType RdrName     -- Always a HsForAllTy
-           -> ([AddAnn], ConDecl RdrName)
-mkGadtDecl names ty = ([], mkGadtDecl' names ty)
-
-mkGadtDecl' :: [Located RdrName]
-            -> LHsType RdrName
-            -> ConDecl RdrName
--- We allow C,D :: ty
--- and expand it as if it had been
---    C :: ty; D :: ty
--- (Just like type signatures in general.)
-
-mkGadtDecl' names lbody_ty@(L loc body_ty)
-  = mk_gadt_con names
+           -> LHsSigType RdrName     -- Always a HsForAllTy
+           -> ConDecl RdrName
+mkGadtDecl names ty = ConDeclGADT { con_names = names
+                                  , con_type  = ty
+                                  , con_doc   = Nothing }
+
+-- AZ:TODO: this probably belongs in a different module
+gadtDeclDetails :: LHsSigType name
+                -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name])
+gadtDeclDetails (HsIB {hsib_body = lbody_ty}) = (details,res_ty,cxt,tvs)
   where
     (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
     (details, res_ty)           -- See Note [Sorting out the result type]
@@ -527,19 +520,6 @@ mkGadtDecl' names lbody_ty@(L loc body_ty)
                   -> (RecCon (L l flds), res_ty)
           _other  -> (PrefixCon [], tau)
 
-    explicit = case body_ty of
-                 HsForAllTy {} -> True
-                 _             -> False
-
-    mk_gadt_con names
-       = ConDecl { con_names    = names
-                 , con_explicit = explicit
-                 , con_qvars    = mkHsQTvs tvs
-                 , con_cxt      = cxt
-                 , con_details  = details
-                 , con_res      = ResTyGADT loc res_ty
-                 , con_doc      = Nothing }
-
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
   | isTcOcc (rdrNameOcc tc)
@@ -639,19 +619,19 @@ really doesn't matter!
 
 -- | Note [Sorting out the result type]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In a GADT declaration which is not a record, we put the whole constr
--- type into the ResTyGADT for now; the renamer will unravel it once it
--- has sorted out operator fixities. Consider for example
+-- In a GADT declaration which is not a record, we put the whole constr type
+-- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
+-- it has sorted out operator fixities. Consider for example
 --      C :: a :*: b -> a :*: b -> a :+: b
 -- Initially this type will parse as
 --       a :*: (b -> (a :*: (b -> (a :+: b))))
-
+--
 -- so it's hard to split up the arguments until we've done the precedence
 -- resolution (in the renamer) On the other hand, for a record
 --         { x,y :: Int } -> a :*: b
 -- there is no doubt.  AND we need to sort records out so that
 -- we can bring x,y into scope.  So:
---    * For PrefixCon we keep all the args in the ResTyGADT
+--    * For PrefixCon we keep all the args in the res_ty
 --    * For RecCon we do not
 
 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)