Add HsSyn prettyprinter tests

Summary:
Add prettyprinter tests, which take a file, parse it, pretty print it,
re-parse the pretty printed version and then compare the original and
new ASTs (ignoring locations)

Updates haddock submodule to match the AST changes.

There are three issues outstanding

1. Extra parens around a context are not reproduced. This will require an
   AST change and will be done in a separate patch.

2. Currently if an `HsTickPragma` is found, this is not pretty-printed,
   to prevent noise in the output.

   I am not sure what the desired behaviour in this case is, so have left
   it as before. Test Ppr047 is marked as expected fail for this.

3. Apart from in a context, the ParsedSource AST keeps all the parens from
   the original source.  Something is happening in the renamer to remove the
   parens around visible type application, causing T12530 to fail, as the
   dumped splice decl is after the renamer.

   This needs to be fixed by keeping the parens, but I do not know where they
   are being removed.  I have amended the test to pass, by removing the parens
   in the expected output.

Test Plan: ./validate

Reviewers: goldfire, mpickering, simonpj, bgamari, austin

Reviewed By: simonpj, bgamari

Subscribers: simonpj, goldfire, thomie, mpickering

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

GHC Trac Issues: #3384

7 files changed, 66 insertions, 68 deletions

diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
index 077c570f2b..0e8ce7c9dc 100644
--- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout
+++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
@@ -24,7 +24,7 @@
 
 (LiteralsTest.hs:5:3,ITequal,[=]),
 
-(LiteralsTest.hs:5:5-8,ITinteger "0003" 3,[0003]),
+(LiteralsTest.hs:5:5-8,ITinteger (SourceText "0003") 3,[0003]),
 
 (LiteralsTest.hs:6:1,ITsemi,[]),
 
@@ -32,7 +32,7 @@
 
 (LiteralsTest.hs:6:3,ITequal,[=]),
 
-(LiteralsTest.hs:6:5-8,ITinteger "0x04" 4,[0x04]),
+(LiteralsTest.hs:6:5-8,ITinteger (SourceText "0x04") 4,[0x04]),
 
 (LiteralsTest.hs:8:1,ITsemi,[]),
 
@@ -48,7 +48,7 @@
 
 (LiteralsTest.hs:9:3,ITequal,[=]),
 
-(LiteralsTest.hs:9:5-10,ITstring "\"\\x20\"" " ",["\x20"]),
+(LiteralsTest.hs:9:5-10,ITstring (SourceText "\"\\x20\"") " ",["\x20"]),
 
 (LiteralsTest.hs:11:1,ITsemi,[]),
 
@@ -64,7 +64,7 @@
 
 (LiteralsTest.hs:12:3,ITequal,[=]),
 
-(LiteralsTest.hs:12:5-10,ITchar "'\\x20'" ' ',['\x20']),
+(LiteralsTest.hs:12:5-10,ITchar (SourceText "'\\x20'") ' ',['\x20']),
 
 (LiteralsTest.hs:14:1,ITsemi,[]),
 
@@ -98,7 +98,7 @@
 
 (LiteralsTest.hs:19:11,ITequal,[=]),
 
-(LiteralsTest.hs:19:13-19,ITprimchar "'\\x41'" 'A',['\x41'#]),
+(LiteralsTest.hs:19:13-19,ITprimchar (SourceText "'\\x41'") 'A',['\x41'#]),
 
 (LiteralsTest.hs:20:5,ITsemi,[]),
 
@@ -106,7 +106,7 @@
 
 (LiteralsTest.hs:20:10,ITequal,[=]),
 
-(LiteralsTest.hs:20:12-16,ITprimint "0004#" 4,[0004#]),
+(LiteralsTest.hs:20:12-16,ITprimint (SourceText "0004#") 4,[0004#]),
 
 (LiteralsTest.hs:21:5,ITsemi,[]),
 
@@ -114,7 +114,7 @@
 
 (LiteralsTest.hs:21:11,ITequal,[=]),
 
-(LiteralsTest.hs:21:13-17,ITprimword "005##" 5,[005##]),
+(LiteralsTest.hs:21:13-17,ITprimword (SourceText "005##") 5,[005##]),
 
 (LiteralsTest.hs:22:5,ITsemi,[]),
 
@@ -138,7 +138,7 @@
 
 (LiteralsTest.hs:24:7,ITequal,[=]),
 
-(LiteralsTest.hs:24:9,ITinteger "1" 1,[1]),
+(LiteralsTest.hs:24:9,ITinteger (SourceText "1") 1,[1]),
 
 (LiteralsTest.hs:25:1,ITvccurly,[]),
 
diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
index 8664fdcf13..0170bc2949 100644
--- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs
+++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
@@ -3,7 +3,7 @@
 -- argument.
 module Main where
 
--- import Data.Generics
+import BasicTypes
 import Data.Data
 import Data.List
 import System.IO
@@ -42,21 +42,33 @@ testOneFile libdir fileName = do
      gq ast = everything (++) ([] `mkQ` doHsLit `extQ` doOverLit) ast
 
      doHsLit :: HsLit -> [String]
-     doHsLit (HsChar       src c) = ["HsChar [" ++ src ++ "] " ++ show c]
-     doHsLit (HsCharPrim   src c) = ["HsCharPrim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsString     src c) = ["HsString [" ++ src ++ "] " ++ show c]
-     doHsLit (HsStringPrim src c) = ["HsStringPrim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsInt        src c) = ["HsInt [" ++ src ++ "] " ++ show c]
-     doHsLit (HsIntPrim    src c) = ["HsIntPrim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsWordPrim   src c) = ["HsWordPrim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsInt64Prim  src c) = ["HsInt64Prim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsWord64Prim src c) = ["HsWord64Prim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsInteger  src c _) = ["HsInteger [" ++ src ++ "] " ++ show c]
+     doHsLit (HsChar       (SourceText src) c)
+       = ["HsChar [" ++ src ++ "] " ++ show c]
+     doHsLit (HsCharPrim   (SourceText src) c)
+       = ["HsCharPrim [" ++ src ++ "] " ++ show c]
+     doHsLit (HsString     (SourceText src) c)
+       = ["HsString [" ++ src ++ "] " ++ show c]
+     doHsLit (HsStringPrim (SourceText src) c)
+       = ["HsStringPrim [" ++ src ++ "] " ++ show c]
+     doHsLit (HsInt        (SourceText src) c)
+       = ["HsInt [" ++ src ++ "] " ++ show c]
+     doHsLit (HsIntPrim    (SourceText src) c)
+       = ["HsIntPrim [" ++ src ++ "] " ++ show c]
+     doHsLit (HsWordPrim   (SourceText src) c)
+       = ["HsWordPrim [" ++ src ++ "] " ++ show c]
+     doHsLit (HsInt64Prim  (SourceText src) c)
+       = ["HsInt64Prim [" ++ src ++ "] " ++ show c]
+     doHsLit (HsWord64Prim (SourceText src) c)
+       = ["HsWord64Prim [" ++ src ++ "] " ++ show c]
+     doHsLit (HsInteger  (SourceText src) c _)
+       = ["HsInteger [" ++ src ++ "] " ++ show c]
      doHsLit _ = []
 
      doOverLit :: OverLitVal -> [String]
-     doOverLit (HsIntegral  src c) = ["HsIntegral [" ++ src ++ "] " ++ show c]
-     doOverLit (HsIsString  src c) = ["HsIsString [" ++ src ++ "] " ++ show c]
+     doOverLit (HsIntegral  (SourceText src) c)
+       = ["HsIntegral [" ++ src ++ "] " ++ show c]
+     doOverLit (HsIsString  (SourceText src) c)
+       = ["HsIsString [" ++ src ++ "] " ++ show c]
      doOverLit _ = []
 
 pp a = showPpr unsafeGlobalDynFlags a
diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout
index ce7a004929..7984181504 100644
--- a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout
+++ b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout
@@ -1,12 +1,12 @@
 HsIntegral [0003] 3
-HsString [] "noExpr"
+HsString [noExpr] "noExpr"
 HsIntegral [0x04] 4
-HsString [] "noExpr"
+HsString [noExpr] "noExpr"
 HsString ["\x20"] " "
 HsChar ['\x20'] ' '
-HsString [] "noExpr"
+HsString [noExpr] "noExpr"
 HsCharPrim ['\x41'] 'A'
 HsIntPrim [0004#] 4
 HsWordPrim [005##] 5
 HsIntegral [1] 1
-HsString [] "noExpr"
+HsString [noExpr] "noExpr"
diff --git a/testsuite/tests/ghc-api/annotations/T10276.stderr b/testsuite/tests/ghc-api/annotations/T10276.stderr
index d79fc3a6e3..fff4c8ce4f 100644
--- a/testsuite/tests/ghc-api/annotations/T10276.stderr
+++ b/testsuite/tests/ghc-api/annotations/T10276.stderr
@@ -8,8 +8,7 @@ Test10276.hs:11:29: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:11:46: error:
     Not in scope: type constructor or class ‘M.Map’
@@ -17,8 +16,7 @@ Test10276.hs:11:46: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:11:52: error:
     Not in scope: type constructor or class ‘L.Name’
@@ -26,8 +24,7 @@ Test10276.hs:11:52: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:11:60: error:
     Not in scope: type constructor or class ‘L.Operand’
@@ -35,8 +32,7 @@ Test10276.hs:11:60: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:14:3: error:
     ‘qqExp’ is not a (visible) method of class ‘QQExp2’
@@ -47,8 +43,7 @@ Test10276.hs:15:29: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:15:46: error:
     Not in scope: type constructor or class ‘M.Map’
@@ -56,8 +51,7 @@ Test10276.hs:15:46: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:15:52: error:
     Not in scope: type constructor or class ‘L.Name’
@@ -65,8 +59,7 @@ Test10276.hs:15:52: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
 
 Test10276.hs:15:60: error:
     Not in scope: type constructor or class ‘L.Operand’
@@ -74,5 +67,4 @@ Test10276.hs:15:60: error:
     In the Template Haskell quotation
       [|| fst
           $ runState
-              ($$(qqExpM x))
-              ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
+              $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||]
diff --git a/testsuite/tests/ghc-api/annotations/T10313.stdout b/testsuite/tests/ghc-api/annotations/T10313.stdout
index a2680a9582..d1cc35cb61 100644
--- a/testsuite/tests/ghc-api/annotations/T10313.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10313.stdout
@@ -1,27 +1,17 @@
-[([i], [([", b, \, x, 6, 1, s, e, "], base)]),
+[([i], [(SourceText "b\x61se", base)]),
  ([w],
-  [([", N, e, w,  , Z, 3,  , A, P, I,  , s, u, p, p, o, r, t,  , i,
-     s,  , s, t, i, l, l,  , i, n, c, o, m, p, l, e, t, e,  , a, n, d,
-      , f, r, a, g, i, l, e, :,  , \, 
-,  ,  ,  ,  ,  ,  ,  ,  ,  ,  ,
-     \, y, o, u,  , m, a, y,  , e, x, p, e, r, i, e, n, c, e,  , s, e,
-     g, m, e, n, t, a, t, i, o, n,  , f, a, u, l, t, s, !, "],
+  [(SourceText "New Z3 API support is still incomplete and fragile: \
+          \you may experience segmentation faults!",
     New Z3 API support is still incomplete and fragile: you may experience segmentation faults!)]),
  ([d],
-  [([", D, e, p, r, e, c, a, t, i, o, n, :,  , \, 
-,  ,  ,  ,  ,  ,
-      ,  ,  ,  ,  , \, y, o, u,  , m, a, y,  , e, x, p, e, r, i, e, n,
-     c, e,  , s, e, g, m, e, n, t, a, t, i, o, n,  , f, a, u, l, t, s,
-     !, "],
+  [(SourceText "Deprecation: \
+          \you may experience segmentation faults!",
     Deprecation: you may experience segmentation faults!)]),
- ([c],
-  [([", f, o, o, \, x, 6, 3, "], fooc),
-   ([", b, \, x, 6, 1, r, "], bar)]),
- ([r], [([", f, o, o, 1, \, x, 6, 7, "], foo1g)]),
- ([s, t], [([", a, \, x, 6, 2, "], ab)]),
+ ([c], [(SourceText "foo\x63", fooc), (SourceText "b\x61r", bar)]),
+ ([r], [(SourceText "foo1\x67", foo1g)]),
+ ([s, t], [(SourceText "a\x62", ab)]),
  ([c, o],
-  [([", S, t, r, i, c, t,  , B, i, t, s, t, r, e, a, m,  , s, t, r,
-     e, \, x, 6, 1, m, "],
+  [(SourceText "Strict Bitstream stre\x61m",
     Strict Bitstream stream)]),
- ([s, c], [([", f, o, o, \, x, 6, 4, "], food)]),
- ([t, p], [([", f, o, o, b, \, x, 6, 1, r, "], foobar)])]
+ ([s, c], [(SourceText "foo\x64", food)]),
+ ([t, p], [(SourceText "foob\x61r", foobar)])]
diff --git a/testsuite/tests/ghc-api/annotations/T11430.stdout b/testsuite/tests/ghc-api/annotations/T11430.stdout
index 32d7ff1b24..157c29bb06 100644
--- a/testsuite/tests/ghc-api/annotations/T11430.stdout
+++ b/testsuite/tests/ghc-api/annotations/T11430.stdout
@@ -3,4 +3,4 @@
 ("ia",["1"])
 ("ia",["0x999"])
 ("ia",["1"])
-("tp",["((\"0x1\",\"0x2\"),(\"0x3\",\"0x4\"))"])
+("tp",["((SourceText \"0x1\",SourceText \"0x2\"),(SourceText \"0x3\",SourceText \"0x4\"))"])
diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs
index 1f00d1d5d2..151efbe611 100644
--- a/testsuite/tests/ghc-api/annotations/t11430.hs
+++ b/testsuite/tests/ghc-api/annotations/t11430.hs
@@ -56,20 +56,24 @@ testOneFile libdir fileName = do
                               ) ast
 
      doFixity :: Fixity -> [(String,[String])]
-     doFixity (Fixity ss _ _) = [("f",[ss])]
+     doFixity (Fixity (SourceText ss) _ _) = [("f",[ss])]
 
      doRuleDecl :: RuleDecl RdrName
                 -> [(String,[String])]
-     doRuleDecl (HsRule _ (ActiveBefore ss _) _ _ _ _ _) = [("rb",[ss])]
-     doRuleDecl (HsRule _ (ActiveAfter ss _) _ _ _ _ _) = [("ra",[ss])]
+     doRuleDecl (HsRule _ (ActiveBefore (SourceText ss) _) _ _ _ _ _)
+       = [("rb",[ss])]
+     doRuleDecl (HsRule _ (ActiveAfter (SourceText 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 _ _ _ (ActiveBefore (SourceText ss) _) _)
+         = [("ib",[ss])]
+     doInline (InlinePragma _ _ _ (ActiveAfter (SourceText ss) _) _)
+         = [("ia",[ss])]
      doInline (InlinePragma _ _ _ _ _ ) = []
 
 showAnns anns = "[\n" ++ (intercalate "\n"