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, 35 insertions, 25 deletions

diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs
index e7f882b86e..657660a735 100644
--- a/compiler/prelude/ForeignCall.hs
+++ b/compiler/prelude/ForeignCall.hs
@@ -90,6 +90,8 @@ playInterruptible _ = False
 
 data CExportSpec
   = CExportStatic               -- foreign export ccall foo :: ty
+        SourceText              -- of the CLabelString.
+                                -- See note [Pragma source text] in BasicTypes
         CLabelString            -- C Name of exported function
         CCallConv
   deriving (Data, Typeable)
@@ -108,6 +110,8 @@ data CCallSpec
 data CCallTarget
   -- An "unboxed" ccall# to named function in a particular package.
   = StaticTarget
+        SourceText                -- of the CLabelString.
+                                  -- See note [Pragma source text] in BasicTypes
         CLabelString                    -- C-land name of label.
 
         (Maybe PackageKey)              -- What package the function is in.
@@ -194,7 +198,7 @@ isCLabelString lbl
 -- Printing into C files:
 
 instance Outputable CExportSpec where
-  ppr (CExportStatic str _) = pprCLabelString str
+  ppr (CExportStatic _ str _) = pprCLabelString str
 
 instance Outputable CCallSpec where
   ppr (CCallSpec fun cconv safety)
@@ -205,7 +209,7 @@ instance Outputable CCallSpec where
       gc_suf | playSafe safety = text "_GC"
              | otherwise       = empty
 
-      ppr_fun (StaticTarget fn mPkgId isFun)
+      ppr_fun (StaticTarget _ fn mPkgId isFun)
         = text (if isFun then "__pkg_ccall"
                          else "__pkg_ccall_value")
        <> gc_suf
@@ -218,11 +222,12 @@ instance Outputable CCallSpec where
         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 
 -- The filename for a C header file
-newtype Header = Header FastString
+-- Note [Pragma source text] in BasicTypes
+data Header = Header SourceText FastString
     deriving (Eq, Data, Typeable)
 
 instance Outputable Header where
-    ppr (Header h) = quotes $ ppr h
+    ppr (Header _ h) = quotes $ ppr h
 
 -- | A C type, used in CAPI FFI calls
 --
@@ -233,11 +238,11 @@ instance Outputable Header where
 -- For details on above see note [Api annotations] in ApiAnnotation
 data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
                    (Maybe Header) -- header to include for this type
-                   FastString     -- the type itself
+                   (SourceText,FastString) -- the type itself
     deriving (Data, Typeable)
 
 instance Outputable CType where
-    ppr (CType _ mh ct) = hDoc <+> ftext ct
+    ppr (CType _ mh (_,ct)) = hDoc <+> ftext ct
         where hDoc = case mh of
                      Nothing -> empty
                      Just h -> ppr h
@@ -270,13 +275,15 @@ instance Binary Safety where
               _ -> do return PlayRisky
 
 instance Binary CExportSpec where
-    put_ bh (CExportStatic aa ab) = do
+    put_ bh (CExportStatic ss aa ab) = do
+            put_ bh ss
             put_ bh aa
             put_ bh ab
     get bh = do
+          ss <- get bh
           aa <- get bh
           ab <- get bh
-          return (CExportStatic aa ab)
+          return (CExportStatic ss aa ab)
 
 instance Binary CCallSpec where
     put_ bh (CCallSpec aa ab ac) = do
@@ -290,8 +297,9 @@ instance Binary CCallSpec where
           return (CCallSpec aa ab ac)
 
 instance Binary CCallTarget where
-    put_ bh (StaticTarget aa ab ac) = do
+    put_ bh (StaticTarget ss aa ab ac) = do
             putByte bh 0
+            put_ bh ss
             put_ bh aa
             put_ bh ab
             put_ bh ac
@@ -300,10 +308,11 @@ instance Binary CCallTarget where
     get bh = do
             h <- getByte bh
             case h of
-              0 -> do aa <- get bh
+              0 -> do ss <- get bh
+                      aa <- get bh
                       ab <- get bh
                       ac <- get bh
-                      return (StaticTarget aa ab ac)
+                      return (StaticTarget ss aa ab ac)
               _ -> do return DynamicTarget
 
 instance Binary CCallConv where
@@ -336,6 +345,7 @@ instance Binary CType where
                 return (CType s mh fs)
 
 instance Binary Header where
-    put_ bh (Header h) = put_ bh h
-    get bh = do h <- get bh
-                return (Header h)
+    put_ bh (Header s h) = put_ bh s >> put_ bh h
+    get bh = do s <- get bh
+                h <- get bh
+                return (Header s h)
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 34c1838997..5ab8654f06 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -589,8 +589,8 @@ charTy = mkTyConTy charTyCon
 
 charTyCon :: TyCon
 charTyCon   = pcNonRecDataTyCon charTyConName
-                                (Just (CType "" Nothing (fsLit "HsChar")))
-                                [] [charDataCon]
+                       (Just (CType "" Nothing ("HsChar",fsLit "HsChar")))
+                       [] [charDataCon]
 charDataCon :: DataCon
 charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
 
@@ -602,8 +602,8 @@ intTy = mkTyConTy intTyCon
 
 intTyCon :: TyCon
 intTyCon = pcNonRecDataTyCon intTyConName
-                             (Just (CType "" Nothing (fsLit "HsInt"))) []
-                             [intDataCon]
+                            (Just (CType "" Nothing ("HsInt",fsLit "HsInt"))) []
+                            [intDataCon]
 intDataCon :: DataCon
 intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
 
@@ -612,8 +612,8 @@ wordTy = mkTyConTy wordTyCon
 
 wordTyCon :: TyCon
 wordTyCon = pcNonRecDataTyCon wordTyConName
-                              (Just (CType "" Nothing (fsLit "HsWord"))) []
-                              [wordDataCon]
+                      (Just (CType "" Nothing ("HsWord", fsLit "HsWord"))) []
+                      [wordDataCon]
 wordDataCon :: DataCon
 wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
 
@@ -622,8 +622,8 @@ floatTy = mkTyConTy floatTyCon
 
 floatTyCon :: TyCon
 floatTyCon   = pcNonRecDataTyCon floatTyConName
-                                 (Just (CType "" Nothing (fsLit "HsFloat"))) []
-                                 [floatDataCon]
+                      (Just (CType "" Nothing ("HsFloat", fsLit "HsFloat"))) []
+                      [floatDataCon]
 floatDataCon :: DataCon
 floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon
 
@@ -632,8 +632,8 @@ doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon :: TyCon
 doubleTyCon = pcNonRecDataTyCon doubleTyConName
-                                (Just (CType "" Nothing (fsLit "HsDouble"))) []
-                                [doubleDataCon]
+                      (Just (CType "" Nothing ("HsDouble",fsLit "HsDouble"))) []
+                      [doubleDataCon]
 
 doubleDataCon :: DataCon
 doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
@@ -693,7 +693,7 @@ boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
 boolTyCon = pcTyCon True NonRecursive True boolTyConName
-                    (Just (CType "" Nothing (fsLit "HsBool")))
+                    (Just (CType "" Nothing ("HsBool", fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
 falseDataCon, trueDataCon :: DataCon