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

5 files changed, 32 insertions, 29 deletions

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 801bc2724f..f8969a8e13 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -75,7 +75,8 @@ import DataCon
 import TyCon
 import PrelNames        ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
 import ErrUtils         ( MsgDoc )
-import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity )
+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,
+                          defaultFixity, pprWarningTxtForMsg, SourceText(..) )
 import SrcLoc
 import Outputable
 import Util
@@ -1072,7 +1073,7 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
                     <+> pprNonVarNameSpace (occNameSpace occ)
                     <+> quotes (ppr occ)
                   , parens imp_msg <> colon ]
-            , ppr txt ]
+            , pprWarningTxtForMsg txt ]
       where
         imp_mod  = importSpecModule imp_spec
         imp_msg  = text "imported from" <+> ppr imp_mod <> extra
@@ -1438,7 +1439,7 @@ lookupFixityRn_help' :: Name
                      -> RnM (Bool, Fixity)
 lookupFixityRn_help' name occ
   | isUnboundName name
-  = return (False, Fixity (show minPrecedence) minPrecedence InfixL)
+  = return (False, Fixity NoSourceText minPrecedence InfixL)
     -- Minimise errors from ubound names; eg
     --    a>0 `foo` b>0
     -- where 'foo' is not in scope, should not give an error (Trac #7937)
@@ -1517,7 +1518,7 @@ lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
         [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
         [ (_, fix):_ ] -> return fix
         ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
-                  >> return (Fixity(show minPrecedence) minPrecedence InfixL)
+                  >> return (Fixity NoSourceText minPrecedence InfixL)
 
     lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
 
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 991162dec8..7cafc2b22f 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -168,7 +168,7 @@ rnExpr (OpApp e1 op  _ e2)
         ; fixity <- case op' of
               L _ (HsVar (L _ n)) -> lookupFixityRn n
               L _ (HsRecFld f)    -> lookupFieldFixityRn f
-              _ -> return (Fixity (show minPrecedence) minPrecedence InfixL)
+              _ -> return (Fixity NoSourceText minPrecedence InfixL)
                    -- c.f. lookupFixity for unbound
 
         ; final_e <- mkOpAppRn e1' op' fixity e2'
@@ -474,7 +474,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
         -- inside 'arrow'.  In the higher-order case (-<<), they are.
 
 -- infix form
-rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
+rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
        ; let L _ (HsVar (L _ op_name)) = op'
        ; (arg1',fv_arg1) <- rnCmdTop arg1
@@ -484,10 +484,10 @@ rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
        ; final_e <- mkOpFormRn arg1' op' fixity arg2'
        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
 
-rnCmd (HsCmdArrForm op fixity cmds)
+rnCmd (HsCmdArrForm op f fixity cmds)
   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
        ; (cmds',fvCmds) <- rnCmdArgs cmds
-       ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
+       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
 
 rnCmd (HsCmdApp fun arg)
   = do { (fun',fvFun) <- rnLCmd  fun
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index e67be63fa4..2122c70c97 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -817,7 +817,7 @@ rnLit _ = return ()
 -- Integer-looking literal.
 generalizeOverLitVal :: OverLitVal -> OverLitVal
 generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val}))
-    | denominator val == 1 = HsIntegral src (numerator val)
+    | denominator val == 1 = HsIntegral (SourceText src) (numerator val)
 generalizeOverLitVal lit = lit
 
 rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 57c35873a8..0c41ed30b6 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -22,7 +22,7 @@ import Kind
 import RnEnv
 import RnSource         ( rnSrcDecls, findSplice )
 import RnPat            ( rnPat )
-import BasicTypes       ( TopLevelFlag, isTopLevel )
+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )
 import Outputable
 import Module
 import SrcLoc
@@ -309,7 +309,7 @@ runRnSplice flavour run_meta ppr_res splice
   = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
 
        ; let the_expr = case splice' of
-                  HsUntypedSplice _ e     ->  e
+                  HsUntypedSplice _ _ e   ->  e
                   HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
                   HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)
                   HsSpliced {}            -> pprPanic "runRnSplice" (ppr splice)
@@ -350,7 +350,7 @@ runRnSplice flavour run_meta ppr_res splice
 makePending :: UntypedSpliceFlavour
             -> HsSplice Name
             -> PendingRnSplice
-makePending flavour (HsUntypedSplice n e)
+makePending flavour (HsUntypedSplice _ n e)
   = PendingRnSplice flavour n e
 makePending flavour (HsQuasiQuote n quoter q_span quote)
   = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
@@ -370,7 +370,7 @@ mkQuasiQuoteExpr flavour quoter q_span quote
                      quoteExpr
   where
     quoterExpr = L q_span $! HsVar $! (L q_span quoter)
-    quoteExpr  = L q_span $! HsLit $! HsString "" quote
+    quoteExpr  = L q_span $! HsLit $! HsString NoSourceText quote
     quote_selector = case flavour of
                        UntypedExpSplice  -> quoteExpName
                        UntypedPatSplice  -> quotePatName
@@ -380,19 +380,19 @@ mkQuasiQuoteExpr flavour quoter q_span quote
 ---------------------
 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 -- Not exported...used for all
-rnSplice (HsTypedSplice splice_name expr)
+rnSplice (HsTypedSplice hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell typed splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsTypedSplice n' expr', fvs) }
+        ; return (HsTypedSplice hasParen n' expr', fvs) }
 
-rnSplice (HsUntypedSplice splice_name expr)
+rnSplice (HsUntypedSplice hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell untyped splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsUntypedSplice n' expr', fvs) }
+        ; return (HsUntypedSplice hasParen n' expr', fvs) }
 
 rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
   = do  { checkTH quoter "Template Haskell quasi-quote"
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index c548c4d0a6..00e27152de 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -464,9 +464,9 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
        ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
                 , fvs1 `plusFV` fvs2) }
 
-rnHsTyKi env (HsTyVar (L loc rdr_name))
+rnHsTyKi env (HsTyVar ip (L loc rdr_name))
   = do { name <- rnTyVar env rdr_name
-       ; return (HsTyVar (L loc name), unitFV name) }
+       ; return (HsTyVar ip (L loc name), unitFV name) }
 
 rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
   = setSrcSpan (getLoc l_op) $
@@ -586,7 +586,8 @@ rnHsTyKi env overall_ty@(HsAppsTy tys)
                    (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
       | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
       = deal_with_star acc1 acc2
-                       ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms)
+                       ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
+                            : non_syms2) : non_syms)
                        ops
     deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
       = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
@@ -643,12 +644,12 @@ rnHsTyKi _ (HsCoreTy ty)
     -- The emptyFVs probably isn't quite right
     -- but I don't think it matters
 
-rnHsTyKi env ty@(HsExplicitListTy k tys)
+rnHsTyKi env ty@(HsExplicitListTy ip k tys)
   = do { checkTypeInType env ty
        ; data_kinds <- xoptM LangExt.DataKinds
        ; unless data_kinds (addErr (dataKindsErr env ty))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsExplicitListTy k tys', fvs) }
+       ; return (HsExplicitListTy ip k tys', fvs) }
 
 rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
   = do { checkTypeInType env ty
@@ -1034,7 +1035,7 @@ collectAnonWildCards lty = go lty
       HsDocTy ty _                 -> go ty
       HsBangTy _ ty                -> go ty
       HsRecTy flds                 -> gos $ map (cd_fld_type . unLoc) flds
-      HsExplicitListTy _ tys       -> gos tys
+      HsExplicitListTy _ _ tys     -> gos tys
       HsExplicitTupleTy _ tys      -> gos tys
       HsForAllTy { hst_bndrs = bndrs
                  , hst_body = ty } -> collectAnonWildCardsBndrs bndrs
@@ -1247,15 +1248,16 @@ mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
           -> RnM (HsCmd Name)
 
 -- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
+mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)
+                                     [a11,a12])) _ _ _))
         op2 fix2 a2
   | nofix_error
   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
+       return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
 
   | associate_right
   = do new_c <- mkOpFormRn a12 op2 fix2 a2
-       return (HsCmdArrForm op1 (Just fix1)
+       return (HsCmdArrForm op1 f (Just fix1)
                [a11, L loc (HsCmdTop (L loc new_c)
                placeHolderType placeHolderType [])])
         -- TODO: locs are wrong
@@ -1264,7 +1266,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _
 
 --      Default case
 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
-  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
+  = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])
 
 
 --------------------------------------
@@ -1600,7 +1602,7 @@ extract_lkind = extract_lty KindLevel
 extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lty t_or_k (L _ ty) acc
   = case ty of
-      HsTyVar ltv               -> extract_tv t_or_k ltv acc
+      HsTyVar _  ltv            -> extract_tv t_or_k ltv acc
       HsBangTy _ ty             -> extract_lty t_or_k ty acc
       HsRecTy flds              -> foldrM (extract_lty t_or_k
                                            . cd_fld_type . unLoc) acc
@@ -1624,7 +1626,7 @@ extract_lty t_or_k (L _ ty) acc
       HsCoreTy {}               -> return acc  -- The type is closed
       HsSpliceTy {}             -> return acc  -- Type splices mention no tvs
       HsDocTy ty _              -> extract_lty t_or_k ty acc
-      HsExplicitListTy _ tys    -> extract_ltys t_or_k tys acc
+      HsExplicitListTy _ _ tys  -> extract_ltys t_or_k tys acc
       HsExplicitTupleTy _ tys   -> extract_ltys t_or_k tys acc
       HsTyLit _                 -> return acc
       HsKindSig ty ki           -> extract_lty t_or_k ty =<<