Fix API Annotations for GADT constructors
authorAlan Zimmerman <alan.zimm@gmail.com>
Mon, 18 Jun 2018 08:18:21 +0000 (10:18 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Tue, 19 Jun 2018 11:19:20 +0000 (13:19 +0200)
Summary:
This patch completes the work for #14529 by making sure that all API
Annotations end up attached to a SrcSpan that appears in the final
ParsedSource.

Updates Haddock submodule

Test Plan: ./validate

Reviewers: goldfire, bgamari

Subscribers: rwbarton, thomie, mpickering, carter

GHC Trac Issues: #14529

Differential Revision: https://phabricator.haskell.org/D4867

13 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnSource.hs
testsuite/tests/ghc-api/annotations/T10399.stdout
testsuite/tests/ghc-api/annotations/Test10399.hs
testsuite/tests/ghc-api/annotations/all.T
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/T14189.stderr
utils/haddock

index 1e85ea1..832473e 100644 (file)
@@ -693,13 +693,13 @@ repAnnProv ModuleAnnProvenance
 
 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_forall = False
+                      , con_forall = L _ False
                       , con_mb_cxt = Nothing
                       , con_args = args }))
   = repDataCon con args
 
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_forall = is_existential
+                      , con_forall = L _ is_existential
                       , con_ex_tvs = con_tvs
                       , con_mb_cxt = mcxt
                       , con_args = args }))
index 7b721ed..3da163c 100644 (file)
@@ -535,14 +535,14 @@ cvtConstr (ForallC tvs ctxt con)
     add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
 
     add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
-      = con { con_forall = not (null all_tvs)
+      = con { con_forall = noLoc $ not (null all_tvs)
             , con_qvars  = mkHsQTvs all_tvs
             , con_mb_cxt = add_cxt cxt' cxt }
       where
         all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
 
     add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
-      = con { con_forall = not (null all_tvs)
+      = con { con_forall = noLoc $ not (null all_tvs)
             , con_ex_tvs = all_tvs
             , con_mb_cxt = add_cxt cxt' cxt }
       where
@@ -555,7 +555,7 @@ cvtConstr (GadtC c strtys ty)
         ; args    <- mapM cvt_arg strtys
         ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
-        ; returnL $ mkGadtDecl c' c_ty}
+        ; returnL $ fst $ mkGadtDecl c' c_ty}
 
 cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
@@ -563,7 +563,7 @@ cvtConstr (RecGadtC c varstrtys ty)
         ; rec_flds <- mapM cvt_id_arg varstrtys
         ; let rec_ty = noLoc (HsFunTy noExt
                                            (noLoc $ HsRecTy noExt rec_flds) ty')
-        ; returnL $ mkGadtDecl c' rec_ty }
+        ; returnL $ fst $ mkGadtDecl c' rec_ty }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
index c7a0ea0..7ac4354 100644 (file)
@@ -1236,7 +1236,9 @@ data ConDecl pass
 
       -- The next four fields describe the type after the '::'
       -- See Note [GADT abstract syntax]
-      , con_forall  :: Bool              -- ^ True <=> explicit forall
+      -- The following field is Located to anchor API Annotations,
+      -- AnnForall and AnnDot.
+      , con_forall  :: Located Bool      -- ^ True <=> explicit forall
                                          --   False => hsq_explicit is empty
       , con_qvars   :: LHsQTyVars pass
                        -- Whether or not there is an /explicit/ forall, we still
@@ -1254,7 +1256,8 @@ data ConDecl pass
       { con_ext     :: XConDeclH98 pass
       , con_name    :: Located (IdP pass)
 
-      , con_forall  :: Bool   -- ^ True <=> explicit user-written forall
+      , con_forall  :: Located Bool
+                              -- ^ True <=> explicit user-written forall
                               --     e.g. data T a = forall b. MkT b (b->a)
                               --     con_ex_tvs = {b}
                               -- False => con_ex_tvs is empty
index d4caf76..066ee42 100644 (file)
@@ -2139,8 +2139,9 @@ gadt_constr :: { LConDecl GhcPs }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtypedoc
-                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3))
-                       [mu AnnDcolon $2] }
+                {% let (gadt,anns) = mkGadtDecl (unLoc $1) $3
+                   in ams (sLL $1 $> gadt)
+                       (mu AnnDcolon $2:anns) }
 
 {- Note [Difference in parsing GADT and data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 64b74d3..22de5ac 100644 (file)
@@ -629,7 +629,7 @@ mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
 mkConDeclH98 name mb_forall mb_cxt args
   = ConDeclH98 { con_ext    = noExt
                , con_name   = name
-               , con_forall = isJust mb_forall
+               , con_forall = noLoc $ isJust mb_forall
                , con_ex_tvs = mb_forall `orElse` []
                , con_mb_cxt = mb_cxt
                , con_args   = args'
@@ -639,33 +639,39 @@ mkConDeclH98 name mb_forall mb_cxt args
 
 mkGadtDecl :: [Located RdrName]
            -> LHsType GhcPs     -- Always a HsForAllTy
-           -> ConDecl GhcPs
+           -> (ConDecl GhcPs, [AddAnn])
 mkGadtDecl names ty
-  = ConDeclGADT { con_g_ext  = noExt
-                , con_names  = names
-                , con_forall = isLHsForAllTy ty
-                , con_qvars  = mkHsQTvs tvs
-                , con_mb_cxt = mcxt
-                , con_args   = args'
-                , con_res_ty = res_ty
-                , con_doc    = Nothing }
+  = (ConDeclGADT { con_g_ext  = noExt
+                 , con_names  = names
+                 , con_forall = L l $ isLHsForAllTy ty
+                 , con_qvars  = mkHsQTvs tvs
+                 , con_mb_cxt = mcxt
+                 , con_args   = args'
+                 , con_res_ty = res_ty
+                 , con_doc    = Nothing }
+    , anns1 ++ anns2 ++ anns3)
   where
-    (tvs, rho) = splitLHsForAllTy ty
-    (mcxt, tau) = split_rho rho
+    (ty'@(L l _),anns1) = peel_parens ty []
+    (tvs, rho) = splitLHsForAllTy ty'
+    (mcxt, tau, anns2) = split_rho rho []
 
-    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau }))
-                                   = (Just cxt, tau)
-    split_rho (L _ (HsParTy _ ty)) = split_rho ty
-    split_rho tau                  = (Nothing, tau)
+    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+                                       = (Just cxt, tau, ann)
+    split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
+    split_rho tau                  ann = (Nothing, tau, ann)
 
-    (args, res_ty) = split_tau tau
+    (args, res_ty, anns3) = split_tau tau []
     args' = nudgeHsSrcBangs args
 
     -- See Note [GADT abstract syntax] in HsDecls
-    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
-                                   = (RecCon (L loc rf), res_ty)
-    split_tau (L _ (HsParTy _ ty)) = split_tau ty
-    split_tau tau                  = (PrefixCon [], tau)
+    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) ann
+                                       = (RecCon (L loc rf), res_ty, ann)
+    split_tau (L l (HsParTy _ ty)) ann = split_tau ty (ann++mkParensApiAnn l)
+    split_tau tau                  ann = (PrefixCon [], tau, ann)
+
+    peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
+                                                       (ann++mkParensApiAnn l)
+    peel_parens ty                   ann = (ty, ann)
 
 nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
 -- ^ This function ensures that fields with strictness or packedness
index 98f8005..bff6694 100644 (file)
@@ -2007,7 +2007,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
                   all_fvs) }}
 
 rnConDecl decl@(ConDeclGADT { con_names   = names
-                            , con_forall  = explicit_forall
+                            , con_forall  = L _ explicit_forall
                             , con_qvars   = qtvs
                             , con_mb_cxt  = mcxt
                             , con_args    = args
index 76c0f7c..c50b5b9 100644 (file)
@@ -29,9 +29,9 @@
 ((Test10399.hs:12:30,AnnComma), [Test10399.hs:12:30]),
 ((Test10399.hs:12:31-32,AnnCloseP), [Test10399.hs:12:32]),
 ((Test10399.hs:12:31-32,AnnOpenP), [Test10399.hs:12:31]),
-((Test10399.hs:(14,1)-(17,69),AnnData), [Test10399.hs:14:1-4]),
-((Test10399.hs:(14,1)-(17,69),AnnSemi), [Test10399.hs:19:1]),
-((Test10399.hs:(14,1)-(17,69),AnnWhere), [Test10399.hs:14:21-25]),
+((Test10399.hs:(14,1)-(18,55),AnnData), [Test10399.hs:14:1-4]),
+((Test10399.hs:(14,1)-(18,55),AnnSemi), [Test10399.hs:20:1]),
+((Test10399.hs:(14,1)-(18,55),AnnWhere), [Test10399.hs:14:21-25]),
 ((Test10399.hs:15:5-64,AnnDcolon), [Test10399.hs:15:11-12]),
 ((Test10399.hs:15:5-64,AnnSemi), [Test10399.hs:16:5]),
 ((Test10399.hs:15:14-64,AnnDot), [Test10399.hs:15:23]),
 ((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]),
 ((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]),
 ((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]),
+((Test10399.hs:(16,5)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
 ((Test10399.hs:(16,5)-(17,69),AnnDcolon), [Test10399.hs:16:12-13]),
+((Test10399.hs:(16,5)-(17,69),AnnOpenP), [Test10399.hs:16:27]),
+((Test10399.hs:(16,5)-(17,69),AnnSemi), [Test10399.hs:18:5]),
 ((Test10399.hs:(16,15)-(17,69),AnnDot), [Test10399.hs:16:25]),
 ((Test10399.hs:(16,15)-(17,69),AnnForall), [Test10399.hs:16:15-20]),
 ((Test10399.hs:(16,27)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
 ((Test10399.hs:17:48-68,AnnRarrow), [Test10399.hs:17:50-51]),
 ((Test10399.hs:17:66-68,AnnCloseS), [Test10399.hs:17:68]),
 ((Test10399.hs:17:66-68,AnnOpenS), [Test10399.hs:17:66]),
-((Test10399.hs:19:1-25,AnnCloseQ), [Test10399.hs:19:24-25]),
-((Test10399.hs:19:1-25,AnnOpen), [Test10399.hs:19:1-3]),
-((Test10399.hs:19:1-25,AnnSemi), [Test10399.hs:21:1]),
-((Test10399.hs:19:20-22,AnnThIdSplice), [Test10399.hs:19:20-22]),
-((Test10399.hs:21:1-21,AnnEqual), [Test10399.hs:21:19]),
-((Test10399.hs:21:1-21,AnnFunId), [Test10399.hs:21:1-3]),
-((Test10399.hs:21:1-21,AnnSemi), [Test10399.hs:22:1]),
-((Test10399.hs:21:5-17,AnnCloseP), [Test10399.hs:21:17]),
-((Test10399.hs:21:5-17,AnnOpenPE), [Test10399.hs:21:5-6]),
-((Test10399.hs:21:8-15,AnnCloseQ), [Test10399.hs:21:14-15]),
-((Test10399.hs:21:8-15,AnnOpen), [Test10399.hs:21:8-10]),
-((<no location info>,AnnEofPos), [Test10399.hs:22:1])
+((Test10399.hs:18:5-55,AnnCloseP), [Test10399.hs:18:55]),
+((Test10399.hs:18:5-55,AnnDcolon), [Test10399.hs:18:16-17]),
+((Test10399.hs:18:5-55,AnnOpenP), [Test10399.hs:18:19]),
+((Test10399.hs:18:19-55,AnnCloseP), [Test10399.hs:18:55]),
+((Test10399.hs:18:19-55,AnnOpenP), [Test10399.hs:18:19]),
+((Test10399.hs:18:20-54,AnnDot), [Test10399.hs:18:29]),
+((Test10399.hs:18:20-54,AnnForall), [Test10399.hs:18:20-25]),
+((Test10399.hs:18:31-36,AnnCloseP), [Test10399.hs:18:36]),
+((Test10399.hs:18:31-36,AnnOpenP), [Test10399.hs:18:31]),
+((Test10399.hs:18:31-54,AnnRarrow), [Test10399.hs:18:38-39]),
+((Test10399.hs:20:1-25,AnnCloseQ), [Test10399.hs:20:24-25]),
+((Test10399.hs:20:1-25,AnnOpen), [Test10399.hs:20:1-3]),
+((Test10399.hs:20:1-25,AnnSemi), [Test10399.hs:22:1]),
+((Test10399.hs:20:20-22,AnnThIdSplice), [Test10399.hs:20:20-22]),
+((Test10399.hs:22:1-21,AnnEqual), [Test10399.hs:22:19]),
+((Test10399.hs:22:1-21,AnnFunId), [Test10399.hs:22:1-3]),
+((Test10399.hs:22:1-21,AnnSemi), [Test10399.hs:23:1]),
+((Test10399.hs:22:5-17,AnnCloseP), [Test10399.hs:22:17]),
+((Test10399.hs:22:5-17,AnnOpenPE), [Test10399.hs:22:5-6]),
+((Test10399.hs:22:8-15,AnnCloseQ), [Test10399.hs:22:14-15]),
+((Test10399.hs:22:8-15,AnnOpen), [Test10399.hs:22:8-10]),
+((<no location info>,AnnEofPos), [Test10399.hs:23:1])
 ]
 
index 949f9f0..6a35712 100644 (file)
@@ -15,6 +15,7 @@ data MaybeDefault v where
     SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
     SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
                                             -> a -> MaybeDefault [a])
+    TestParens :: (forall v . (Eq v) -> MaybeDefault v)
 
 [t| Map.Map T.Text $tc |]
 
index a0c0b24..adc0d14 100644 (file)
@@ -28,15 +28,13 @@ test('T10357',      [extra_files(['Test10357.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10357'])
 test('T10358',      [extra_files(['Test10358.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10358'])
-test('T10278',      [expect_broken(14529),
-                     extra_files(['Test10278.hs']),
+test('T10278',      [extra_files(['Test10278.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10278'])
 test('T10354',      [extra_files(['Test10354.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10354'])
 test('T10396',      [extra_files(['Test10396.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10396'])
-test('T10399',      [expect_broken(14529),
-                     extra_files(['Test10399.hs']),
+test('T10399',      [extra_files(['Test10399.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10399'])
 test('T10313',      [extra_files(['Test10313.hs', 'stringSource.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10313'])
index a176503..2310173 100644 (file)
@@ -33,7 +33,8 @@
           ({ DumpParsedAst.hs:5:14-17 }
            (Unqual
             {OccName: Zero}))
-          (False)
+          ({ <no location info> }
+           (False))
           []
           (Nothing)
           (PrefixCon
@@ -45,7 +46,8 @@
           ({ DumpParsedAst.hs:5:21-24 }
            (Unqual
             {OccName: Succ}))
-          (False)
+          ({ <no location info> }
+           (False))
           []
           (Nothing)
           (PrefixCon
index 673b391..a1c412b 100644 (file)
@@ -86,7 +86,8 @@
             (NoExt)
             ({ DumpRenamedAst.hs:6:14-17 }
              {Name: DumpRenamedAst.Zero})
-            (False)
+            ({ <no location info> }
+             (False))
             []
             (Nothing)
             (PrefixCon
@@ -97,7 +98,8 @@
             (NoExt)
             ({ DumpRenamedAst.hs:6:21-24 }
              {Name: DumpRenamedAst.Succ})
-            (False)
+            ({ <no location info> }
+             (False))
             []
             (Nothing)
             (PrefixCon
                (NoExt)
                [({ DumpRenamedAst.hs:16:3-5 }
                  {Name: DumpRenamedAst.Nat})]
-               (False)
+               ({ DumpRenamedAst.hs:16:10-45 }
+                (False))
                (HsQTvs
                 (HsQTvsRn
                  [{Name: f}
index e8e5e6a..e5aff5b 100644 (file)
@@ -39,7 +39,8 @@
             (NoExt)
             ({ T14189.hs:6:15-16 }
              {Name: T14189.MT})
-            (False)
+            ({ <no location info> }
+             (False))
             []
             (Nothing)
             (PrefixCon
@@ -55,7 +56,8 @@
             (NoExt)
             ({ T14189.hs:6:24-25 }
              {Name: T14189.NT})
-            (False)
+            ({ <no location info> }
+             (False))
             []
             (Nothing)
             (PrefixCon
@@ -66,7 +68,8 @@
             (NoExt)
             ({ T14189.hs:6:29 }
              {Name: T14189.F})
-            (False)
+            ({ <no location info> }
+             (False))
             []
             (Nothing)
             (RecCon
index 2755526..d58fff7 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 2755526abb478c2f51c9cf4b894de287dd318868
+Subproject commit d58fff78de7d48546a22392cefdd0abab1f1ccec