diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs index 86d2d98..5e94059 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs +++ b/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. diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs index aba9d95..0348f4c 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs +++ b/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 = diff --git a/dhall/src/Dhall/Format.hs b/dhall/src/Dhall/Format.hs index d654d43..8778cfa 100644 --- a/dhall/src/Dhall/Format.hs +++ b/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) diff --git a/dhall/src/Dhall/Freeze.hs b/dhall/src/Dhall/Freeze.hs index 05a70be..ce868f1 100644 --- a/dhall/src/Dhall/Freeze.hs +++ b/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 diff --git a/dhall/src/Dhall/Main.hs b/dhall/src/Dhall/Main.hs index b778ddd..50b174b 100644 --- a/dhall/src/Dhall/Main.hs +++ b/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 diff --git a/dhall/src/Dhall/Parser.hs b/dhall/src/Dhall/Parser.hs index 5c55ca3..ee16124 100644 --- a/dhall/src/Dhall/Parser.hs +++ b/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') diff --git a/dhall/src/Dhall/Pretty/Internal.hs b/dhall/src/Dhall/Pretty/Internal.hs index 2a44be0..f6fd5cb 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs +++ b/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 diff --git a/dhall/src/Dhall/Util.hs b/dhall/src/Dhall/Util.hs index 0a71640..3eea3bf 100644 --- a/dhall/src/Dhall/Util.hs +++ b/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 diff --git a/dhall/tests/Dhall/Test/Format.hs b/dhall/tests/Dhall/Test/Format.hs index 407aa16..1f073ba 100644 --- a/dhall/tests/Dhall/Test/Format.hs +++ b/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 = diff --git a/dhall/tests/Dhall/Test/QuickCheck.hs b/dhall/tests/Dhall/Test/QuickCheck.hs index 29321fc..2c045f5 100644 --- a/dhall/tests/Dhall/Test/QuickCheck.hs +++ b/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)