Add difference tests for pretty-printing

We now also do a round-trip difference test for pretty-printing. In the
process, I found a bunch of pretty-printing bugs:

  * string literals
    - newlines were getting flattened
    - missing braces in unicode escapes
    - 'rb' instead of 'br' for raw bytestring prefixes
    - '\xHH' characters had too wide a range (only up to '\x7F' is allowed)
    - unicode escape is at most 6 hex digits, not 8
  * commas should never be present after '..' in struct patterns
  * the content of doc comments should not be indented
  * successive tuple field accessors need a space between them ('x.0 .0' instead of 'x.0.0')
  * successive '..' also need space ('x .. .. y' instead of 'x....y')

Author: harpocrates

src/Language/Rust/Parser.hs

@@ -23,7 +23,7 @@ sourceFile :: SourceFile Span
 
 module Language.Rust.Parser (
   -- * Parsing
-  parse, parse', readSourceFile, Parse(..), P, execParser, initPos, Span,
+  parse, parse', readSourceFile, readTokens, Parse(..), P, execParser, initPos, Span,
   -- * Lexing
   lexToken, lexNonSpace, lexTokens, translateLit,
   -- * Input stream
@@ -32,9 +32,9 @@ module Language.Rust.Parser (
   lexicalError, parseError, ParseFail,
 ) where
 
-import Language.Rust.Syntax.AST
+import Language.Rust.Syntax
 import Language.Rust.Data.InputStream (InputStream, readInputStream, inputStreamToString, inputStreamFromString)
-import Language.Rust.Data.Position (Position, Span, initPos, prettyPosition)
+import Language.Rust.Data.Position (Position, Span, Spanned, initPos, prettyPosition)
 import Language.Rust.Parser.Internal
 import Language.Rust.Parser.Lexer (lexToken, lexNonSpace, lexTokens, lexicalError)
 import Language.Rust.Parser.Literals (translateLit)
@@ -59,6 +59,14 @@ parse' is = case execParser parser is initPos of
 readSourceFile :: FilePath -> IO (SourceFile Span)
 readSourceFile fileName = parse' <$> readInputStream fileName
 
+-- | Given a path pointing to a Rust source file, read that file and lex it (ignoring whitespace)
+readTokens :: FilePath -> IO [Spanned Token]
+readTokens fileName = do
+  inp <- readInputStream fileName
+  case execParser (lexTokens lexNonSpace) inp initPos of
+    Left (pos, msg) -> throw (ParseFail pos msg)
+    Right x -> pure x
+
 -- | Exceptions that occur during parsing
 data ParseFail = ParseFail Position String deriving (Eq, Typeable)
 

src/Language/Rust/Parser/Lexer.x

@@ -917,16 +917,17 @@ $hexit             = [0-9a-fA-F]
 
 @char_escape
   = [nrt\\'"0]
-  | [xX] $hexit $hexit
-  | u $hexit $hexit $hexit $hexit
-  | U $hexit $hexit $hexit $hexit $hexit $hexit $hexit $hexit
+  | [xX] [0-7] $hexit
   | u\{ $hexit \}
   | u\{ $hexit $hexit \}
   | u\{ $hexit $hexit $hexit \}
   | u\{ $hexit $hexit $hexit $hexit \}
   | u\{ $hexit $hexit $hexit $hexit $hexit \}
   | u\{ $hexit $hexit $hexit $hexit $hexit $hexit \}
 
+@byte_escape
+  = [xX] $hexit $hexit
+  | [nrt\\'"0]
 
 -- literals
 
@@ -938,8 +939,7 @@ $hexit             = [0-9a-fA-F]
     \'
 
 @lit_byte
-  = b\' ( \\ ( [xX] $hexit $hexit
-             | [nrt\\'"0] )
+  = b\' ( \\ @byte_escape 
         | [^\\'\n\t\r] [ \udc00-\udfff ]?
         )
     \'
@@ -956,8 +956,8 @@ $hexit             = [0-9a-fA-F]
 @lit_float         = [0-9][0-9_]* @decimal_suffix? @exponent_suffix?
 @lit_float2        = [0-9][0-9_]* \.
 
-@lit_str           = \" (\\\n | \\\r\n | \\ @char_escape | [^\\\"] | \n | \r)* \"
-@lit_byte_str      = b @lit_str
+@lit_str           =   \" (\\\n | \\\r\n | \\ @char_escape | [^\\\"] | \n | \r)* \"
+@lit_byte_str      = b \" (\\\n | \\\r\n | \\ @byte_escape | [^\\\"] | \n | \r)* \"
 
 @lit_raw_str       = r \#* \"
 @lit_raw_bstr      = br \#* \"

src/Language/Rust/Pretty/Internal.hs

@@ -208,7 +208,7 @@ printToken (CloseDelim Bracket) = "]"
 printToken (CloseDelim Brace) = "}"
 printToken (CloseDelim NoDelim) = ""
 -- Literals
-printToken (LiteralTok l s) = printLitTok l <> perhaps printName s
+printToken (LiteralTok l s) = noIndent $ printLitTok l <> perhaps printName s
 -- Name components
 printToken (IdentTok i) = printIdent i
 printToken Underscore = "_"
@@ -232,10 +232,11 @@ printLitTok (ByteTok n)         = "b'" <> printName n <> "'"
 printLitTok (CharTok n)         = "'" <> printName n <> "'"
 printLitTok (IntegerTok n)      = printName n
 printLitTok (FloatTok n)        = printName n
-printLitTok (StrTok n)          = "\"" <> printName n <> "\""
-printLitTok (StrRawTok n m)     = let pad = pretty (replicate m '#') in "r" <> pad <> "\"" <> printName n <> "\"" <> pad
-printLitTok (ByteStrTok n)      = "b\"" <> printName n <> "\""
-printLitTok (ByteStrRawTok n m) = let pad = pretty (replicate m '#') in "rb" <> pad <> "\"" <> printName n <> "\"" <> pad
+printLitTok (StrTok n)          = "\"" <> string hardline n <> "\""
+printLitTok (StrRawTok n m)     = let pad = pretty (replicate m '#')
+                                  in "r" <> pad <> "\"" <> string hardline n <> "\"" <> pad
+printLitTok (ByteStrTok n)      = "b\"" <> string hardline n <> "\""
+printLitTok (ByteStrRawTok n m) = let pad = pretty (replicate m '#') in "br" <> pad <> "\"" <> string hardline n <> "\"" <> pad
 
 -- | Print a nonterminal
 printNonterminal :: Nonterminal a -> Doc a
@@ -298,7 +299,7 @@ printExprOuterAttrStyle expr isInline = glue (printEitherAttrs (expressionAttrs
     Vec as exprs x              -> annotate x (block Bracket True "," (printInnerAttrs as) (printExpr <$> exprs))
     Call _ func [arg] x         -> annotate x (printExpr func <> parens (printExpr arg))
     Call _ func args x          -> annotate x (printExpr func <> block Paren True "," mempty (printExpr <$> args))
-    MethodCall{}                -> chainedMethodCalls expr id
+    MethodCall{}                -> chainedMethodCalls expr False id
     TupExpr as [e] x            -> annotate x (block Paren True ""  (printInnerAttrs as) [ printExpr e <> "," ])
     TupExpr as es x             -> annotate x (block Paren True "," (printInnerAttrs as) (printExpr <$> es))
     Binary _ op lhs rhs x       -> annotate x (hsep [ printExpr lhs, printBinOp op, printExpr rhs ])
@@ -319,10 +320,10 @@ printExprOuterAttrStyle expr isInline = glue (printEitherAttrs (expressionAttrs
     Catch attrs blk x           -> annotate x ("do catch" <+> printBlockWithAttrs True blk attrs)
     Assign _ lhs rhs x          -> annotate x (hsep [ printExpr lhs, "=", printExpr rhs ])
     AssignOp _ op lhs rhs x     -> annotate x (hsep [ printExpr lhs, printBinOp op <> "=", printExpr rhs ])
-    FieldAccess{}               -> chainedMethodCalls expr id
-    TupField{}                  -> chainedMethodCalls expr id
-    Index{}                     -> chainedMethodCalls expr id
-    Range _ start end limits x  -> annotate x (hcat [ perhaps printExpr start, printRangeLimits limits, perhaps printExpr end ])
+    FieldAccess{}               -> chainedMethodCalls expr False id
+    TupField{}                  -> chainedMethodCalls expr False id
+    Index{}                     -> chainedMethodCalls expr False id
+    Range _ start end limits x  -> annotate x (perhaps printExpr start <+> printRangeLimits limits <+> perhaps printExpr end)
     PathExpr _ Nothing path x   -> annotate x (printPath path True)
     PathExpr _ (Just qs) path x -> annotate x (printQPath path qs True)
     AddrOf _ mut e x            -> annotate x ("&" <> printMutability mut <+> printExpr e)
@@ -335,7 +336,7 @@ printExprOuterAttrStyle expr isInline = glue (printEitherAttrs (expressionAttrs
                                    in annotate x (printPath p True <+> block Brace True mempty (printInnerAttrs as) body)
     Repeat attrs e cnt x        -> annotate x (brackets (printInnerAttrs attrs <+> printExpr e <> ";" <+> printExpr cnt))
     ParenExpr attrs e x         -> annotate x (parens (printInnerAttrs attrs <+> printExpr e))
-    Try{}                       -> chainedMethodCalls expr id
+    Try{}                       -> chainedMethodCalls expr False id
   where
   printLbl = perhaps (\i -> printLifetime i <> ":")
   glue = if isInline then (<+>) else (</>)
@@ -352,23 +353,26 @@ printExprOuterAttrStyle expr isInline = glue (printEitherAttrs (expressionAttrs
   --   * try
   --
   chainedMethodCalls :: Expr a            -- ^ expression
+                     -> Bool              -- ^ last expression was a 'TupField' (if we have two
+                                          -- successive 'TupField's, we need a space between them
+                                          -- to prevent them from looking like a float literal)
                      -> (Doc a -> Doc a)  -- ^ suffix to the expression
                      -> Doc a
-  chainedMethodCalls (MethodCall _ s i ts' as x) fdoc
+  chainedMethodCalls (MethodCall _ s i ts' as x) _ fdoc
     = let tys = perhaps (\ts -> "::<" <> commas ts printType <> ">") ts'
           as' = case as of
                   [a] -> parens (printExpr a)
                   _ -> block Paren True "," mempty (printExpr <$> as)
-      in chainedMethodCalls s (annotate x . (<##> fdoc (indent n (hcat [ ".", printIdent i, tys, as' ]))))
-  chainedMethodCalls (FieldAccess _ s i x) fdoc
-    = chainedMethodCalls s (annotate x . (<##> fdoc (indent n (hcat [ ".", printIdent i ]))))
-  chainedMethodCalls (Try _ s x) fdoc
-    = chainedMethodCalls s (annotate x . (<> fdoc "?"))
-  chainedMethodCalls (Index _ s i x) fdoc
-    = chainedMethodCalls s (annotate x . (<> fdoc ("[" <> block NoDelim True mempty mempty [printExpr i] <> "]")))
-  chainedMethodCalls (TupField _ s i x) fdoc
-    = chainedMethodCalls s (annotate x . (<> fdoc ("." <> pretty i)))
-  chainedMethodCalls e fdoc = group (fdoc (printExpr e))
+      in chainedMethodCalls s False (annotate x . (<##> fdoc (indent n (hcat [ ".", printIdent i, tys, as' ]))))
+  chainedMethodCalls (FieldAccess _ s i x) _ fdoc
+    = chainedMethodCalls s False (annotate x . (<##> fdoc (indent n (hcat [ ".", printIdent i ]))))
+  chainedMethodCalls (Try _ s x) _ fdoc
+    = chainedMethodCalls s False (annotate x . (<> fdoc "?"))
+  chainedMethodCalls (Index _ s i x) _ fdoc
+    = chainedMethodCalls s False (annotate x . (<> fdoc ("[" <> block NoDelim True mempty mempty [printExpr i] <> "]")))
+  chainedMethodCalls (TupField _ s i x) t fdoc
+    = chainedMethodCalls s True (annotate x . (<> fdoc ("." <> pretty i <> when t " ")))
+  chainedMethodCalls e _ fdoc = group (fdoc (printExpr e))
 
 -- | Print a string literal
 printStr :: StrStyle -> String -> Doc a
@@ -508,12 +512,12 @@ printEitherAttrs attrs kind inline = unless (null attrs') (glue attrs')
 
 -- | Print an attribute (@print_attribute_inline@ or @print_attribute@)
 printAttr :: Attribute a -> Bool -> Doc a
-printAttr   (Attribute Inner p ts x) _     = annotate x ("#![" <> printPath p True <> printTokenStreamSp ts <> printTokenStream ts <> "]")
-printAttr   (Attribute Outer p ts x) _     = annotate x ("#[" <> printPath p True <> printTokenStreamSp ts <> printTokenStream ts <> "]")
-printAttr   (SugaredDoc Inner _ c x) True  = annotate x ("/*!" <> pretty c <> "*/")
-printAttr   (SugaredDoc Outer _ c x) True  = annotate x ("/**" <> pretty c <> "*/")
-printAttr a@(SugaredDoc Inner _ c x) False = annotate x (flatAlt ("//!" <+> pretty c) (printAttr a True))
-printAttr a@(SugaredDoc Outer _ c x) False = annotate x (flatAlt ("///" <+> pretty c) (printAttr a True))
+printAttr (Attribute Inner p ts x) _     = annotate x ("#![" <> printPath p True <> printTokenStreamSp ts <> printTokenStream ts <> "]")
+printAttr (Attribute Outer p ts x) _     = annotate x ("#[" <> printPath p True <> printTokenStreamSp ts <> printTokenStream ts <> "]")
+printAttr (SugaredDoc Inner True c x)  _ = annotate x (noIndent ("/*!" <> string hardline c <> "*/"))
+printAttr (SugaredDoc Outer True c x)  _ = annotate x (noIndent ("/**" <> string hardline c <> "*/"))
+printAttr (SugaredDoc Inner False c x) _ = annotate x (flatAlt ("//!" <> pretty c) ("/*!" <> pretty c <> "*/"))
+printAttr (SugaredDoc Outer False c x) _ = annotate x (flatAlt ("///" <> pretty c) ("/**" <> pretty c <> "*/"))
 
 -- | Print an identifier as is, or as cooked string if containing a hyphen
 printCookedIdent :: Ident -> Doc a
@@ -667,9 +671,9 @@ printVis InheritedV = mempty
 -- | Print a foreign item (@print_foreign_item@)
 printForeignItem :: ForeignItem a -> Doc a
 printForeignItem (ForeignFn attrs vis ident decl generics x) = annotate x $
-  printOuterAttrs attrs <+> printFn decl Normal NotConst Rust (Just ident) generics vis Nothing
+  printOuterAttrs attrs <#> printFn decl Normal NotConst Rust (Just ident) generics vis Nothing
 printForeignItem (ForeignStatic attrs vis ident ty mut x) = annotate x $
-  printOuterAttrs attrs <+> printVis vis <+> "static" <+> printMutability mut <+> printIdent ident <> ":" <+> printType ty <> ";"
+  printOuterAttrs attrs <#> printVis vis <+> "static" <+> printMutability mut <+> printIdent ident <> ":" <+> printType ty <> ";"
 
 -- | Print a struct definition (@print_struct@)
 printStruct :: VariantData a -> Generics a -> Ident -> Bool -> Bool -> Doc a
@@ -776,8 +780,8 @@ printFullMutability Immutable = "const"
 printPat :: Pat a -> Doc a
 printPat (WildP x)                      = annotate x "_"
 printPat (IdentP bm p s x)              = annotate x (printBindingMode bm <+> printIdent p <+> perhaps (\p' -> "@" <+> printPat p') s)
-printPat (StructP p fs b x)             = annotate x (printPath p True <+> block Brace True "," mempty body)
-  where body = (printFieldPat `map` fs) ++ [ ".." | b ]
+printPat (StructP p fs False x)         = annotate x (printPath p True <+> block Brace True "," mempty (printFieldPat `map` fs))
+printPat (StructP p fs True x)          = annotate x (printPath p True <+> block Brace True mempty mempty ([ printFieldPat f <> "," | f <- fs ] ++ [ ".." ]))
 printPat (TupleStructP p es Nothing x)  = annotate x (printPath p True <> "(" <> commas es printPat <> ")")
 printPat (TupleStructP p es (Just d) x) = let (before,after) = splitAt d es
   in annotate x (printPath p True <> "(" <> commas before printPat <> when (d /= 0) ","

src/Language/Rust/Pretty/Literals.hs

@@ -17,19 +17,20 @@ module Language.Rust.Pretty.Literals (
 ) where
 
 import Language.Rust.Syntax.AST
+import Language.Rust.Pretty.Util
 
-import Data.Text.Prettyprint.Doc (hcat, annotate, (<>), Doc, pretty)
+import Data.Text.Prettyprint.Doc (hcat, annotate, (<>), Doc, pretty, hardline)
 
 import Data.Char (intToDigit, ord, chr)
 import Data.Word (Word8)
 
 -- | Print a literal (@print_literal@)
 printLit :: Lit a -> Doc a
-printLit lit = case lit of
+printLit lit = noIndent $ case lit of
     (Str     str Cooked  s x) -> annotate x (hcat [ "\"", foldMap escapeChar str, "\"", suf s ])
-    (Str     str (Raw n) s x) -> annotate x (hcat [ "r", pad n, "\"", pretty str, "\"", pad n, suf s ])
+    (Str     str (Raw n) s x) -> annotate x (hcat [ "r", pad n, "\"", string hardline str, "\"", pad n, suf s ])
     (ByteStr str Cooked  s x) -> annotate x (hcat [ "b\"", foldMap escapeByte str, "\"", suf s ])
-    (ByteStr str (Raw n) s x) -> annotate x (hcat [ "br", pad n, "\"", pretty (map byte2Char str), "\"", pad n, suf s ])
+    (ByteStr str (Raw n) s x) -> annotate x (hcat [ "br", pad n, "\"", string hardline (map byte2Char str), "\"", pad n, suf s ])
     (Char c s x)              -> annotate x (hcat [ "'",  escapeChar c, "'", suf s ])
     (Byte b s x)              -> annotate x (hcat [ "b'", escapeByte b, "'", suf s ])
     (Int b i s x)             -> annotate x (hcat [ printIntLit i b, suf s ])
@@ -92,9 +93,9 @@ escapeByte w8 = case byte2Char w8 of
 
 -- | Escape a unicode character. Based on @std::ascii::escape_default@
 escapeChar :: Char -> Doc a
-escapeChar c | c <= '\xff'   = escapeByte (char2Byte c)
-             | c <= '\xffff' = "\\u" <> padHex 4 (ord c)
-             | otherwise     = "\\U" <> padHex 8 (ord c)
+escapeChar c | c <= '\x7f'   = escapeByte (char2Byte c)
+             | c <= '\xffff' = "\\u{" <> padHex 4 (ord c) <> "}"
+             | otherwise     = "\\u{" <> padHex 6 (ord c) <> "}"
 
 -- | Convert a number to its padded hexadecimal form
 padHex :: Integral a => Int -> a -> Doc b

src/Language/Rust/Pretty/Util.hs

@@ -26,6 +26,7 @@ module Language.Rust.Pretty.Util where
 
 import Data.Monoid ((<>))
 import Data.List (mapAccumL)
+import Data.String (IsString(..))
 
 import qualified Data.Text.Prettyprint.Doc as PP
 import Data.Text.Prettyprint.Doc.Internal.Type (Doc(..))
@@ -117,7 +118,13 @@ ungroup :: Doc a -> Doc a
 ungroup (Union _ x) = x
 ungroup y = y
 
+-- | Remove all indent
+noIndent :: Doc a -> Doc a
+noIndent d = PP.nesting (\i -> PP.nest (negate i) d)
 
+-- | Translate '\n' in a string using the provided 'Doc' instead of 'line'
+string :: Doc a -> String -> Doc a
+string new = foldMap (\c -> case c of { '\n' -> new; _ -> Char c })
 
 -- | This is the most general function for printing blocks. It operates with any delimiter, any
 -- seperator, an optional leading attribute doc (which isn't followed by a seperator), and wraps a