From c83ac326ea61277a31cc0a42a5027028edcb664e Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Wed, 30 Sep 2020 23:14:25 +0100
Subject: ApiAnnotations : preserve parens in GADTs

A cleanup in 7f418acf61e accidentally discarded some parens in
ConDeclGADT.

Make sure these stay in the AST in a usable format.

Also ensure the AnnLolly does not get lost in a GADT.
---
 compiler/GHC/Hs/Type.hs            | 18 +++++++++++-------
 compiler/GHC/Parser.y              | 11 ++++++-----
 compiler/GHC/Parser/PostProcess.hs | 13 +++++++------
 3 files changed, 24 insertions(+), 18 deletions(-)

diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 482fb27198..73efcda88f 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -107,6 +107,7 @@ import GHC.Utils.Misc ( count )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
 import Data.Maybe
+import GHC.Parser.Lexer
 
 {-
 ************************************************************************
@@ -1331,17 +1332,20 @@ mkHsAppKindTy ext ty k
 -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
 -- Breaks up any parens in the result type:
 --      splitHsFunType (a -> (b -> c)) = ([a,b], c)
+-- It returns API Annotations for any parens removed
 splitHsFunType ::
      LHsType (GhcPass p)
-  -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
-splitHsFunType (L _ (HsParTy _ ty))
-  = splitHsFunType ty
+  -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn])
+splitHsFunType ty = go ty []
+  where
+    go (L l (HsParTy _ ty)) anns
+      = go ty (anns ++ mkParensApiAnn l)
 
-splitHsFunType (L _ (HsFunTy _ mult x y))
-  | (args, res) <- splitHsFunType y
-  = (HsScaled mult x:args, res)
+    go (L _ (HsFunTy _ mult x y)) anns
+      | (args, res, anns') <- go y anns
+      = (HsScaled mult x:args, res, anns')
 
-splitHsFunType other = ([], other)
+    go other anns = ([], other, anns)
 
 -- | Retrieve the name of the \"head\" of a nested type application.
 -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index efda37b6a0..40c2464da2 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1959,9 +1959,10 @@ type :: { LHsType GhcPs }
                                        >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
                                               [mu AnnRarrow $2] }
 
-        | btype '#->' ctype             {% hintLinear (getLoc $2) >>
-                                         ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
-                                             [mu AnnLolly $2] }
+        | btype '#->' ctype             {% hintLinear (getLoc $2)
+                                        >> ams $1 [mu AnnLolly $2] -- See note [GADT decl discards annotations]
+                                        >> ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
+                                               [mu AnnLolly $2] }
 
 mult :: { LHsType GhcPs }
         : btype                  { $1 }
@@ -2173,9 +2174,9 @@ gadt_constr :: { LConDecl GhcPs }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
         : optSemi con_list '::' sigtype
-                {% do { decl <- mkGadtDecl (unLoc $2) $4
+                {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4
                       ; ams (sLL $2 $> decl)
-                            [mu AnnDcolon $3] } }
+                            (mu AnnDcolon $3:anns) } }
 
 {- Note [Difference in parsing GADT and data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index dde29e06e5..51921e335d 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -700,20 +700,20 @@ mkConDeclH98 name mb_forall mb_cxt args
 --   we faithfully record whether -> or #-> was used.
 mkGadtDecl :: [Located RdrName]
            -> LHsType GhcPs
-           -> P (ConDecl GhcPs)
+           -> P (ConDecl GhcPs, [AddAnn])
 mkGadtDecl names ty = do
   linearEnabled <- getBit LinearTypesBit
 
-  let (args, res_ty)
+  let (args, res_ty, anns)
         | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty
-        = (RecCon (L loc rf), res_ty)
+        = (RecCon (L loc rf), res_ty, [])
         | otherwise
-        = let (arg_types, res_type) = splitHsFunType body_ty
+        = let (arg_types, res_type, anns) = splitHsFunType body_ty
               arg_types' | linearEnabled = arg_types
                          | otherwise     = map (hsLinear . hsScaledThing) arg_types
-          in (PrefixCon arg_types', res_type)
+          in (PrefixCon arg_types', res_type, anns)
 
-  pure $ ConDeclGADT { con_g_ext  = noExtField
+  pure ( ConDeclGADT { con_g_ext  = noExtField
                      , con_names  = names
                      , con_forall = L (getLoc ty) $ isJust mtvs
                      , con_qvars  = fromMaybe [] mtvs
@@ -721,6 +721,7 @@ mkGadtDecl names ty = do
                      , con_args   = args
                      , con_res_ty = res_ty
                      , con_doc    = Nothing }
+       , anns )
   where
     (mtvs, mcxt, body_ty) = splitLHsGadtTy ty
 
-- 
cgit v1.2.1