Work SourceText in for all integer literals

Summary:
Certain syntactic elements have integers in them, such as fixity
specifications, SPECIALISE pragmas and so on.

The lexer will accept mult-radix literals, with arbitrary leading zeros
in these.

Bring in a SourceText field to each affected AST element to capture the
original literal text for use with API Annotations.

Affected hsSyn elements are

```
     -- See note [Pragma source text]
     data Activation = NeverActive
                     | AlwaysActive
                     | ActiveBefore SourceText PhaseNum
                          -- Active only *strictly before* this phase
                     | ActiveAfter SourceText PhaseNum
                           -- Active in this phase and later
                     deriving( Eq, Data, Typeable )
                               -- Eq used in comparing rules in HsDecls

     data Fixity = Fixity SourceText Int FixityDirection
       -- Note [Pragma source text]
       deriving (Data, Typeable)
 ```

and

```
      | HsTickPragma         -- A pragma introduced tick
         SourceText           -- Note [Pragma source text] in BasicTypes
         (StringLiteral,(Int,Int),(Int,Int))
                                          -- external span for this tick
         ((SourceText,SourceText),(SourceText,SourceText))
            -- Source text for the four integers used in the span.
            -- See note [Pragma source text] in BasicTypes
         (LHsExpr id)
```

Updates haddock submodule

Test Plan: ./validate

Reviewers: goldfire, bgamari, austin

Reviewed By: bgamari

Subscribers: thomie, mpickering

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

GHC Trac Issues: #11430

6 files changed, 167 insertions, 1 deletions

diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 212f7b0706..045cd4084d 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -7,6 +7,7 @@ clean:
 	rm -f annotations comments parseTree
 	rm -f listcomps
 	rm -f stringSource
+	rm -f t11430
 
 .PHONY: annotations
 annotations:
@@ -118,3 +119,9 @@ T11321:
 .PHONY: T11332
 T11332:
 	$(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11332
+
+.PHONY: T11430
+T11430:
+	rm -f t11430.o t11430.hi t11430
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t11430
+	./t11430 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430
diff --git a/testsuite/tests/ghc-api/annotations/T11430.stdout b/testsuite/tests/ghc-api/annotations/T11430.stdout
new file mode 100644
index 0000000000..32d7ff1b24
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T11430.stdout
@@ -0,0 +1,6 @@
+("f",["0x1"])
+("ib",["001"])
+("ia",["1"])
+("ia",["0x999"])
+("ia",["1"])
+("tp",["((\"0x1\",\"0x2\"),(\"0x3\",\"0x4\"))"])
diff --git a/testsuite/tests/ghc-api/annotations/Test11430.hs b/testsuite/tests/ghc-api/annotations/Test11430.hs
new file mode 100644
index 0000000000..4b124e478c
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test11430.hs
@@ -0,0 +1,25 @@
+module Test11430 where
+
+
+infixl 0x1 `f`
+
+x `f` y = x
+
+
+{-# SPECIALISE [~ 001] x ::
+        Integer -> Integer -> Integer,
+        Integer -> Int -> Integer,
+        Int -> Int -> Int #-}
+{-# INLINABLE [1] x #-}
+x :: (Num a, Integral b) => a -> b -> a
+x = undefined
+
+{-# SPECIALISE INLINE [0x999] y ::
+        Integer -> Integer -> Integer,
+        Integer -> Int -> Integer,
+        Int -> Int -> Int #-}
+{-# INLINABLE [1] y #-}
+y :: (Num a, Integral b) => a -> b -> a
+y = undefined
+
+c = {-# GENERATED "foob\x61r" 0x1 : 0x2  -  0x3 :   0x4 #-} 0.00
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index a2750ff08a..64f69e20f0 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -23,3 +23,4 @@ test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundl
 test('T10276',      normal, run_command, ['$MAKE -s --no-print-directory T10276'])
 test('T11321',      normal, run_command, ['$MAKE -s --no-print-directory T11321'])
 test('T11332',      normal, run_command, ['$MAKE -s --no-print-directory T11332'])
+test('T11430',      normal, run_command, ['$MAKE -s --no-print-directory T11430'])
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index 1e8af17072..bf691ae8ea 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -82,7 +82,7 @@ testOneFile libdir fileName = do
      doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])]
      doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])]
      doHsExpr (HsSCC     src ss _) = [("sc",[conv (noLoc ss)])]
-     doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])]
+     doHsExpr (HsTickPragma src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])]
      doHsExpr _ = []
 
      conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)
diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs
new file mode 100644
index 0000000000..1f00d1d5d2
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/t11430.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data hiding (Fixity)
+import Data.List
+import System.IO
+import GHC
+import BasicTypes
+import DynFlags
+import FastString
+import ForeignCall
+import MonadUtils
+import Outputable
+import HsDecls
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir,fileName] <- getArgs
+        testOneFile libdir fileName
+
+testOneFile libdir fileName = do
+       ((anns,cs),p) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        return (pm_annotations p,p)
+
+       let tupArgs = gq (pm_parsed_source p)
+
+       putStrLn (intercalate "\n" $ map show tupArgs)
+       -- putStrLn (pp tupArgs)
+       -- putStrLn (intercalate "\n" [showAnns anns])
+
+    where
+     gq ast = everything (++) ([] `mkQ` doFixity
+                               `extQ` doRuleDecl
+                               `extQ` doHsExpr
+                               `extQ` doInline
+                              ) ast
+
+     doFixity :: Fixity -> [(String,[String])]
+     doFixity (Fixity ss _ _) = [("f",[ss])]
+
+     doRuleDecl :: RuleDecl RdrName
+                -> [(String,[String])]
+     doRuleDecl (HsRule _ (ActiveBefore ss _) _ _ _ _ _) = [("rb",[ss])]
+     doRuleDecl (HsRule _ (ActiveAfter ss _) _ _ _ _ _) = [("ra",[ss])]
+     doRuleDecl (HsRule _ _ _ _ _ _ _) = []
+
+     doHsExpr :: HsExpr RdrName -> [(String,[String])]
+     doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])]
+     doHsExpr _ = []
+
+     doInline (InlinePragma _ _ _ (ActiveBefore ss _) _) = [("ib",[ss])]
+     doInline (InlinePragma _ _ _ (ActiveAfter ss _) _) = [("ia",[ss])]
+     doInline (InlinePragma _ _ _ _ _ ) = []
+
+showAnns anns = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp a = showPpr unsafeGlobalDynFlags a
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)