ApiAnnotations : strings in warnings do not return SourceText

Summary:
The strings used in a WARNING pragma are captured via

    strings :: { Located ([AddAnn],[Located FastString]) }
        : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) }
    ..

The STRING token has a method getSTRINGs that returns the original
source text for a string.

A warning of the form

    {-# WARNING Logic
              , mkSolver
              , mkSimpleSolver
              , mkSolverForLogic
              , solverSetParams
              , solverPush
              , solverPop
              , solverReset
              , solverGetNumScopes
              , solverAssertCnstr
              , solverAssertAndTrack
              , solverCheck
              , solverCheckAndGetModel
              , solverGetReasonUnknown
              "New Z3 API support is still incomplete and fragile: \
              \you may experience segmentation faults!"
      #-}

returns the concatenated warning string rather than the original source.

This patch now deals with all remaining instances of getSTRING to bring
in a SourceText for each.

This updates the haddock submodule as well, for the AST change.

Test Plan: ./validate

Reviewers: hvr, austin, goldfire

Reviewed By: austin

Subscribers: bgamari, thomie, mpickering

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

GHC Trac Issues: #10313

2 files changed, 30 insertions, 29 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 63fc5f9c94..2739e10fb2 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -776,10 +776,10 @@ maybe_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }
         | {- empty -}                           { ([],False) }
 
-maybe_pkg :: { ([AddAnn],Maybe FastString) }
+maybe_pkg :: { ([AddAnn],Maybe (SourceText,FastString)) }
         : STRING  {% let pkgFS = getSTRING $1 in
                      if looksLikePackageName (unpackFS pkgFS)
-                        then return ([mj AnnPackageName $1], Just pkgFS)
+                        then return ([mj AnnPackageName $1], Just (getSTRINGs $1,pkgFS))
                         else parseErrorSDoc (getLoc $1) $ vcat [
                              text "parse error" <> colon <+> quotes (ppr pkgFS),
                              text "Version number or non-alphanumeric" <+>
@@ -1119,12 +1119,12 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
 
 capi_ctype :: { Maybe (Located CType) }
 capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRING $2)))
-                                        (getSTRING $3))))
+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
+                                        (getSTRINGs $3,getSTRING $3))))
                               [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
 
            | '{-# CTYPE'        STRING '#-}'
-                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing  (getSTRING $2))))
+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing  (getSTRINGs $2, getSTRING $2))))
                               [mo $1,mj AnnVal $2,mc $3] }
 
            |           { Nothing }
@@ -1378,7 +1378,7 @@ rules   :: { OrdList (LRuleDecl RdrName) }
 
 rule    :: { LRuleDecl RdrName }
         : STRING rule_activation rule_forall infixexp '=' exp
-         {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRING $1))
+         {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1))
                                   ((snd $2) `orElse` AlwaysActive)
                                   (snd $3) $4 placeHolderNames $6
                                   placeHolderNames))
@@ -1444,15 +1444,15 @@ deprecation :: { OrdList (LWarnDecl RdrName) }
              {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2)))
                      (fst $ unLoc $2) }
 
-strings :: { Located ([AddAnn],[Located FastString]) }
-    : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) }
+strings :: { Located ([AddAnn],[Located (SourceText,FastString)]) }
+    : STRING { sL1 $1 ([],[L (gl $1) (getSTRINGs $1,getSTRING $1)]) }
     | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
 
-stringlist :: { Located (OrdList (Located FastString)) }
+stringlist :: { Located (OrdList (Located (SourceText,FastString))) }
     : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
                                return (sLL $1 $> (unLoc $1 `snocOL`
-                                                  (L (gl $3) (getSTRING $3)))) }
-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) }
+                                                  (L (gl $3) (getSTRINGs $3,getSTRING $3)))) }
+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRINGs $1,getSTRING $1))) }
 
 -----------------------------------------------------------------------------
 -- Annotations
@@ -1500,12 +1500,12 @@ safety :: { Located Safety }
         | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
 fspec :: { Located ([AddAnn]
-                    ,(Located FastString, Located RdrName, LHsType RdrName)) }
+                    ,(Located (SourceText,FastString), Located RdrName, LHsType RdrName)) }
        : STRING var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $3]
                                              ,(L (getLoc $1)
-                                                    (getSTRING $1), $2, $4)) }
+                                                    (getSTRINGs $1,getSTRING $1), $2, $4)) }
        |        var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $2]
-                                             ,(noLoc nilFS, $1, $3)) }
+                                             ,(noLoc ("",nilFS), $1, $3)) }
          -- if the entity string is missing, it defaults to the empty string;
          -- the meaning of an empty entity string depends on the calling
          -- convention
@@ -2191,7 +2191,7 @@ exp10 :: { LHsExpr RdrName }
                                             -- TODO: is LL right here?
                                [mj AnnProc $1,mj AnnRarrow $3] }
 
-        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRING $2) $4)
+        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRINGs $2,getSTRING $2) $4)
                                               [mo $1,mj AnnVal $2
                                               ,mc $3] }
                                           -- hdaume: core annotation
@@ -2232,16 +2232,16 @@ optSemi :: { ([Located a],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }
 
-scc_annot :: { Located (([AddAnn],SourceText),FastString) }
+scc_annot :: { Located (([AddAnn],SourceText),(SourceText,FastString)) }
         : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
                                             ; return $ sLL $1 $>
                                                (([mo $1,mj AnnValStr $2
-                                                ,mc $3],getSCC_PRAGs $1),scc) }
+                                                ,mc $3],getSCC_PRAGs $1),(getSTRINGs $2,scc)) }
         | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
                                          ,mc $3],getSCC_PRAGs $1)
-                                        ,(getVARID $2)) }
+                                        ,(unpackFS $ getVARID $2,getVARID $2)) }
 
-hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int))) }
+hpc_annot :: { Located (([AddAnn],SourceText),((SourceText,FastString),(Int,Int),(Int,Int))) }
       : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
                                       { sLL $1 $> $ (([mo $1,mj AnnVal $2
                                               ,mj AnnVal $3,mj AnnColon $4
@@ -2249,7 +2249,7 @@ hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int)))
                                               ,mj AnnVal $7,mj AnnColon $8
                                               ,mj AnnVal $9,mc $10],
                                                 getGENERATED_PRAGs $1)
-                                              ,(getSTRING $2
+                                              ,((getSTRINGs $2,getSTRING $2)
                                                ,( fromInteger $ getINTEGER $3
                                                 , fromInteger $ getINTEGER $5
                                                 )
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index d3d3b7af90..98fa8f7608 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1472,21 +1472,21 @@ mkInlinePragma src (inl, match_info) mb_act
 --
 mkImport :: Located CCallConv
          -> Located Safety
-         -> (Located FastString, Located RdrName, LHsType RdrName)
+         -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
+mkImport (L lc cconv) (L ls safety) (L loc (esrc,entity), v, ty)
   | Just loc <- maybeLocation $ findWildcards ty
     = parseErrorSDoc loc $
       text "Wildcard not allowed" $$
       text "In foreign import declaration" <+>
       quotes (ppr v) $$ ppr ty
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget entity Nothing True)
+  let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
                            (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | cconv == JavaScriptCallConv = do
-  let funcTarget = CFunction (StaticTarget entity Nothing True)
+  let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
       importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
                            funcTarget (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
@@ -1515,7 +1515,7 @@ parseCImport cconv safety nm str sourceText =
              ((mk Nothing <$> cimp nm) +++
               (do h <- munch1 hdr_char
                   skipSpaces
-                  mk (Just (Header (mkFastString h))) <$> cimp nm))
+                  mk (Just (Header h (mkFastString h))) <$> cimp nm))
          ]
        skipSpaces
        return r
@@ -1544,7 +1544,8 @@ parseCImport cconv safety nm str sourceText =
                                              return False)
                               _ -> return True
                      cid' <- cid
-                     return (CFunction (StaticTarget cid' Nothing isFun)))
+                     return (CFunction (StaticTarget (unpackFS cid') cid'
+                                        Nothing isFun)))
           where
             cid = return nm +++
                   (do c  <- satisfy id_first_char
@@ -1555,13 +1556,13 @@ parseCImport cconv safety nm str sourceText =
 -- construct a foreign export declaration
 --
 mkExport :: Located CCallConv
-         -> (Located FastString, Located RdrName, LHsType RdrName)
+         -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkExport (L lc cconv) (L le entity, v, ty) = do
+mkExport (L lc cconv) (L le (esrc,entity), v, ty) = do
   checkNoPartialType (ptext (sLit "In foreign export declaration") <+>
                       quotes (ppr v) $$ ppr ty) ty
   return $ ForD (ForeignExport v ty noForeignExportCoercionYet
-                 (CExport (L lc (CExportStatic entity' cconv))
+                 (CExport (L lc (CExportStatic esrc entity' cconv))
                           (L le (unpackFS entity))))
   where
     entity' | nullFS entity = mkExtName (unLoc v)