Test that `dhall format` is idempotent (#1427)

dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs

@@ -128,7 +128,7 @@ parse = fmap snd . parseWithHeader
 
 -- | Parse a Dhall expression along with its "header", i.e. whitespace and
 --   comments prefixing the actual code.
-parseWithHeader :: Text -> Either DhallError (Text, Expr Src Dhall.Import)
+parseWithHeader :: Text -> Either DhallError (Dhall.Header, Expr Src Dhall.Import)
 parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText ""
 
 -- | Resolve all imports in an expression.

dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs

@@ -1,6 +1,7 @@
 module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where
 
 import Dhall.Core (Expr)
+import Dhall.Parser (Header(..))
 import Dhall.Pretty (CharacterSet(..), layoutOpts, prettyCharacterSet)
 import Dhall.Src (Src)
 
@@ -11,12 +12,12 @@ import qualified Data.Text.Prettyprint.Doc.Render.Text     as Pretty
 
 -- | Pretty-print the given Dhall expression.
 formatExpr :: Pretty.Pretty b => Expr Src b -> Text
-formatExpr expr = formatExprWithHeader expr ""
+formatExpr expr = formatExprWithHeader expr (Header "")
 
 -- | Pretty-print the given Dhall expression, prepending the given a "header"
 --   (usually consisting of comments and whitespace).
-formatExprWithHeader :: Pretty.Pretty b => Expr Src b -> Text -> Text
-formatExprWithHeader expr header = Pretty.renderStrict
+formatExprWithHeader :: Pretty.Pretty b => Expr Src b -> Header -> Text
+formatExprWithHeader expr (Header header) = Pretty.renderStrict
   (Pretty.layoutSmart layoutOpts doc)
   where
     doc =

dhall/src/Dhall/Format.hs

@@ -55,7 +55,8 @@ format (Format {..}) =
         Modify {..} ->
             case inplace of
                 InputFile file -> do
-                    (header, expr) <- Dhall.Util.getExpressionAndHeader censor (InputFile file)
+                    (Dhall.Util.Header header, expr) <-
+                        Dhall.Util.getExpressionAndHeader censor (InputFile file)
 
                     let doc =   Pretty.pretty header
                             <>  Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr)
@@ -64,7 +65,8 @@ format (Format {..}) =
                     System.IO.withFile file System.IO.WriteMode (\handle -> do
                         Pretty.Terminal.renderIO handle (Pretty.layoutSmart layoutOpts doc))
                 StandardInput -> do
-                    (header, expr) <- Dhall.Util.getExpressionAndHeader censor StandardInput
+                    (Dhall.Util.Header header, expr) <-
+                        Dhall.Util.getExpressionAndHeader censor StandardInput
 
                     let doc =   Pretty.pretty header
                             <>  Dhall.Pretty.prettyCharacterSet characterSet expr
@@ -86,7 +88,8 @@ format (Format {..}) =
                 InputFile file -> Data.Text.IO.readFile file
                 StandardInput  -> Data.Text.IO.getContents
 
-            (header, expr) <- Dhall.Util.getExpressionAndHeader censor path
+            (Dhall.Util.Header header, expr) <-
+                Dhall.Util.getExpressionAndHeader censor path
 
             let doc =   Pretty.pretty header
                     <>  Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr)

dhall/src/Dhall/Freeze.hs

@@ -145,7 +145,8 @@ freeze inplace scope intent characterSet censor = do
             StandardInput  -> "."
             InputFile file -> System.FilePath.takeDirectory file
 
-    (header, parsedExpression) <- Dhall.Util.getExpressionAndHeader censor inplace
+    (Dhall.Util.Header header, parsedExpression) <-
+        Dhall.Util.getExpressionAndHeader censor inplace
 
     let freezeScope =
             case scope of

dhall/src/Dhall/Main.hs

@@ -34,7 +34,7 @@ import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semantic
 import Dhall.Parser (Src)
 import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle, layoutOpts)
 import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError)
-import Dhall.Util (Censor(..), Input(..), Output(..))
+import Dhall.Util (Censor(..), Header (..), Input(..), Output(..))
 import Dhall.Version (dhallVersionString)
 import Options.Applicative (Parser, ParserInfo)
 import System.Exit (ExitCode, exitFailure)
@@ -650,7 +650,7 @@ command (Options {..}) = do
             Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression)
 
         Lint {..} -> do
-            (header, expression) <- getExpressionAndHeader inplace
+            (Header header, expression) <- getExpressionAndHeader inplace
 
             case inplace of
                 InputFile file -> do

dhall/src/Dhall/Parser.hs

@@ -8,11 +8,13 @@ module Dhall.Parser (
       exprFromText
     , exprAndHeaderFromText
     , censor
+    , createHeader
 
     -- * Parsers
     , expr, exprA
 
     -- * Types
+    , Header(..)
     , Src(..)
     , SourcedException(..)
     , ParseError(..)
@@ -92,6 +94,17 @@ exprFromText
   -> Either ParseError (Expr Src Import)
 exprFromText delta text = fmap snd (exprAndHeaderFromText delta text)
 
+-- | A header corresponds to the leading comment at the top of a Dhall file.
+--
+-- The header includes comment characters but is stripped of leading spaces and
+-- trailing newlines
+newtype Header = Header Text deriving Show
+
+-- | Create a header with stripped leading spaces and trailing newlines
+createHeader :: Text -> Header
+createHeader =
+    Header . Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n')
+
 {-| Like `exprFromText` but also returns the leading comments and whitespace
     (i.e. header) up to the last newline before the code begins
 
@@ -108,10 +121,10 @@ exprAndHeaderFromText
     :: String -- ^ User-friendly name describing the input expression,
               --   used in parsing error messages
     -> Text   -- ^ Input expression to parse
-    -> Either ParseError (Text, Expr Src Import)
+    -> Either ParseError (Header, Expr Src Import)
 exprAndHeaderFromText delta text = case result of
     Left errInfo   -> Left (ParseError { unwrap = errInfo, input = text })
-    Right (txt, r) -> Right (stripHeader txt, r)
+    Right (txt, r) -> Right (createHeader txt, r)
   where
     parser = do
         (bytes, _) <- Text.Megaparsec.match whitespace
@@ -120,5 +133,3 @@ exprAndHeaderFromText delta text = case result of
         return (bytes, r)
 
     result = Text.Megaparsec.parse (unParser parser) delta text
-
-    stripHeader = Data.Text.dropWhile Data.Char.isSpace . Data.Text.dropWhileEnd (/= '\n')

dhall/src/Dhall/Pretty/Internal.hs

@@ -109,7 +109,7 @@ annToAnsiStyle Builtin  = Terminal.underlined
 annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green
 
 -- | This type determines whether to render code as `ASCII` or `Unicode`
-data CharacterSet = ASCII | Unicode
+data CharacterSet = ASCII | Unicode deriving Show
 
 -- | Pretty print an expression
 prettyExpr :: Pretty a => Expr s a -> Doc Ann

dhall/src/Dhall/Util.hs

@@ -12,6 +12,7 @@ module Dhall.Util
     , Output(..)
     , getExpression
     , getExpressionAndHeader
+    , Header(..)
     ) where
 
 import Data.Bifunctor (first)
@@ -20,7 +21,7 @@ import Data.String (IsString)
 import Data.Text (Text)
 import Data.Text.Prettyprint.Doc (Doc, Pretty)
 import Dhall.Core (Expr, Import)
-import Dhall.Parser (ParseError)
+import Dhall.Parser (ParseError, Header(..))
 import Dhall.Pretty (Ann)
 import Dhall.Src (Src)
 
@@ -129,5 +130,5 @@ getExpression :: Censor -> Input -> IO (Expr Src Import)
 getExpression = get Dhall.Parser.exprFromText
 
 -- | Convenient utility for retrieving an expression along with its header
-getExpressionAndHeader :: Censor -> Input -> IO (Text, Expr Src Import)
+getExpressionAndHeader :: Censor -> Input -> IO (Header, Expr Src Import)
 getExpressionAndHeader = get Dhall.Parser.exprAndHeaderFromText

dhall/tests/Dhall/Test/Format.hs

@@ -4,6 +4,7 @@ module Dhall.Test.Format where
 
 import Data.Monoid (mempty, (<>))
 import Data.Text (Text)
+import Dhall.Parser (Header(..))
 import Dhall.Pretty (CharacterSet(..))
 import Test.Tasty (TestTree)
 
@@ -43,6 +44,16 @@ getTests = do
 
     return testTree
 
+format :: CharacterSet -> (Header, Core.Expr Parser.Src Core.Import) -> Text
+format characterSet (Header header, expr) =
+    let doc =  Doc.pretty header
+            <> Pretty.prettyCharacterSet characterSet expr
+            <> "\n"
+
+        docStream = Doc.layoutSmart Pretty.layoutOpts doc
+    in
+        Doc.Render.Text.renderStrict docStream
+
 formatTest :: CharacterSet -> Text -> TestTree
 formatTest characterSet prefix =
     Tasty.HUnit.testCase (Text.unpack prefix) $ do
@@ -51,14 +62,9 @@ formatTest characterSet prefix =
 
         inputText <- Text.IO.readFile inputFile
 
-        (header, expr) <- Core.throws (Parser.exprAndHeaderFromText mempty inputText)
-
-        let doc        =   Doc.pretty header
-                       <>  Pretty.prettyCharacterSet characterSet expr
-                       <>  "\n"
-        let docStream  = Doc.layoutSmart Pretty.layoutOpts doc
-        let actualText = Doc.Render.Text.renderStrict docStream
+        headerAndExpr <- Core.throws (Parser.exprAndHeaderFromText mempty inputText)
 
+        let actualText = format characterSet headerAndExpr
         expectedText <- Text.IO.readFile outputFile
 
         let message =

dhall/tests/Dhall/Test/QuickCheck.hs

@@ -1,10 +1,10 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE StandaloneDeriving  #-}
-{-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -13,6 +13,7 @@ module Dhall.Test.QuickCheck where
 import Codec.Serialise (DeserialiseFailure(..))
 import Data.Either (isRight)
 import Data.Either.Validation (Validation(..))
+import Data.Monoid ((<>))
 import Dhall (ToDhall(..), FromDhall(..), auto, extract, inject, embed, Vector)
 import Dhall.Map (Map)
 import Dhall.Core
@@ -37,11 +38,15 @@ import Data.Functor.Identity (Identity(..))
 import Data.Typeable (Typeable, typeRep)
 import Data.Proxy (Proxy(..))
 import Dhall.Set (Set)
+import Dhall.Parser (Header, createHeader)
+import Dhall.Pretty (CharacterSet(..))
 import Dhall.Src (Src(..))
+import Dhall.Test.Format (format)
 import Dhall.TypeCheck (Typer, TypeError)
 import Generic.Random (Weights, W, (%), (:+)(..))
 import Test.QuickCheck
-    (Arbitrary(..), Gen, Positive(..), Property, NonNegative(..), genericShrink, (===), (==>))
+    ( Arbitrary(..), Gen, Positive(..), Property, NonNegative(..)
+    , genericShrink, suchThat, (===), (==>))
 import Test.QuickCheck.Instances ()
 import Test.Tasty (TestTree)
 import Test.Tasty.QuickCheck (QuickCheckTests(..))
@@ -63,6 +68,7 @@ import qualified Dhall.Context
 import qualified Dhall.Core
 import qualified Dhall.Diff
 import qualified Dhall.Map
+import qualified Dhall.Parser as Parser
 import qualified Dhall.Set
 import qualified Dhall.TypeCheck
 import qualified Generic.Random
@@ -140,6 +146,31 @@ integer =
         , (1, fmap (\x -> x - (2 ^ (64 :: Int))) arbitrary)
         ]
 
+instance Arbitrary CharacterSet where
+    arbitrary = Test.QuickCheck.elements [ ASCII, Unicode ]
+
+instance Arbitrary Header where
+    arbitrary = do
+      let multiline = do
+            txt <- arbitrary `suchThat` (not . Text.isInfixOf "-}")
+            pure $ "{-" <> txt <> "-}"
+
+          singleline = do
+            txt <- arbitrary `suchThat` (not . Text.isInfixOf "\n")
+            pure $ "--" <> txt
+
+          newlines = Text.concat <$> Test.QuickCheck.listOf (pure "\n")
+
+      comments <- Test.QuickCheck.listOf $ Test.QuickCheck.oneof
+        [ multiline
+        , singleline
+        , newlines
+        ]
+
+      pure . createHeader $ Text.unlines comments
+
+    shrink = const [] -- TODO improve
+
 instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where
     arbitrary = do
         n   <- Test.QuickCheck.choose (0, 2)
@@ -450,17 +481,24 @@ normalizingAnExpressionDoesntChangeItsInferredType expression =
 embedThenExtractIsIdentity
     :: forall a. (ToDhall a, FromDhall a, Eq a, Typeable a, Arbitrary a, Show a)
     => Proxy a
-    -> (String, Property, QuickCheckTests)
+    -> (String, Property, TestTree -> TestTree)
 embedThenExtractIsIdentity p =
     ( "Embedding then extracting is identity for " ++ show (typeRep p)
     , Test.QuickCheck.property (prop :: a -> Bool)
-    , QuickCheckTests 1000
+    , adjustQuickCheckTests 1000
     )
   where
     prop a = case extract auto (embed inject a) of
         Success a' -> a == a'
         Failure _  -> False
 
+idempotenceTest :: Property
+idempotenceTest =
+    Test.QuickCheck.property $
+        \characterSet (format characterSet -> once) ->
+            case Parser.exprAndHeaderFromText mempty once of
+                Right (format characterSet -> twice) -> once === twice
+                Left _ -> Test.QuickCheck.discard
 
 tests :: TestTree
 tests =
@@ -468,31 +506,31 @@ tests =
         "QuickCheck"
         [ ( "Binary serialization should round-trip"
           , Test.QuickCheck.property binaryRoundtrip
-          , QuickCheckTests 100
+          , adjustQuickCheckTests 100
           )
         , ( "everything well-typed should normalize"
           , Test.QuickCheck.property everythingWellTypedNormalizes
-          , QuickCheckTests 100000
+          , adjustQuickCheckTests 100000
           )
         , ( "isNormalized should be consistent with normalize"
           , Test.QuickCheck.property isNormalizedIsConsistentWithNormalize
-          , QuickCheckTests 10000
+          , adjustQuickCheckTests 10000
           )
         , ( "normalizeWithM should be consistent with normalize"
           , Test.QuickCheck.property normalizeWithMIsConsistentWithNormalize
-          , QuickCheckTests 10000
+          , adjustQuickCheckTests 10000
           )
         , ( "An expression should have no difference with itself"
           , Test.QuickCheck.property isSameAsSelf
-          , QuickCheckTests 10000
+          , adjustQuickCheckTests 10000
           )
         , ( "Inferred types should be normalized"
           , Test.QuickCheck.property inferredTypesAreNormalized
-          , QuickCheckTests 10000
+          , adjustQuickCheckTests 10000
           )
         , ( "Normalizing an expression doesn't change its inferred type"
           , Test.QuickCheck.property normalizingAnExpressionDoesntChangeItsInferredType
-          , QuickCheckTests 10000
+          , adjustQuickCheckTests 10000
           )
         , embedThenExtractIsIdentity (Proxy :: Proxy (Text.Text))
         , embedThenExtractIsIdentity (Proxy :: Proxy [Nat.Natural])
@@ -504,13 +542,24 @@ tests =
         , embedThenExtractIsIdentity (Proxy :: Proxy (Vector Double))
         , embedThenExtractIsIdentity (Proxy :: Proxy (Data.Map.Map Double Bool))
         , embedThenExtractIsIdentity (Proxy :: Proxy (HashMap.HashMap Double Bool))
+        , ( "Formatting should be idempotent"
+          , idempotenceTest
+          , Test.Tasty.adjustOption (const $ QuickCheckTests 1) -- TODO Increase this!
+          . adjustQuickCheckMaxRatio 10000 -- This test discards many cases
+          )
         ]
 
+adjustQuickCheckMaxRatio :: Int -> TestTree -> TestTree
+adjustQuickCheckMaxRatio maxSize =
+    Test.Tasty.adjustOption (max $ Test.Tasty.QuickCheck.QuickCheckMaxRatio maxSize)
 
-
-testProperties' :: String -> [(String, Property, QuickCheckTests)] -> TestTree
-testProperties' name = Test.Tasty.testGroup name . map f
-  where
+adjustQuickCheckTests :: Int -> TestTree -> TestTree
+adjustQuickCheckTests nTests =
     -- Using adjustOption instead of withMaxSuccess allows us to override the number of tests
     -- with the --quickcheck-tests CLI option.
-    f (n, p, nTests) = Test.Tasty.adjustOption (max nTests) (Test.Tasty.QuickCheck.testProperty n p)
+    Test.Tasty.adjustOption (max $ QuickCheckTests nTests)
+
+testProperties' :: String -> [(String, Property, TestTree -> TestTree)] -> TestTree
+testProperties' name = Test.Tasty.testGroup name . map f
+  where
+    f (n, p, adjust) = adjust (Test.Tasty.QuickCheck.testProperty n p)