From 7d31506be4c0418f4d930187066b5acf21f41b9b Mon Sep 17 00:00:00 2001 From: Gabriel Gonzalez Date: Wed, 24 Apr 2019 13:01:46 -0700 Subject: [PATCH] Automatically discover tests (#897) This adds a new `Dhall.Test.Util.discover` utility for auto-generating a `TestTree` from a directory tree. This simplifies keeping up to date with changes to the standard test suite. --- dhall/dhall.cabal | 4 + dhall/src/Dhall.hs | 12 +- dhall/src/Dhall/Core.hs | 11 + dhall/src/Dhall/Format.hs | 12 +- dhall/src/Dhall/Import.hs | 12 +- dhall/src/Dhall/Main.hs | 26 +- dhall/tests/Dhall/Test/Format.hs | 145 ++--- dhall/tests/Dhall/Test/Import.hs | 135 ++--- dhall/tests/Dhall/Test/Lint.hs | 78 ++- dhall/tests/Dhall/Test/Main.hs | 53 +- dhall/tests/Dhall/Test/Normalization.hs | 668 ++++++------------------ dhall/tests/Dhall/Test/Parser.hs | 281 +++------- dhall/tests/Dhall/Test/TypeCheck.hs | 165 +++--- dhall/tests/Dhall/Test/Util.hs | 52 +- nix/shared.nix | 37 +- nix/turtle.nix | 21 + nix/turtle.patch | 12 + stack-lts-12.yaml | 1 + 18 files changed, 628 insertions(+), 1097 deletions(-) create mode 100644 nix/turtle.nix create mode 100644 nix/turtle.patch diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 3a64ff9..9432d29 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -102,6 +102,8 @@ Extra-Source-Files: dhall-lang/Prelude/Text/concatSep dhall-lang/Prelude/Text/package.dhall dhall-lang/Prelude/Text/show + dhall-lang/tests/import/data/*.txt + dhall-lang/tests/import/data/*.dhall dhall-lang/tests/import/data/fieldOrder/*.dhall dhall-lang/tests/import/failure/*.dhall dhall-lang/tests/import/success/*.dhall @@ -492,6 +494,7 @@ Test-Suite tasty dhall , directory , filepath , + foldl < 1.5 , prettyprinter , QuickCheck >= 2.10 && < 2.14, quickcheck-instances >= 0.3.12 && < 0.4 , @@ -501,6 +504,7 @@ Test-Suite tasty tasty-quickcheck >= 0.9.2 && < 0.11, text >= 0.11.1.0 && < 1.3 , transformers , + turtle < 1.6 , vector >= 0.11.0.0 && < 0.13 Default-Language: Haskell2010 diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index 77f4c93..2358b67 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -147,10 +147,6 @@ import qualified Dhall.Util -- $setup -- >>> :set -XOverloadedStrings -throws :: Exception e => Either e a -> IO a -throws (Left e) = Control.Exception.throwIO e -throws (Right r) = return r - {-| Every `Type` must obey the contract that if an expression's type matches the the `expected` type then the `extract` function must succeed. If not, then this exception is thrown @@ -336,7 +332,7 @@ inputWithSettings -> IO a -- ^ The decoded value in Haskell inputWithSettings settings (Type {..}) txt = do - expr <- throws (Dhall.Parser.exprFromText (view sourceName settings) txt) + expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) let InputSettings {..} = settings @@ -359,7 +355,7 @@ inputWithSettings settings (Type {..}) txt = do bytes' = bytes <> " : " <> suffix _ -> Annot expr' expected - _ <- throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) annot) let normExpr = Dhall.Core.normalizeWith (view normalizer settings) expr' case extract normExpr of @@ -432,7 +428,7 @@ inputExprWithSettings -> IO (Expr Src X) -- ^ The fully normalized AST inputExprWithSettings settings txt = do - expr <- throws (Dhall.Parser.exprFromText (view sourceName settings) txt) + expr <- Dhall.Core.throws (Dhall.Parser.exprFromText (view sourceName settings) txt) let InputSettings {..} = settings @@ -447,7 +443,7 @@ inputExprWithSettings settings txt = do expr' <- State.evalStateT (Dhall.Import.loadWith expr) status - _ <- throws (Dhall.TypeCheck.typeWith (view startingContext settings) expr') + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith (view startingContext settings) expr') pure (Dhall.Core.normalizeWith (view normalizer settings) expr') -- | Use this function to extract Haskell values directly from Dhall AST. diff --git a/dhall/src/Dhall/Core.hs b/dhall/src/Dhall/Core.hs index 91d614d..55e320a 100644 --- a/dhall/src/Dhall/Core.hs +++ b/dhall/src/Dhall/Core.hs @@ -57,6 +57,7 @@ module Dhall.Core ( , escapeText , subExpressions , pathCharacter + , throws ) where #if MIN_VERSION_base(4,8,0) @@ -64,6 +65,8 @@ module Dhall.Core ( import Control.Applicative (Applicative(..), (<$>)) #endif import Control.Applicative (empty) +import Control.Exception (Exception) +import Control.Monad.IO.Class (MonadIO(..)) import Crypto.Hash (SHA256) import Data.Bifunctor (Bifunctor(..)) import Data.Data (Data) @@ -84,6 +87,7 @@ import GHC.Generics (Generic) import Numeric.Natural (Natural) import Prelude hiding (succ) +import qualified Control.Exception import qualified Control.Monad import qualified Crypto.Hash import qualified Data.Char @@ -2106,3 +2110,10 @@ prettyPathComponent text "/" <> Pretty.pretty text | otherwise = "/\"" <> Pretty.pretty text <> "\"" + +{-| Convenience utility for converting `Either`-based exceptions to `IO`-based + exceptions +-} +throws :: (Exception e, MonadIO io) => Either e a -> io a +throws (Left e) = liftIO (Control.Exception.throwIO e) +throws (Right r) = return r diff --git a/dhall/src/Dhall/Format.hs b/dhall/src/Dhall/Format.hs index 4222dc3..e866567 100644 --- a/dhall/src/Dhall/Format.hs +++ b/dhall/src/Dhall/Format.hs @@ -12,7 +12,6 @@ module Dhall.Format ) where import Control.Exception (Exception) -import Control.Monad.IO.Class (MonadIO(..)) import Dhall.Parser (exprAndHeaderFromText) import Dhall.Pretty (CharacterSet(..), annToAnsiStyle, layoutOpts) @@ -23,6 +22,7 @@ import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Control.Exception import qualified Data.Text.IO +import qualified Dhall.Core import qualified Dhall.Pretty import qualified System.Console.ANSI import qualified System.IO @@ -64,7 +64,7 @@ format (Format {..}) = Just file -> do text <- Data.Text.IO.readFile file - (header, expr) <- throws (exprAndHeaderFromText "(stdin)" text) + (header, expr) <- Dhall.Core.throws (exprAndHeaderFromText "(stdin)" text) let doc = Pretty.pretty header <> Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr) @@ -74,7 +74,7 @@ format (Format {..}) = Nothing -> do inText <- Data.Text.IO.getContents - (header, expr) <- throws (exprAndHeaderFromText "(stdin)" inText) + (header, expr) <- Dhall.Core.throws (exprAndHeaderFromText "(stdin)" inText) let doc = Pretty.pretty header <> Dhall.Pretty.prettyCharacterSet characterSet expr @@ -96,7 +96,7 @@ format (Format {..}) = Just file -> Data.Text.IO.readFile file Nothing -> Data.Text.IO.getContents - (header, expr) <- throws (exprAndHeaderFromText "(stdin)" originalText) + (header, expr) <- Dhall.Core.throws (exprAndHeaderFromText "(stdin)" originalText) let doc = Pretty.pretty header <> Pretty.unAnnotate (Dhall.Pretty.prettyCharacterSet characterSet expr) @@ -108,7 +108,3 @@ format (Format {..}) = if originalText == formattedText then return () else Control.Exception.throwIO NotFormatted - -throws :: (Exception e, MonadIO io) => Either e a -> io a -throws (Left e) = liftIO (Control.Exception.throwIO e) -throws (Right a) = return a diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index aba8703..47fc01a 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -476,9 +476,9 @@ exprFromImport here@(Import {..}) = do let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict - term <- throws (Codec.Serialise.deserialiseOrFail bytesLazy) + term <- Dhall.Core.throws (Codec.Serialise.deserialiseOrFail bytesLazy) - throws (Dhall.Binary.decodeExpression term) + Dhall.Core.throws (Dhall.Binary.decodeExpression term) case result of Just expression -> return expression @@ -506,7 +506,7 @@ exprToImport here expression = do Just expectedHash <- return hash cacheFile <- getCacheFile expectedHash - _ <- throws (Dhall.TypeCheck.typeWith _startingContext expression) + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeWith _startingContext expression) let normalizedExpression = Dhall.Core.alphaNormalize @@ -955,8 +955,4 @@ instance Show ImportResolutionDisabled where -- | Assert than an expression is import-free assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src X) assertNoImports expression = - throws (traverse (\_ -> Left ImportResolutionDisabled) expression) - -throws :: (Exception e, MonadIO io) => Either e a -> io a -throws (Left e) = liftIO (Control.Exception.throwIO e) -throws (Right a) = return a + Dhall.Core.throws (traverse (\_ -> Left ImportResolutionDisabled) expression) diff --git a/dhall/src/Dhall/Main.hs b/dhall/src/Dhall/Main.hs index 43714ec..558d3f5 100644 --- a/dhall/src/Dhall/Main.hs +++ b/dhall/src/Dhall/Main.hs @@ -20,7 +20,7 @@ module Dhall.Main ) where import Control.Applicative (optional, (<|>)) -import Control.Exception (Exception, SomeException) +import Control.Exception (SomeException) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) @@ -251,15 +251,11 @@ parseMode = adapt True path = Dhall.Format.Check {..} adapt False inplace = Dhall.Format.Modify {..} -throws :: Exception e => Either e a -> IO a -throws (Left e) = Control.Exception.throwIO e -throws (Right a) = return a - getExpression :: IO (Expr Src Import) getExpression = do inText <- Data.Text.IO.getContents - throws (Dhall.Parser.exprFromText "(stdin)" inText) + Dhall.Core.throws (Dhall.Parser.exprFromText "(stdin)" inText) -- | `ParserInfo` for the `Options` type parserInfoOptions :: ParserInfo Options @@ -350,7 +346,7 @@ command (Options {..}) = do resolvedExpression <- State.evalStateT (Dhall.Import.loadWith expression) status - inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) + inferredType <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) let normalizedExpression = Dhall.Core.normalize resolvedExpression @@ -408,7 +404,7 @@ command (Options {..}) = do resolvedExpression <- Dhall.Import.assertNoImports expression - _ <- throws (Dhall.TypeCheck.typeOf resolvedExpression) + _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) let normalizedExpression = Dhall.Core.normalize resolvedExpression @@ -424,7 +420,7 @@ command (Options {..}) = do resolvedExpression <- Dhall.Import.assertNoImports expression - inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) + inferredType <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) render System.IO.stdout (Dhall.Core.normalize inferredType) @@ -454,7 +450,7 @@ command (Options {..}) = do Just file -> do text <- Data.Text.IO.readFile file - (header, expression) <- throws (Dhall.Parser.exprAndHeaderFromText file text) + (header, expression) <- Dhall.Core.throws (Dhall.Parser.exprAndHeaderFromText file text) let lintedExpression = Dhall.Lint.lint expression @@ -467,7 +463,7 @@ command (Options {..}) = do Nothing -> do text <- Data.Text.IO.getContents - (header, expression) <- throws (Dhall.Parser.exprAndHeaderFromText "(stdin)" text) + (header, expression) <- Dhall.Core.throws (Dhall.Parser.exprAndHeaderFromText "(stdin)" text) let lintedExpression = Dhall.Lint.lint expression @@ -487,7 +483,7 @@ command (Options {..}) = do then do let decoder = Codec.CBOR.JSON.decodeValue False - (_, value) <- throws (Codec.CBOR.Read.deserialiseFromBytes decoder bytes) + (_, value) <- Dhall.Core.throws (Codec.CBOR.Read.deserialiseFromBytes decoder bytes) let jsonBytes = Data.Aeson.Encode.Pretty.encodePretty value @@ -509,11 +505,11 @@ command (Options {..}) = do let encoding = Codec.CBOR.JSON.encodeValue value let cborBytes = Codec.CBOR.Write.toLazyByteString encoding - throws (Codec.Serialise.deserialiseOrFail cborBytes) + Dhall.Core.throws (Codec.Serialise.deserialiseOrFail cborBytes) else do - throws (Codec.Serialise.deserialiseOrFail bytes) + Dhall.Core.throws (Codec.Serialise.deserialiseOrFail bytes) - expression <- throws (Dhall.Binary.decodeExpression term) + expression <- Dhall.Core.throws (Dhall.Binary.decodeExpression term) let doc = Dhall.Pretty.prettyCharacterSet characterSet expression diff --git a/dhall/tests/Dhall/Test/Format.hs b/dhall/tests/Dhall/Test/Format.hs index 625fec6..ae2dca3 100644 --- a/dhall/tests/Dhall/Test/Format.hs +++ b/dhall/tests/Dhall/Test/Format.hs @@ -7,108 +7,59 @@ import Data.Text (Text) import Dhall.Pretty (CharacterSet(..)) import Test.Tasty (TestTree) -import qualified Control.Exception -import qualified Data.Text -import qualified Data.Text.IO -import qualified Data.Text.Prettyprint.Doc -import qualified Data.Text.Prettyprint.Doc.Render.Text -import qualified Dhall.Parser -import qualified Dhall.Pretty -import qualified Test.Tasty -import qualified Test.Tasty.HUnit +import qualified Control.Monad as Monad +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Prettyprint.Doc as Doc +import qualified Data.Text.Prettyprint.Doc.Render.Text as Doc.Render.Text +import qualified Dhall.Core as Core +import qualified Dhall.Parser as Parser +import qualified Dhall.Pretty as Pretty +import qualified Dhall.Test.Util as Test.Util +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle -tests :: TestTree -tests = - Test.Tasty.testGroup "format tests" - [ should - Unicode - "prefer multi-line strings when newlines present" - "multiline" - , should - Unicode - "escape ${ for single-quoted strings" - "escapeSingleQuotedOpenInterpolation" - , should - Unicode - "preserve the original order of fields" - "fieldOrder" - , should - Unicode - "preserve the original order of projections" - "projectionOrder" - , should - Unicode - "escape numeric labels correctly" - "escapeNumericLabel" - , should - Unicode - "correctly handle scientific notation with a large exponent" - "largeExponent" - , should - Unicode - "round a double to the nearest representable value. Ties go to even least significant bit" - "doubleRound" - , should - Unicode - "correctly format the empty record literal" - "emptyRecord" - , should - Unicode - "indent then/else to the same column" - "ifThenElse" - , should - Unicode - "handle indenting long imports correctly without trailing space per line" - "importLines" - , should - Unicode - "handle indenting small imports correctly without trailing space inline" - "importLines2" - , should - Unicode - "not remove parentheses when accessing a field of a record" - "importAccess" - , should - Unicode - "handle formatting sha256 imports correctly" - "sha256Printing" - , should - Unicode - "handle formatting of Import suffix correctly" - "importSuffix" - , should - ASCII - "be able to format with ASCII characters" - "ascii" - , should - Unicode - "preserve Unicode characters" - "unicode" - , should - Unicode - "not replace `../` with `./../`" - "parent" - ] +getTests :: IO TestTree +getTests = do + let unicodeFiles = do + path <- Turtle.lstree "./tests/format" -should :: CharacterSet -> Text -> Text -> TestTree -should characterSet name basename = - Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do - let inputFile = - Data.Text.unpack ("./tests/format/" <> basename <> "A.dhall") - let outputFile = - Data.Text.unpack ("./tests/format/" <> basename <> "B.dhall") - inputText <- Data.Text.IO.readFile inputFile + let skip = [ "./tests/format/asciiA.dhall" ] - expr <- case Dhall.Parser.exprFromText mempty inputText of - Left err -> Control.Exception.throwIO err - Right expr -> return expr + Monad.guard (path `notElem` skip) - let doc = Dhall.Pretty.prettyCharacterSet characterSet expr - let docStream = Data.Text.Prettyprint.Doc.layoutSmart Dhall.Pretty.layoutOpts doc - let actualText = Data.Text.Prettyprint.Doc.Render.Text.renderStrict docStream + return path - expectedText <- Data.Text.IO.readFile outputFile + unicodeTests <- Test.Util.discover (Turtle.chars <* "A.dhall") (formatTest Unicode) unicodeFiles + + asciiTests <- Test.Util.discover (Turtle.chars <* "A.dhall") (formatTest ASCII) (pure "./tests/format/asciiA.dhall") + + let testTree = + Tasty.testGroup "format tests" + [ unicodeTests + , asciiTests + ] + + return testTree + +formatTest :: CharacterSet -> Text -> TestTree +formatTest characterSet prefix = + Tasty.HUnit.testCase (Text.unpack prefix) $ do + let inputFile = Text.unpack (prefix <> "A.dhall") + let outputFile = Text.unpack (prefix <> "B.dhall") + + inputText <- Text.IO.readFile inputFile + + expr <- Core.throws (Parser.exprFromText mempty inputText) + + let doc = Pretty.prettyCharacterSet characterSet expr + let docStream = Doc.layoutSmart Pretty.layoutOpts doc + let actualText = Doc.Render.Text.renderStrict docStream + + expectedText <- Text.IO.readFile outputFile let message = "The formatted expression did not match the expected output" - Test.Tasty.HUnit.assertEqual message expectedText actualText + + Tasty.HUnit.assertEqual message expectedText actualText diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 8059d48..01cd265 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -2,92 +2,71 @@ module Dhall.Test.Import where +import Control.Exception (catch) +import Data.Monoid ((<>)) import Data.Text (Text) -import Test.Tasty (TestTree) import Dhall.Import (MissingImports(..)) import Dhall.Parser (SourcedException(..)) -import Control.Exception (catch, throwIO) -import Data.Monoid ((<>)) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, ()) import qualified Control.Monad.Trans.State.Strict as State -import qualified Data.Text -import qualified Data.Text.IO -import qualified Dhall.Parser -import qualified Dhall.Import -import qualified Test.Tasty -import qualified Test.Tasty.HUnit +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core +import qualified Dhall.Import as Import +import qualified Dhall.Parser as Parser +import qualified Dhall.Test.Util as Test.Util +import qualified System.FilePath as FilePath +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle -tests :: TestTree -tests = - Test.Tasty.testGroup "import tests" - [ Test.Tasty.testGroup "import alternatives" - [ shouldFail - 3 - "alternative of several unset env variables" - "./dhall-lang/tests/import/failure/alternativeEnv.dhall" - , shouldFail - 1 - "alternative of env variable and missing" - "./dhall-lang/tests/import/failure/alternativeEnvMissing.dhall" - , shouldFail - 0 - "just missing" - "./dhall-lang/tests/import/failure/missing.dhall" - , shouldNotFail - "alternative of env variable, missing, and a Natural" - "./dhall-lang/tests/import/success/alternativeEnvNaturalA.dhall" - , shouldNotFail - "alternative of env variable and a Natural" - "./dhall-lang/tests/import/success/alternativeEnvSimpleA.dhall" - , shouldNotFail - "alternative of a Natural and missing" - "./dhall-lang/tests/import/success/alternativeNaturalA.dhall" - ] - , Test.Tasty.testGroup "import relative to argument" - [ shouldNotFailRelative - "a semantic integrity check if fields are reordered" - "./dhall-lang/tests/import/success/" - "./dhall-lang/tests/import/success/fieldOrderA.dhall" - ] - ] +importDirectory :: FilePath +importDirectory = "./dhall-lang/tests/import" -shouldNotFail :: Text -> FilePath -> TestTree -shouldNotFail name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do - text <- Data.Text.IO.readFile path - actualExpr <- case Dhall.Parser.exprFromText mempty text of - Left err -> throwIO err - Right expr -> return expr - _ <- Dhall.Import.load actualExpr - return ()) +getTests :: IO TestTree +getTests = do + successTests <- Test.Util.discover (Turtle.chars <> "A.dhall") successTest (Turtle.lstree (importDirectory "success")) -shouldNotFailRelative :: Text -> FilePath -> FilePath -> TestTree -shouldNotFailRelative name dir path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do - text <- Data.Text.IO.readFile path - expr <- case Dhall.Parser.exprFromText mempty text of - Left err -> throwIO err - Right expr -> return expr + failureTests <- Test.Util.discover (Turtle.chars <> ".dhall") failureTest (Turtle.lstree (importDirectory "failure")) - _ <- State.evalStateT (Dhall.Import.loadWith expr) (Dhall.Import.emptyStatus dir) + let testTree = + Tasty.testGroup "import tests" + [ successTests + , failureTests + ] - return ()) + return testTree -shouldFail :: Int -> Text -> FilePath -> TestTree -shouldFail failures name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do - text <- Data.Text.IO.readFile path - actualExpr <- case Dhall.Parser.exprFromText mempty text of - Left err -> throwIO err - Right expr -> return expr - catch - (do - _ <- Dhall.Import.load actualExpr - fail "Import should have failed, but it succeeds") - (\(SourcedException _ (MissingImports es)) -> - case length es == failures of - True -> pure () - False -> fail - ( "Should have failed " - <> show failures - <> " times, but failed with: \n" - <> show es - ) - ) ) +successTest :: Text -> TestTree +successTest path = do + let pathString = Text.unpack path + + let directoryString = FilePath.takeDirectory pathString + + Tasty.HUnit.testCase pathString (do + + text <- Text.IO.readFile pathString + + actualExpr <- Core.throws (Parser.exprFromText mempty text) + + _ <- State.evalStateT (Import.loadWith actualExpr) (Import.emptyStatus directoryString) + + return () ) + +failureTest :: Text -> TestTree +failureTest path = do + let pathString = Text.unpack path + + Tasty.HUnit.testCase pathString (do + text <- Text.IO.readFile pathString + + actualExpr <- Core.throws (Parser.exprFromText mempty text) + + catch + (do _ <- Import.load actualExpr + + fail "Import should have failed, but it succeeds") + (\(SourcedException _ (MissingImports _)) -> pure ()) ) diff --git a/dhall/tests/Dhall/Test/Lint.hs b/dhall/tests/Dhall/Test/Lint.hs index e0b5841..acc2600 100644 --- a/dhall/tests/Dhall/Test/Lint.hs +++ b/dhall/tests/Dhall/Test/Lint.hs @@ -4,58 +4,54 @@ module Dhall.Test.Lint where import Data.Monoid (mempty, (<>)) import Data.Text (Text) +import Prelude hiding (FilePath) import Test.Tasty (TestTree) +import Turtle (FilePath) -import qualified Control.Exception -import qualified Data.Text -import qualified Data.Text.IO -import qualified Dhall.Core -import qualified Dhall.Import -import qualified Dhall.Lint -import qualified Dhall.Parser -import qualified Test.Tasty -import qualified Test.Tasty.HUnit +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core +import qualified Dhall.Import as Import +import qualified Dhall.Lint as Lint +import qualified Dhall.Parser as Parser +import qualified Dhall.Test.Util as Test.Util +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle -tests :: TestTree -tests = - Test.Tasty.testGroup "format tests" - [ should - "correctly handle multi-let expressions" - "success/multilet" - , should - "not fail when an inner expression removes all `let` bindings" - "success/regression0" - ] +lintDirectory :: FilePath +lintDirectory = "./tests/lint" -should :: Text -> Text -> TestTree -should name basename = - Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do - let inputFile = - Data.Text.unpack ("./tests/lint/" <> basename <> "A.dhall") - let outputFile = - Data.Text.unpack ("./tests/lint/" <> basename <> "B.dhall") +getTests :: IO TestTree +getTests = do + formatTests <- Test.Util.discover (Turtle.chars <* "A.dhall") lintTest (Turtle.lstree lintDirectory) - inputText <- Data.Text.IO.readFile inputFile + let testTree = Tasty.testGroup "format tests" [ formatTests ] - parsedInput <- case Dhall.Parser.exprFromText mempty inputText of - Left exception -> Control.Exception.throwIO exception - Right expression -> return expression + return testTree - let lintedInput = Dhall.Lint.lint parsedInput +lintTest :: Text -> TestTree +lintTest prefix = + Tasty.HUnit.testCase (Text.unpack prefix) $ do + let inputFile = Text.unpack (prefix <> "A.dhall") + let outputFile = Text.unpack (prefix <> "B.dhall") - actualExpression <- Dhall.Import.load lintedInput + inputText <- Text.IO.readFile inputFile - outputText <- Data.Text.IO.readFile outputFile + parsedInput <- Core.throws (Parser.exprFromText mempty inputText) - parsedOutput <- case Dhall.Parser.exprFromText mempty outputText of - Left exception -> Control.Exception.throwIO exception - Right expression -> return expression + let lintedInput = Lint.lint parsedInput - resolvedOutput <- Dhall.Import.load parsedOutput + actualExpression <- Import.load lintedInput - let expectedExpression = Dhall.Core.denote resolvedOutput + outputText <- Text.IO.readFile outputFile - let message = - "The linted expression did not match the expected output" + parsedOutput <- Core.throws (Parser.exprFromText mempty outputText) - Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression + resolvedOutput <- Import.load parsedOutput + + let expectedExpression = Core.denote resolvedOutput + + let message = "The linted expression did not match the expected output" + + Tasty.HUnit.assertEqual message expectedExpression actualExpression diff --git a/dhall/tests/Dhall/Test/Main.hs b/dhall/tests/Dhall/Test/Main.hs index 2465357..b4641f3 100644 --- a/dhall/tests/Dhall/Test/Main.hs +++ b/dhall/tests/Dhall/Test/Main.hs @@ -1,6 +1,7 @@ module Main where -import Test.Tasty (TestTree) +import System.FilePath (()) +import Test.Tasty (TestTree) import qualified Dhall.Test.Dhall import qualified Dhall.Test.Format @@ -18,28 +19,44 @@ import qualified System.Environment import qualified System.IO import qualified Test.Tasty -import System.FilePath (()) +getAllTests :: IO TestTree +getAllTests = do + normalizationTests <- Dhall.Test.Normalization.getTests -allTests :: TestTree -allTests = - Test.Tasty.testGroup "Dhall Tests" - [ - Dhall.Test.Normalization.tests - , Dhall.Test.Parser.tests - , Dhall.Test.Regression.tests - , Dhall.Test.Tutorial.tests - , Dhall.Test.Format.tests - , Dhall.Test.TypeCheck.tests - , Dhall.Test.Import.tests - , Dhall.Test.QuickCheck.tests - , Dhall.Test.Lint.tests - , Dhall.Test.Dhall.tests - ] + parsingTests <- Dhall.Test.Parser.getTests + + formattingTests <- Dhall.Test.Format.getTests + + typecheckingTests <- Dhall.Test.TypeCheck.getTests + + importingTests <- Dhall.Test.Import.getTests + + lintTests <- Dhall.Test.Lint.getTests + + let testTree = + Test.Tasty.testGroup "Dhall Tests" + [ normalizationTests + , parsingTests + , importingTests + , typecheckingTests + , formattingTests + , lintTests + , Dhall.Test.Regression.tests + , Dhall.Test.Tutorial.tests + , Dhall.Test.QuickCheck.tests + , Dhall.Test.Dhall.tests + ] + + return testTree main :: IO () main = do - GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 + pwd <- System.Directory.getCurrentDirectory + System.Environment.setEnv "XDG_CACHE_HOME" (pwd ".cache") + + allTests <- getAllTests + Test.Tasty.defaultMain allTests diff --git a/dhall/tests/Dhall/Test/Normalization.hs b/dhall/tests/Dhall/Test/Normalization.hs index b14ce88..953ae6e 100644 --- a/dhall/tests/Dhall/Test/Normalization.hs +++ b/dhall/tests/Dhall/Test/Normalization.hs @@ -1,536 +1,210 @@ -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Dhall.Test.Normalization where import Data.Monoid ((<>)) import Data.Text (Text) -import Dhall.Core (Expr) +import Dhall.Core (Expr(..), Var(..), throws) import Dhall.TypeCheck (X) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, ()) -import qualified Control.Exception -import qualified Data.Text -import qualified Data.Text.IO -import qualified Dhall.Core -import qualified Dhall.Import -import qualified Dhall.Parser -import qualified Dhall.TypeCheck +import qualified Control.Monad as Monad +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Context as Context +import qualified Dhall.Core as Core +import qualified Dhall.Import as Import +import qualified Dhall.Parser as Parser +import qualified Dhall.Test.Util as Test.Util +import qualified Dhall.TypeCheck as TypeCheck +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle -import Dhall.Core -import Dhall.Context -import Test.Tasty -import Test.Tasty.HUnit -import Dhall.Test.Util +normalizationDirectory :: FilePath +normalizationDirectory = "./dhall-lang/tests/normalization/success" -tests :: TestTree -tests = - testGroup "normalization" - [ tutorialExamples - , preludeExamples - , unitTests - , alphaNormalizationTests - , simplifications - , constantFolding - , conversions - , customization - , shouldNormalize - "Optional build/fold fusion" - "success/simple/optionalBuildFold" - , shouldNormalize - "a remote-systems.conf builder" - "success/remoteSystems" - , shouldNormalize - "multi-line strings correctly" - "success/simple/multiLine" - , shouldNormalize - "the // operator and sort the fields" - "success/simple/sortOperator" - , shouldNormalize - "enums" - "success/simple/enum" - ] +getTests :: IO TestTree +getTests = do + let pattern = Turtle.chars <* "A.dhall" -tutorialExamples :: TestTree -tutorialExamples = - testGroup "Tutorial examples" - [ shouldNormalize "⩓" "./success/haskell-tutorial/combineTypes/0" - , shouldNormalize "//\\\\" "./success/haskell-tutorial/combineTypes/1" - , shouldNormalize "//" "./success/haskell-tutorial/prefer/0" - , shouldNormalize "projection" "./success/haskell-tutorial/projection/0" - , shouldNormalize "access record" "./success/haskell-tutorial/access/0" - , shouldNormalize "access union" "./success/haskell-tutorial/access/1" - ] + let normalizationFiles = do + path <- Turtle.lstree normalizationDirectory -preludeExamples :: TestTree -preludeExamples = - testGroup "Prelude examples" - [ shouldNormalize "Bool/and" "./success/prelude/Bool/and/0" - , shouldNormalize "Bool/and" "./success/prelude/Bool/and/1" - , shouldNormalize "Bool/build" "./success/prelude/Bool/build/0" - , shouldNormalize "Bool/build" "./success/prelude/Bool/build/1" - , shouldNormalize "Bool/even" "./success/prelude/Bool/even/0" - , shouldNormalize "Bool/even" "./success/prelude/Bool/even/1" - , shouldNormalize "Bool/even" "./success/prelude/Bool/even/2" - , shouldNormalize "Bool/even" "./success/prelude/Bool/even/3" - , shouldNormalize "Bool/fold" "./success/prelude/Bool/fold/0" - , shouldNormalize "Bool/fold" "./success/prelude/Bool/fold/1" - , shouldNormalize "Bool/not" "./success/prelude/Bool/not/0" - , shouldNormalize "Bool/not" "./success/prelude/Bool/not/1" - , shouldNormalize "Bool/odd" "./success/prelude/Bool/odd/0" - , shouldNormalize "Bool/odd" "./success/prelude/Bool/odd/1" - , shouldNormalize "Bool/odd" "./success/prelude/Bool/odd/2" - , shouldNormalize "Bool/odd" "./success/prelude/Bool/odd/3" - , shouldNormalize "Bool/or" "./success/prelude/Bool/or/0" - , shouldNormalize "Bool/or" "./success/prelude/Bool/or/1" - , shouldNormalize "Bool/show" "./success/prelude/Bool/show/0" - , shouldNormalize "Bool/show" "./success/prelude/Bool/show/1" - , shouldNormalize "Double/show" "./success/prelude/Double/show/0" - , shouldNormalize "Double/show" "./success/prelude/Double/show/1" - , shouldNormalize "Integer/show" "./success/prelude/Integer/show/0" - , shouldNormalize "Integer/show" "./success/prelude/Integer/show/1" - , shouldNormalize "Integer/toDouble" "./success/prelude/Integer/toDouble/0" - , shouldNormalize "Integer/toDouble" "./success/prelude/Integer/toDouble/1" - , shouldNormalize "List/all" "./success/prelude/List/all/0" - , shouldNormalize "List/all" "./success/prelude/List/all/1" - , shouldNormalize "List/any" "./success/prelude/List/any/0" - , shouldNormalize "List/any" "./success/prelude/List/any/1" - , shouldNormalize "List/build" "./success/prelude/List/build/0" - , shouldNormalize "List/build" "./success/prelude/List/build/1" - , shouldNormalize "List/concat" "./success/prelude/List/concat/0" - , shouldNormalize "List/concat" "./success/prelude/List/concat/1" - , shouldNormalize "List/concatMap" "./success/prelude/List/concatMap/0" - , shouldNormalize "List/concatMap" "./success/prelude/List/concatMap/1" - , shouldNormalize "List/filter" "./success/prelude/List/filter/0" - , shouldNormalize "List/filter" "./success/prelude/List/filter/1" - , shouldNormalize "List/fold" "./success/prelude/List/fold/0" - , shouldNormalize "List/fold" "./success/prelude/List/fold/1" - , shouldNormalize "List/fold" "./success/prelude/List/fold/2" - , shouldNormalize "List/generate" "./success/prelude/List/generate/0" - , shouldNormalize "List/generate" "./success/prelude/List/generate/1" - , shouldNormalize "List/head" "./success/prelude/List/head/0" - , shouldNormalize "List/head" "./success/prelude/List/head/1" - , shouldNormalize "List/indexed" "./success/prelude/List/indexed/0" - , shouldNormalize "List/indexed" "./success/prelude/List/indexed/1" - , shouldNormalize "List/iterate" "./success/prelude/List/iterate/0" - , shouldNormalize "List/iterate" "./success/prelude/List/iterate/1" - , shouldNormalize "List/last" "./success/prelude/List/last/0" - , shouldNormalize "List/last" "./success/prelude/List/last/1" - , shouldNormalize "List/length" "./success/prelude/List/length/0" - , shouldNormalize "List/length" "./success/prelude/List/length/1" - , shouldNormalize "List/map" "./success/prelude/List/map/0" - , shouldNormalize "List/map" "./success/prelude/List/map/1" - , shouldNormalize "List/null" "./success/prelude/List/null/0" - , shouldNormalize "List/null" "./success/prelude/List/null/1" - , shouldNormalize "List/replicate" "./success/prelude/List/replicate/0" - , shouldNormalize "List/replicate" "./success/prelude/List/replicate/1" - , shouldNormalize "List/reverse" "./success/prelude/List/reverse/0" - , shouldNormalize "List/reverse" "./success/prelude/List/reverse/1" - , shouldNormalize "List/shifted" "./success/prelude/List/shifted/0" - , shouldNormalize "List/shifted" "./success/prelude/List/shifted/1" - , shouldNormalize "List/unzip" "./success/prelude/List/unzip/0" - , shouldNormalize "List/unzip" "./success/prelude/List/unzip/1" - , shouldNormalize "Natural/build" "./success/prelude/Natural/build/0" - , shouldNormalize "Natural/build" "./success/prelude/Natural/build/1" - , shouldNormalize "Natural/enumerate" "./success/prelude/Natural/enumerate/0" - , shouldNormalize "Natural/enumerate" "./success/prelude/Natural/enumerate/1" - , shouldNormalize "Natural/even" "./success/prelude/Natural/even/0" - , shouldNormalize "Natural/even" "./success/prelude/Natural/even/1" - , shouldNormalize "Natural/fold" "./success/prelude/Natural/fold/0" - , shouldNormalize "Natural/fold" "./success/prelude/Natural/fold/1" - , shouldNormalize "Natural/fold" "./success/prelude/Natural/fold/2" - , shouldNormalize "Natural/isZero" "./success/prelude/Natural/isZero/0" - , shouldNormalize "Natural/isZero" "./success/prelude/Natural/isZero/1" - , shouldNormalize "Natural/odd" "./success/prelude/Natural/odd/0" - , shouldNormalize "Natural/odd" "./success/prelude/Natural/odd/1" - , shouldNormalize "Natural/product" "./success/prelude/Natural/product/0" - , shouldNormalize "Natural/product" "./success/prelude/Natural/product/1" - , shouldNormalize "Natural/show" "./success/prelude/Natural/show/0" - , shouldNormalize "Natural/show" "./success/prelude/Natural/show/1" - , shouldNormalize "Natural/sum" "./success/prelude/Natural/sum/0" - , shouldNormalize "Natural/sum" "./success/prelude/Natural/sum/1" - , shouldNormalize "Natural/toDouble" "./success/prelude/Natural/toDouble/0" - , shouldNormalize "Natural/toDouble" "./success/prelude/Natural/toDouble/1" - , shouldNormalize "Natural/toInteger" "./success/prelude/Natural/toInteger/0" - , shouldNormalize "Natural/toInteger" "./success/prelude/Natural/toInteger/1" - , shouldNormalize "Optional/all" "./success/prelude/Optional/all/0" - , shouldNormalize "Optional/all" "./success/prelude/Optional/all/1" - , shouldNormalize "Optional/any" "./success/prelude/Optional/any/0" - , shouldNormalize "Optional/any" "./success/prelude/Optional/any/1" - , shouldNormalize "Optional/build" "./success/prelude/Optional/build/0" - , shouldNormalize "Optional/build" "./success/prelude/Optional/build/1" - , shouldNormalize "Optional/concat" "./success/prelude/Optional/concat/0" - , shouldNormalize "Optional/concat" "./success/prelude/Optional/concat/1" - , shouldNormalize "Optional/concat" "./success/prelude/Optional/concat/2" - , shouldNormalize "Optional/filter" "./success/prelude/Optional/filter/0" - , shouldNormalize "Optional/filter" "./success/prelude/Optional/filter/1" - , shouldNormalize "Optional/fold" "./success/prelude/Optional/fold/0" - , shouldNormalize "Optional/fold" "./success/prelude/Optional/fold/1" - , shouldNormalize "Optional/head" "./success/prelude/Optional/head/0" - , shouldNormalize "Optional/head" "./success/prelude/Optional/head/1" - , shouldNormalize "Optional/head" "./success/prelude/Optional/head/2" - , shouldNormalize "Optional/last" "./success/prelude/Optional/last/0" - , shouldNormalize "Optional/last" "./success/prelude/Optional/last/1" - , shouldNormalize "Optional/last" "./success/prelude/Optional/last/2" - , shouldNormalize "Optional/length" "./success/prelude/Optional/length/0" - , shouldNormalize "Optional/length" "./success/prelude/Optional/length/1" - , shouldNormalize "Optional/map" "./success/prelude/Optional/map/0" - , shouldNormalize "Optional/map" "./success/prelude/Optional/map/1" - , shouldNormalize "Optional/null" "./success/prelude/Optional/null/0" - , shouldNormalize "Optional/null" "./success/prelude/Optional/null/1" - , shouldNormalize "Optional/toList" "./success/prelude/Optional/toList/0" - , shouldNormalize "Optional/toList" "./success/prelude/Optional/toList/1" - , shouldNormalize "Optional/unzip" "./success/prelude/Optional/unzip/0" - , shouldNormalize "Optional/unzip" "./success/prelude/Optional/unzip/1" - , shouldNormalize "Text/concat" "./success/prelude/Text/concat/0" - , shouldNormalize "Text/concat" "./success/prelude/Text/concat/1" - , shouldNormalize "Text/concatMap" "./success/prelude/Text/concatMap/0" - , shouldNormalize "Text/concatMap" "./success/prelude/Text/concatMap/1" - , shouldNormalize "Text/concatMapSep" "./success/prelude/Text/concatMapSep/0" - , shouldNormalize "Text/concatMapSep" "./success/prelude/Text/concatMapSep/1" - , shouldNormalize "Text/concatSep" "./success/prelude/Text/concatSep/0" - , shouldNormalize "Text/concatSep" "./success/prelude/Text/concatSep/1" - , shouldNormalize "Text/show" "./success/prelude/Text/show/0" - , shouldNormalize "Text/show" "./success/prelude/Text/show/1" - ] + Nothing <- return (Turtle.stripPrefix (normalizationDirectory "unit/") path) -unitTests :: TestTree -unitTests = - testGroup "Unit tests" - [ shouldOnlyNormalize "Bool" - , shouldOnlyNormalize "Double" - , shouldOnlyNormalize "DoubleLiteral" - , shouldOnlyNormalize "DoubleShow" - , shouldOnlyNormalize "DoubleShowValue" - , shouldOnlyNormalize "FunctionApplicationCapture" - , shouldOnlyNormalize "FunctionApplicationNoSubstitute" - , shouldOnlyNormalize "FunctionApplicationNormalizeArguments" - , shouldOnlyNormalize "FunctionApplicationSubstitute" - , shouldOnlyNormalize "FunctionNormalizeArguments" - , shouldOnlyNormalize "FunctionTypeNormalizeArguments" - , shouldOnlyNormalize "IfAlternativesIdentical" - , shouldOnlyNormalize "IfFalse" - , shouldOnlyNormalize "IfNormalizePredicateAndBranches" - , shouldOnlyNormalize "IfTrivial" - , shouldOnlyNormalize "IfTrue" - , shouldOnlyNormalize "Integer" - , shouldOnlyNormalize "IntegerNegative" - , shouldOnlyNormalize "IntegerPositive" - , shouldOnlyNormalize "IntegerShow" - , shouldOnlyNormalize "IntegerShow-12" - , shouldOnlyNormalize "IntegerShow12" - , shouldOnlyNormalize "IntegerToDouble" - , shouldOnlyNormalize "IntegerToDouble-12" - , shouldOnlyNormalize "IntegerToDouble12" - , shouldOnlyNormalize "Kind" - , shouldOnlyNormalize "Let" - , shouldOnlyNormalize "LetWithType" - , shouldOnlyNormalize "List" - , shouldOnlyNormalize "ListBuild" - , shouldOnlyNormalize "ListBuildFoldFusion" - , shouldOnlyNormalize "ListBuildImplementation" - , shouldOnlyNormalize "ListFold" - , shouldOnlyNormalize "ListFoldEmpty" - , shouldOnlyNormalize "ListFoldOne" - , shouldOnlyNormalize "ListHead" - , shouldOnlyNormalize "ListHeadEmpty" - , shouldOnlyNormalize "ListHeadOne" - , shouldOnlyNormalize "ListIndexed" - , shouldOnlyNormalize "ListIndexedEmpty" - , shouldOnlyNormalize "ListIndexedOne" - , shouldOnlyNormalize "ListLast" - , shouldOnlyNormalize "ListLastEmpty" - , shouldOnlyNormalize "ListLastOne" - , shouldOnlyNormalize "ListLength" - , shouldOnlyNormalize "ListLengthEmpty" - , shouldOnlyNormalize "ListLengthOne" - , shouldOnlyNormalize "ListNormalizeElements" - , shouldOnlyNormalize "ListNormalizeTypeAnnotation" - , shouldOnlyNormalize "ListReverse" - , shouldOnlyNormalize "ListReverseEmpty" - , shouldOnlyNormalize "ListReverseTwo" - , shouldOnlyNormalize "Merge" - , shouldOnlyNormalize "MergeEmptyAlternative" - , shouldOnlyNormalize "MergeNormalizeArguments" - , shouldOnlyNormalize "MergeWithType" - , shouldOnlyNormalize "MergeWithTypeNormalizeArguments" - , shouldOnlyNormalize "Natural" - , shouldOnlyNormalize "NaturalBuild" - , shouldOnlyNormalize "NaturalBuildFoldFusion" - , shouldOnlyNormalize "NaturalBuildImplementation" - , shouldOnlyNormalize "NaturalEven" - , shouldOnlyNormalize "NaturalEvenOne" - , shouldOnlyNormalize "NaturalEvenZero" - , shouldOnlyNormalize "NaturalFold" - , shouldOnlyNormalize "NaturalFoldOne" - , shouldOnlyNormalize "NaturalFoldZero" - , shouldOnlyNormalize "NaturalIsZero" - , shouldOnlyNormalize "NaturalIsZeroOne" - , shouldOnlyNormalize "NaturalIsZeroZero" - , shouldOnlyNormalize "NaturalLiteral" - , shouldOnlyNormalize "NaturalOdd" - , shouldOnlyNormalize "NaturalOddOne" - , shouldOnlyNormalize "NaturalOddZero" - , shouldOnlyNormalize "NaturalShow" - , shouldOnlyNormalize "NaturalShowOne" - , shouldOnlyNormalize "NaturalToInteger" - , shouldOnlyNormalize "NaturalToIntegerOne" - , shouldOnlyNormalize "None" - , shouldOnlyNormalize "NoneNatural" - , shouldOnlyNormalize "OperatorAndEquivalentArguments" - , shouldOnlyNormalize "OperatorAndLhsFalse" - , shouldOnlyNormalize "OperatorAndLhsTrue" - , shouldOnlyNormalize "OperatorAndNormalizeArguments" - , shouldOnlyNormalize "OperatorAndRhsFalse" - , shouldOnlyNormalize "OperatorAndRhsTrue" - , shouldOnlyNormalize "OperatorEqualEquivalentArguments" - , shouldOnlyNormalize "OperatorEqualLhsTrue" - , shouldOnlyNormalize "OperatorEqualNormalizeArguments" - , shouldOnlyNormalize "OperatorEqualRhsTrue" - , shouldOnlyNormalize "OperatorListConcatenateLhsEmpty" - , shouldOnlyNormalize "OperatorListConcatenateListList" - , shouldOnlyNormalize "OperatorListConcatenateNormalizeArguments" - , shouldOnlyNormalize "OperatorListConcatenateRhsEmpty" - , shouldOnlyNormalize "OperatorNotEqualEquivalentArguments" - , shouldOnlyNormalize "OperatorNotEqualLhsFalse" - , shouldOnlyNormalize "OperatorNotEqualNormalizeArguments" - , shouldOnlyNormalize "OperatorNotEqualRhsFalse" - , shouldOnlyNormalize "OperatorOrEquivalentArguments" - , shouldOnlyNormalize "OperatorOrLhsFalse" - , shouldOnlyNormalize "OperatorOrLhsTrue" - , shouldOnlyNormalize "OperatorOrNormalizeArguments" - , shouldOnlyNormalize "OperatorOrRhsFalse" - , shouldOnlyNormalize "OperatorOrRhsTrue" - , shouldOnlyNormalize "OperatorPlusLhsZero" - , shouldOnlyNormalize "OperatorPlusNormalizeArguments" - , shouldOnlyNormalize "OperatorPlusOneAndOne" - , shouldOnlyNormalize "OperatorPlusRhsZero" - , shouldOnlyNormalize "OperatorTextConcatenateLhsEmpty" - , shouldOnlyNormalize "OperatorTextConcatenateNormalizeArguments" - , shouldOnlyNormalize "OperatorTextConcatenateRhsEmpty" - , shouldOnlyNormalize "OperatorTextConcatenateTextText" - , shouldOnlyNormalize "OperatorTimesLhsOne" - , shouldOnlyNormalize "OperatorTimesLhsZero" - , shouldOnlyNormalize "OperatorTimesNormalizeArguments" - , shouldOnlyNormalize "OperatorTimesRhsOne" - , shouldOnlyNormalize "OperatorTimesRhsZero" - , shouldOnlyNormalize "OperatorTimesTwoAndTwo" - , shouldOnlyNormalize "Optional" - , shouldOnlyNormalize "OptionalBuild" - , shouldOnlyNormalize "OptionalBuildFoldFusion" - , shouldOnlyNormalize "OptionalBuildImplementation" - , shouldOnlyNormalize "OptionalFold" - , shouldOnlyNormalize "OptionalFoldNone" - , shouldOnlyNormalize "OptionalFoldSome" - , shouldOnlyNormalize "Record" - , shouldOnlyNormalize "RecordEmpty" - , shouldOnlyNormalize "RecordProjection" - , shouldOnlyNormalize "RecordProjectionEmpty" - , shouldOnlyNormalize "RecordProjectionNormalizeArguments" - , shouldOnlyNormalize "RecordSelection" - , shouldOnlyNormalize "RecordSelectionNormalizeArguments" - , shouldOnlyNormalize "RecordType" - , shouldOnlyNormalize "RecordTypeEmpty" - , shouldOnlyNormalize "RecursiveRecordMergeCollision" - , shouldOnlyNormalize "RecursiveRecordMergeLhsEmpty" - , shouldOnlyNormalize "RecursiveRecordMergeNoCollision" - , shouldOnlyNormalize "RecursiveRecordMergeNormalizeArguments" - , shouldOnlyNormalize "RecursiveRecordMergeRhsEmpty" - , shouldOnlyNormalize "RecursiveRecordTypeMergeCollision" - , shouldOnlyNormalize "RecursiveRecordTypeMergeLhsEmpty" - , shouldOnlyNormalize "RecursiveRecordTypeMergeNoCollision" - , shouldOnlyNormalize "RecursiveRecordTypeMergeNormalizeArguments" - , shouldOnlyNormalize "RecursiveRecordTypeMergeRhsEmpty" - , shouldOnlyNormalize "RightBiasedRecordMergeCollision" - , shouldOnlyNormalize "RightBiasedRecordMergeLhsEmpty" - , shouldOnlyNormalize "RightBiasedRecordMergeNoCollision" - , shouldOnlyNormalize "RightBiasedRecordMergeNormalizeArguments" - , shouldOnlyNormalize "RightBiasedRecordMergeRhsEmpty" - , shouldOnlyNormalize "SomeNormalizeArguments" - , shouldOnlyNormalize "Sort" - , shouldOnlyNormalize "Text" - , shouldOnlyNormalize "TextInterpolate" - , shouldOnlyNormalize "TextLiteral" - , shouldOnlyNormalize "TextNormalizeInterpolations" - , shouldOnlyNormalize "TextShow" - , shouldOnlyNormalize "TextShowAllEscapes" - , shouldOnlyNormalize "True" - , shouldOnlyNormalize "Type" - , shouldOnlyNormalize "TypeAnnotation" - , shouldOnlyNormalize "UnionNormalizeAlternatives" - , shouldOnlyNormalize "UnionNormalizeArguments" - , shouldOnlyNormalize "UnionProjectConstructor" - , shouldOnlyNormalize "UnionProjectConstructorNormalizeArguments" - , shouldOnlyNormalize "UnionSortAlternatives" - , shouldOnlyNormalize "UnionType" - , shouldOnlyNormalize "UnionTypeEmpty" - , shouldOnlyNormalize "UnionTypeNormalizeArguments" - , shouldOnlyNormalize "Variable" - ] + return path -alphaNormalizationTests :: TestTree -alphaNormalizationTests = - testGroup "α-normalization tests" - [ shouldOnlyAlphaNormalize "FunctionBindingX" - , shouldOnlyAlphaNormalize "FunctionTypeBindingX" - , shouldOnlyAlphaNormalize "FunctionTypeNestedBindingX" - , shouldOnlyAlphaNormalize "FunctionNestedBindingX" - , shouldOnlyAlphaNormalize "FunctionTypeBindingUnderscore" - , shouldOnlyAlphaNormalize "FunctionBindingUnderscore" - ] + betaNormalizationTests <- Test.Util.discover pattern betaNormalizationTest normalizationFiles -simplifications :: TestTree -simplifications = - testGroup "Simplifications" - [ shouldNormalize "if/then/else" "./success/simplifications/ifThenElse" - , shouldNormalize "||" "./success/simplifications/or" - , shouldNormalize "&&" "./success/simplifications/and" - , shouldNormalize "==" "./success/simplifications/eq" - , shouldNormalize "!=" "./success/simplifications/ne" - ] + alphaNormalizationTests <- do + Test.Util.discover pattern alphaNormalizationTest + (Turtle.lstree "./dhall-lang/tests/α-normalization/success/") -constantFolding :: TestTree -constantFolding = - testGroup "folding of constants" - [ shouldNormalize "Natural/plus" "success/simple/naturalPlus" - , shouldNormalize "Optional/fold" "success/simple/optionalFold" - , shouldNormalize "Optional/build" "success/simple/optionalBuild" - , shouldNormalize "Natural/build" "success/simple/naturalBuild" - ] + let unitTestFiles = do + path <- Turtle.lstree "./dhall-lang/tests/normalization/success/unit" -conversions :: TestTree -conversions = - testGroup "conversions" - [ shouldNormalize "Natural/show" "success/simple/naturalShow" - , shouldNormalize "Integer/show" "success/simple/integerShow" - , shouldNormalize "Double/show" "success/simple/doubleShow" - , shouldNormalize "Natural/toInteger" "success/simple/naturalToInteger" - , shouldNormalize "Integer/toDouble" "success/simple/integerToDouble" - ] + let skip = + [ normalizationDirectory "unit/EmptyAlternativeA.dhall" + ] + + Monad.guard (path `notElem` skip) + + return path + + unitTests <- Test.Util.discover pattern unitTest unitTestFiles + + let testTree = + Tasty.testGroup "normalization" + [ betaNormalizationTests + , unitTests + , alphaNormalizationTests + , customization + ] + + return testTree customization :: TestTree customization = - testGroup "customization" + Tasty.testGroup "customization" [ simpleCustomization , nestedReduction ] simpleCustomization :: TestTree -simpleCustomization = testCase "simpleCustomization" $ do - let tyCtx = insert "min" (Pi "_" Natural (Pi "_" Natural Natural)) empty - valCtx e = case e of - (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y)) -> pure (Just (NaturalLit (min x y))) - _ -> pure Nothing - e <- codeWith tyCtx "min (min 11 12) 8 + 1" - assertNormalizesToWith valCtx e "9" +simpleCustomization = Tasty.HUnit.testCase "simpleCustomization" $ do + let tyCtx = + Context.insert + "min" + (Pi "_" Natural (Pi "_" Natural Natural)) + Context.empty + + valCtx e = + case e of + App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y) -> + pure (Just (NaturalLit (min x y))) + _ -> + pure Nothing + + e <- Test.Util.codeWith tyCtx "min (min 11 12) 8 + 1" + + Test.Util.assertNormalizesToWith valCtx e "9" nestedReduction :: TestTree -nestedReduction = testCase "doubleReduction" $ do - minType <- insert "min" <$> code "Natural → Natural → Natural" - fiveorlessType <- insert "fiveorless" <$> code "Natural → Natural" - wurbleType <- insert "wurble" <$> code "Natural → Integer" - let tyCtx = minType . fiveorlessType . wurbleType $ empty - valCtx e = case e of - (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y)) -> pure (Just (NaturalLit (min x y))) - (App (Var (V "wurble" 0)) (NaturalLit x)) -> pure (Just - (App (Var (V "fiveorless" 0)) (NaturalPlus (NaturalLit x) (NaturalLit 2)))) - (App (Var (V "fiveorless" 0)) (NaturalLit x)) -> pure (Just - (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalPlus (NaturalLit 3) (NaturalLit 2)))) - _ -> pure Nothing - e <- codeWith tyCtx "wurble 6" - assertNormalizesToWith valCtx e "5" +nestedReduction = Tasty.HUnit.testCase "doubleReduction" $ do + minType <- Context.insert "min" <$> Test.Util.code "Natural → Natural → Natural" + fiveorlessType <- Context.insert "fiveorless" <$> Test.Util.code "Natural → Natural" + wurbleType <- Context.insert "wurble" <$> Test.Util.code "Natural → Integer" -should :: Text -> Text -> TestTree -should name basename = - Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do - let actualCode = "./dhall-lang/tests/normalization/" <> basename <> "A.dhall" - let expectedCode = "./dhall-lang/tests/normalization/" <> basename <> "B.dhall" + let tyCtx = minType . fiveorlessType . wurbleType $ Context.empty + + valCtx e = + case e of + App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y) -> + pure (Just (NaturalLit (min x y))) + App (Var (V "wurble" 0)) (NaturalLit x) -> + pure (Just (App (Var (V "fiveorless" 0)) (NaturalPlus (NaturalLit x) (NaturalLit 2)))) + App (Var (V "fiveorless" 0)) (NaturalLit x) -> + pure (Just (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalPlus (NaturalLit 3) (NaturalLit 2)))) + _ -> + pure Nothing + + e <- Test.Util.codeWith tyCtx "wurble 6" + + Test.Util.assertNormalizesToWith valCtx e "5" + +alphaNormalizationTest :: Text -> TestTree +alphaNormalizationTest prefix = do + let prefixString = Text.unpack prefix + + Tasty.HUnit.testCase prefixString $ do + let actualPath = prefixString <> "A.dhall" + let expectedPath = prefixString <> "B.dhall" + + actualCode <- Text.IO.readFile actualPath + expectedCode <- Text.IO.readFile expectedPath + + actualExpr <- throws (Parser.exprFromText mempty actualCode) + + actualResolved <- Import.assertNoImports actualExpr + + let actualNormalized = Core.alphaNormalize (Core.denote actualResolved) + + expectedExpr <- throws (Parser.exprFromText mempty expectedCode) + + expectedResolved <- Import.assertNoImports expectedExpr + + let expectedNormalized = Core.denote expectedResolved :: Expr X X + + let message = + "The normalized expression did not match the expected output" + + Tasty.HUnit.assertEqual message expectedNormalized actualNormalized + +{- Unit tests don't type-check, so we only verify that they normalize to the + expected output +-} +unitTest :: Text -> TestTree +unitTest prefix = do + let prefixString = Text.unpack prefix + + Tasty.HUnit.testCase prefixString $ do + let actualPath = prefixString <> "A.dhall" + let expectedPath = prefixString <> "B.dhall" + + actualCode <- Text.IO.readFile actualPath + expectedCode <- Text.IO.readFile expectedPath + + actualExpr <- throws (Parser.exprFromText mempty actualCode) + + actualResolved <- Import.assertNoImports actualExpr - actualExpr <- case Dhall.Parser.exprFromText mempty actualCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - actualResolved <- Dhall.Import.load actualExpr - case Dhall.TypeCheck.typeOf actualResolved of - Left err -> Control.Exception.throwIO err - Right _ -> return () let actualNormalized = - Dhall.Core.alphaNormalize - (Dhall.Core.normalize actualResolved :: Expr X X) + Core.alphaNormalize + (Core.normalize actualResolved :: Expr X X) - expectedExpr <- case Dhall.Parser.exprFromText mempty expectedCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - expectedResolved <- Dhall.Import.load expectedExpr - case Dhall.TypeCheck.typeOf expectedResolved of - Left err -> Control.Exception.throwIO err - Right _ -> return () + expectedExpr <- throws (Parser.exprFromText mempty expectedCode) + + expectedResolved <- Import.assertNoImports expectedExpr + + let expectedNormalized = + Core.alphaNormalize (Core.denote expectedResolved) + + let message = + "The normalized expression did not match the expected output" + + Tasty.HUnit.assertEqual message expectedNormalized actualNormalized + +betaNormalizationTest :: Text -> TestTree +betaNormalizationTest prefix = + Tasty.HUnit.testCase (Text.unpack prefix) $ do + let actualCode = Test.Util.toDhallPath (prefix <> "A.dhall") + let expectedCode = Test.Util.toDhallPath (prefix <> "B.dhall") + + actualExpr <- throws (Parser.exprFromText mempty actualCode) + + actualResolved <- Import.load actualExpr + + _ <- throws (TypeCheck.typeOf actualResolved) + + let actualNormalized = + Core.alphaNormalize + (Core.normalize actualResolved :: Expr X X) + + expectedExpr <- throws (Parser.exprFromText mempty expectedCode) + + expectedResolved <- Import.load expectedExpr + + _ <- throws (TypeCheck.typeOf expectedResolved) -- Use `denote` instead of `normalize` to enforce that the expected -- expression is already in normal form let expectedNormalized = - Dhall.Core.alphaNormalize (Dhall.Core.denote expectedResolved) + Core.alphaNormalize (Core.denote expectedResolved) let message = "The normalized expression did not match the expected output" - Test.Tasty.HUnit.assertEqual message expectedNormalized actualNormalized -shouldNormalize :: Text -> Text -> TestTree -shouldNormalize name = should ("normalize " <> name <> " correctly") - -shouldOnlyAlphaNormalize :: String -> TestTree -shouldOnlyAlphaNormalize name = - Test.Tasty.HUnit.testCase ("normalize " <> name <> " correctly") $ do - - let actualPath = "./dhall-lang/tests/α-normalization/success/unit/" <> name <> "A.dhall" - let expectedPath = "./dhall-lang/tests/α-normalization/success/unit/" <> name <> "B.dhall" - - actualCode <- Data.Text.IO.readFile actualPath - expectedCode <- Data.Text.IO.readFile expectedPath - - actualExpr <- case Dhall.Parser.exprFromText mempty actualCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - actualResolved <- Dhall.Import.assertNoImports actualExpr - - let actualNormalized = Dhall.Core.alphaNormalize (Dhall.Core.denote actualResolved) - - expectedExpr <- case Dhall.Parser.exprFromText mempty expectedCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - expectedResolved <- Dhall.Import.assertNoImports expectedExpr - - let expectedNormalized = Dhall.Core.denote expectedResolved :: Expr X X - - let message = - "The normalized expression did not match the expected output" - Test.Tasty.HUnit.assertEqual message expectedNormalized actualNormalized - -shouldOnlyNormalize :: String -> TestTree -shouldOnlyNormalize name = - Test.Tasty.HUnit.testCase ("normalize " <> name <> " correctly") $ do - - let actualPath = "./dhall-lang/tests/normalization/success/unit/" <> name <> "A.dhall" - let expectedPath = "./dhall-lang/tests/normalization/success/unit/" <> name <> "B.dhall" - - actualCode <- Data.Text.IO.readFile actualPath - expectedCode <- Data.Text.IO.readFile expectedPath - - actualExpr <- case Dhall.Parser.exprFromText mempty actualCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - actualResolved <- Dhall.Import.assertNoImports actualExpr - - let actualNormalized = - Dhall.Core.alphaNormalize - (Dhall.Core.normalize actualResolved :: Expr X X) - - expectedExpr <- case Dhall.Parser.exprFromText mempty expectedCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - expectedResolved <- Dhall.Import.assertNoImports expectedExpr - - let expectedNormalized = - Dhall.Core.alphaNormalize (Dhall.Core.denote expectedResolved) - - let message = - "The normalized expression did not match the expected output" - Test.Tasty.HUnit.assertEqual message expectedNormalized actualNormalized + Tasty.HUnit.assertEqual message expectedNormalized actualNormalized diff --git a/dhall/tests/Dhall/Test/Parser.hs b/dhall/tests/Dhall/Test/Parser.hs index 452d9ad..0fe5dd8 100644 --- a/dhall/tests/Dhall/Test/Parser.hs +++ b/dhall/tests/Dhall/Test/Parser.hs @@ -2,223 +2,80 @@ module Dhall.Test.Parser where -import Data.Text (Text) -import Test.Tasty (TestTree) +import Data.Text (Text) +import Prelude hiding (FilePath) +import Test.Tasty (TestTree) +import Turtle (FilePath, ()) -import qualified Codec.Serialise -import qualified Control.Exception -import qualified Data.ByteString.Lazy -import qualified Data.Text -import qualified Data.Text.IO -import qualified Dhall.Binary -import qualified Dhall.Parser -import qualified Test.Tasty -import qualified Test.Tasty.HUnit +import qualified Codec.Serialise as Serialise +import qualified Control.Monad as Monad +import qualified Data.ByteString.Lazy as ByteString.Lazy +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Dhall.Binary as Binary +import qualified Dhall.Core as Core +import qualified Dhall.Parser as Parser +import qualified Dhall.Test.Util as Test.Util +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle -tests :: TestTree -tests = - Test.Tasty.testGroup "parser tests" - [ Test.Tasty.testGroup "whitespace" - [ shouldParse - "prefix/suffix" - "./dhall-lang/tests/parser/success/whitespace" - , shouldParse - "block comment" - "./dhall-lang/tests/parser/success/blockComment" - , shouldParse - "nested block comment" - "./dhall-lang/tests/parser/success/nestedBlockComment" - , shouldParse - "line comment" - "./dhall-lang/tests/parser/success/lineComment" - , shouldParse - "Unicode comment" - "./dhall-lang/tests/parser/success/unicodeComment" - , shouldParse - "whitespace buffet" - "./dhall-lang/tests/parser/success/whitespaceBuffet" - ] - , shouldParse - "label" - "./dhall-lang/tests/parser/success/label" - , shouldParse - "builtin name as label" - "./dhall-lang/tests/parser/success/builtinNameAsField" - , shouldParse - "quoted label" - "./dhall-lang/tests/parser/success/quotedLabel" - , shouldParse - "double quoted string" - "./dhall-lang/tests/parser/success/text/doubleQuotedString" - , shouldParse - "Unicode double quoted string" - "./dhall-lang/tests/parser/success/text/unicodeDoubleQuotedString" - , shouldParse - "escaped double quoted string" - "./dhall-lang/tests/parser/success/text/escapedDoubleQuotedString" - , shouldParse - "interpolated double quoted string" - "./dhall-lang/tests/parser/success/text/interpolatedDoubleQuotedString" - , shouldParse - "single quoted string" - "./dhall-lang/tests/parser/success/text/singleQuotedString" - , shouldParse - "escaped single quoted string" - "./dhall-lang/tests/parser/success/text/escapedSingleQuotedString" - , shouldParse - "interpolated single quoted string" - "./dhall-lang/tests/parser/success/text/interpolatedSingleQuotedString" - , shouldParse - "double" - "./dhall-lang/tests/parser/success/double" - , shouldParse - "natural" - "./dhall-lang/tests/parser/success/natural" - , shouldParse - "identifier" - "./dhall-lang/tests/parser/success/identifier" - , shouldParse - "paths" - "./dhall-lang/tests/parser/success/import/paths" - , shouldParse - "path termination" - "./dhall-lang/tests/parser/success/import/pathTermination" - , shouldParse - "urls" - "./dhall-lang/tests/parser/success/import/urls" - , shouldParse - "environmentVariables" - "./dhall-lang/tests/parser/success/import/environmentVariables" - , shouldParse - "hash" - "./dhall-lang/tests/parser/success/import/hash" - , shouldParse - "lambda" - "./dhall-lang/tests/parser/success/lambda" - , shouldParse - "if then else" - "./dhall-lang/tests/parser/success/ifThenElse" - , shouldParse - "let" - "./dhall-lang/tests/parser/success/let" - , shouldParse - "forall" - "./dhall-lang/tests/parser/success/forall" - , shouldParse - "function type" - "./dhall-lang/tests/parser/success/functionType" - , shouldParse - "operators" - "./dhall-lang/tests/parser/success/operators" - , shouldParse - "annotations" - "./dhall-lang/tests/parser/success/annotations" - , shouldParse - "merge" - "./dhall-lang/tests/parser/success/merge" - , shouldParse - "fields" - "./dhall-lang/tests/parser/success/fields" - , shouldParse - "record" - "./dhall-lang/tests/parser/success/record" - , shouldParse - "union" - "./dhall-lang/tests/parser/success/union" - , shouldParse - "list" - "./dhall-lang/tests/parser/success/list" - , shouldParse - "builtins" - "./dhall-lang/tests/parser/success/builtins" - , shouldParse - "import alternatives" - "./dhall-lang/tests/parser/success/import/importAlt" - , shouldParse - "large expression" - "./dhall-lang/tests/parser/success/largeExpression" - , shouldParse - "names that begin with reserved identifiers" - "./dhall-lang/tests/parser/success/reservedPrefix" - , shouldParse - "interpolated expressions with leading whitespace" - "./dhall-lang/tests/parser/success/text/template" - , shouldParse - "collections with type annotations containing imports" - "./dhall-lang/tests/parser/success/collectionImportType" - , shouldParse - "a parenthesized custom header import" - "./dhall-lang/tests/parser/success/import/parenthesizeUsing" - , shouldNotParse - "accessing a field of an import without parentheses" - "./dhall-lang/tests/parser/failure/importAccess.dhall" - , shouldParse - "Sort" - "./dhall-lang/tests/parser/success/sort" - , shouldParse - "quoted path components" - "./dhall-lang/tests/parser/success/import/quotedPaths" - , shouldNotParse - "positive double out of bounds" - "./dhall-lang/tests/parser/failure/doubleBoundsPos.dhall" - , shouldNotParse - "negative double out of bounds" - "./dhall-lang/tests/parser/failure/doubleBoundsNeg.dhall" - , shouldParse - "as Text" - "./dhall-lang/tests/parser/success/import/asText" - , shouldNotParse - "a multi-line literal without an initial newline" - "./dhall-lang/tests/parser/failure/mandatoryNewline.dhall" - , shouldParse - "a Unicode path component" - "./dhall-lang/tests/parser/success/import/unicodePaths" - ] +parseDirectory :: FilePath +parseDirectory = "./dhall-lang/tests/parser" -multiline :: TestTree -multiline = - Test.Tasty.testGroup "Multi-line literals" - [ shouldParse - "multi-line escape sequences" - "./dhall-lang/tests/parser/success/text/escape" - , shouldParse - "a multi-line literal with a hanging indent" - "./dhall-lang/tests/parser/success/text/hangingIndent" - , shouldParse - "a multi-line literal with an interior indent" - "./dhall-lang/tests/parser/success/text/interiorIndent" - , shouldParse - "a multi-line literal with an interpolated expression" - "./dhall-lang/tests/parser/success/text/interpolation" - , shouldParse - "comments within a multi-line literal" - "./dhall-lang/tests/parser/success/text/preserveComment" - , shouldParse - "a multi-line literal with one line" - "./dhall-lang/tests/parser/success/text/singleLine" - , shouldParse - "a multi-line literal with two lines" - "./dhall-lang/tests/parser/success/text/twoLines" - ] +getTests :: IO TestTree +getTests = do + successTests <- do + Test.Util.discover (Turtle.chars <* "A.dhall") shouldParse (Turtle.lstree (parseDirectory "success")) -shouldParse :: Text -> FilePath -> TestTree -shouldParse name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do - text <- Data.Text.IO.readFile (path <> "A.dhall") - encoded <- Data.ByteString.Lazy.readFile (path <> "B.dhallb") + let failureFiles = do + path <- Turtle.lstree (parseDirectory "failure") - expression <- case Dhall.Parser.exprFromText mempty text of - Left e -> Control.Exception.throwIO e - Right a -> pure a + let skip = + [ parseDirectory "failure/annotation.dhall" + , parseDirectory "failure/missingSpace.dhall" + ] - let term = Dhall.Binary.encode expression - bytes = Codec.Serialise.serialise term + Monad.guard (path `notElem` skip) - let message = "The expected CBOR representation doesn't match the actual one" - Test.Tasty.HUnit.assertEqual message encoded bytes + return path -shouldNotParse :: Text -> FilePath -> TestTree -shouldNotParse name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do - text <- Data.Text.IO.readFile path - case Dhall.Parser.exprFromText mempty text of - Left _ -> return () - Right _ -> fail "Unexpected successful parser" ) + failureTests <- do + Test.Util.discover (Turtle.chars <> ".dhall") shouldNotParse failureFiles + + let testTree = + Tasty.testGroup "parser tests" + [ successTests + , failureTests + ] + + return testTree + +shouldParse :: Text -> TestTree +shouldParse path = do + let pathString = Text.unpack path + + Tasty.HUnit.testCase pathString $ do + text <- Text.IO.readFile (pathString <> "A.dhall") + + encoded <- ByteString.Lazy.readFile (pathString <> "B.dhallb") + + expression <- Core.throws (Parser.exprFromText mempty text) + + let term = Binary.encode expression + + let bytes = Serialise.serialise term + + let message = "The expected CBOR representation doesn't match the actual one" + Tasty.HUnit.assertEqual message encoded bytes + +shouldNotParse :: Text -> TestTree +shouldNotParse path = do + let pathString = Text.unpack path + + Tasty.HUnit.testCase pathString (do + text <- Text.IO.readFile pathString + + case Parser.exprFromText mempty text of + Left _ -> return () + Right _ -> fail "Unexpected successful parser" ) diff --git a/dhall/tests/Dhall/Test/TypeCheck.hs b/dhall/tests/Dhall/Test/TypeCheck.hs index 68c61bf..6714e5c 100644 --- a/dhall/tests/Dhall/Test/TypeCheck.hs +++ b/dhall/tests/Dhall/Test/TypeCheck.hs @@ -7,131 +7,84 @@ import Data.Text (Text) import Dhall.Import (Imported) import Dhall.Parser (Src) import Dhall.TypeCheck (TypeError, X) +import Prelude hiding (FilePath) import Test.Tasty (TestTree) +import Turtle (FilePath, ()) -import qualified Control.Exception -import qualified Data.Text -import qualified Dhall.Core -import qualified Dhall.Import -import qualified Dhall.Parser -import qualified Dhall.TypeCheck -import qualified Test.Tasty -import qualified Test.Tasty.HUnit +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Data.Text as Text +import qualified Dhall.Core as Core +import qualified Dhall.Import as Import +import qualified Dhall.Parser as Parser +import qualified Dhall.Test.Util as Test.Util +import qualified Dhall.TypeCheck as TypeCheck +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty.HUnit +import qualified Turtle -tests :: TestTree -tests = - Test.Tasty.testGroup "typecheck tests" - [ preludeExamples - , accessTypeChecks - , should - "allow type-valued fields in a record" - "success/simple/fieldsAreTypes" - , should - "allow type-valued alternatives in a union" - "success/simple/alternativesAreTypes" - , should - "allow anonymous functions in types to be judgmentally equal" - "success/simple/anonymousFunctionsInTypes" - , should - "correctly handle α-equivalent merge alternatives" - "success/simple/mergeEquivalence" - , should - "allow Kind variables" - "success/simple/kindParameter" - , shouldNotTypeCheck - "combining records of terms and types" - "failure/combineMixedRecords" - , shouldNotTypeCheck - "preferring a record of types over a record of terms" - "failure/preferMixedRecords" - , should - "allow records of types of mixed kinds" - "success/recordOfTypes" - , should - "allow accessing a type from a record" - "success/accessType" - , should - "allow accessing a type from a Boehm-Berarducci-encoded record" - "success/accessEncodedType" - , shouldNotTypeCheck - "Hurkens' paradox" - "failure/hurkensParadox" - , should - "allow accessing a constructor from a type stored inside a record" - "success/simple/mixedFieldAccess" - , should - "allow a record of a record of types" - "success/recordOfRecordOfTypes" - , should - "allow a union of types of of mixed kinds" - "success/simple/unionsOfTypes" - , shouldNotTypeCheck - "Unions mixing terms and and types" - "failure/mixedUnions" - ] +typecheckDirectory :: FilePath +typecheckDirectory = "./dhall-lang/tests/typecheck" -preludeExamples :: TestTree -preludeExamples = - Test.Tasty.testGroup "Prelude examples" - [ should "Monoid" "./success/prelude/Monoid/00" - , should "Monoid" "./success/prelude/Monoid/01" - , should "Monoid" "./success/prelude/Monoid/02" - , should "Monoid" "./success/prelude/Monoid/03" - , should "Monoid" "./success/prelude/Monoid/04" - , should "Monoid" "./success/prelude/Monoid/05" - , should "Monoid" "./success/prelude/Monoid/06" - , should "Monoid" "./success/prelude/Monoid/07" - , should "Monoid" "./success/prelude/Monoid/08" - , should "Monoid" "./success/prelude/Monoid/09" - , should "Monoid" "./success/prelude/Monoid/10" - ] +getTests :: IO TestTree +getTests = do + successTests <- Test.Util.discover (Turtle.chars <* "A.dhall") successTest (Turtle.lstree (typecheckDirectory "success")) -accessTypeChecks :: TestTree -accessTypeChecks = - Test.Tasty.testGroup "typecheck access" - [ should "record" "./success/simple/access/0" - , should "record" "./success/simple/access/1" - ] + let failureTestFiles = do + path <- Turtle.lstree (typecheckDirectory "failure") -should :: Text -> Text -> TestTree -should name basename = - Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do - let actualCode = "./dhall-lang/tests/typecheck/" <> basename <> "A.dhall" - let expectedCode = "./dhall-lang/tests/typecheck/" <> basename <> "B.dhall" + let skip = + [ typecheckDirectory "failure/duplicateFields.dhall" + ] - actualExpr <- case Dhall.Parser.exprFromText mempty actualCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - expectedExpr <- case Dhall.Parser.exprFromText mempty expectedCode of - Left err -> Control.Exception.throwIO err - Right expr -> return expr + Monad.guard (path `notElem` skip) - let annotatedExpr = Dhall.Core.Annot actualExpr expectedExpr + return path - resolvedExpr <- Dhall.Import.load annotatedExpr - case Dhall.TypeCheck.typeOf resolvedExpr of - Left err -> Control.Exception.throwIO err - Right _ -> return () + failureTests <- Test.Util.discover (Turtle.chars <> ".dhall") failureTest failureTestFiles -shouldNotTypeCheck :: Text -> Text -> TestTree -shouldNotTypeCheck name basename = - Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do - let code = "./dhall-lang/tests/typecheck/" <> basename <> ".dhall" + let testTree = Tasty.testGroup "typecheck tests" + [ successTests + , failureTests + ] - expression <- case Dhall.Parser.exprFromText mempty code of - Left exception -> Control.Exception.throwIO exception - Right expression -> return expression + return testTree + +successTest :: Text -> TestTree +successTest prefix = + Tasty.HUnit.testCase (Text.unpack prefix) $ do + let actualCode = Test.Util.toDhallPath (prefix <> "A.dhall") + let expectedCode = Test.Util.toDhallPath (prefix <> "B.dhall") + + actualExpr <- Core.throws (Parser.exprFromText mempty actualCode) + + expectedExpr <- Core.throws (Parser.exprFromText mempty expectedCode) + + let annotatedExpr = Core.Annot actualExpr expectedExpr + + resolvedExpr <- Import.load annotatedExpr + + _ <- Core.throws (TypeCheck.typeOf resolvedExpr) + + return () + +failureTest :: Text -> TestTree +failureTest path = do + Tasty.HUnit.testCase (Text.unpack path) $ do + let dhallPath = Test.Util.toDhallPath path + + expression <- Core.throws (Parser.exprFromText mempty dhallPath) let io :: IO Bool io = do - _ <- Dhall.Import.load expression + _ <- Import.load expression return True let handler :: Imported (TypeError Src X)-> IO Bool handler _ = return False - typeChecked <- Control.Exception.handle handler io + typeChecked <- Exception.handle handler io if typeChecked - then fail (Data.Text.unpack code <> " should not have type-checked") + then fail (Text.unpack path <> " should not have type-checked") else return () diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 2c50a93..ba43455 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -11,22 +11,32 @@ module Dhall.Test.Util , assertNormalizesToWith , assertNormalized , assertTypeChecks + , discover + , toDhallPath ) where +import Data.Bifunctor (first) +import Data.Text (Text) +import Dhall.Context (Context) +import Dhall.Core (Expr, Normalizer, ReifiedNormalizer(..)) +import Dhall.Parser (Src) +import Dhall.TypeCheck (X) +import Prelude hiding (FilePath) +import Test.Tasty.HUnit +import Test.Tasty (TestTree) +import Turtle (FilePath, Pattern, Shell, fp) + import qualified Control.Exception +import qualified Control.Foldl as Foldl import qualified Data.Functor -import Data.Bifunctor (first) -import Data.Text (Text) -import qualified Dhall.Core -import Dhall.Core (Expr, Normalizer, ReifiedNormalizer(..)) +import qualified Data.Text as Text import qualified Dhall.Context -import Dhall.Context (Context) +import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Parser -import Dhall.Parser (Src) import qualified Dhall.TypeCheck -import Dhall.TypeCheck (X) -import Test.Tasty.HUnit +import qualified Test.Tasty as Tasty +import qualified Turtle normalize' :: Expr Src X -> Text normalize' = Dhall.Core.pretty . Dhall.Core.normalize @@ -76,3 +86,29 @@ assertNormalized e = do assertTypeChecks :: Text -> IO () assertTypeChecks text = Data.Functor.void (code text) + +{-| Automatically run a test on all files in a directory tree that end in + @A.dhall@ +-} +discover :: Pattern Text -> (Text -> TestTree) -> Shell FilePath -> IO TestTree +discover pattern buildTest paths = do + let shell = do + path <- paths + + let pathText = Turtle.format fp path + + prefix : _ <- return (Turtle.match pattern pathText) + + return (buildTest prefix) + + tests <- Turtle.fold shell Foldl.list + + return (Tasty.testGroup "discover" tests) + + +{-| Path names on Windows are not valid Dhall paths due to using backslashes + instead of forwardslashes to separate path components. This utility fixes + them if necessary +-} +toDhallPath :: Text -> Text +toDhallPath = Text.replace "\\" "/" diff --git a/nix/shared.nix b/nix/shared.nix index 9f2978f..efa2bd7 100644 --- a/nix/shared.nix +++ b/nix/shared.nix @@ -415,6 +415,38 @@ let }; }; + overlayGHC861 = pkgsNew: pkgsOld: { + haskell = pkgsOld.haskell // { + packages = pkgsOld.haskell.packages // { + "${compiler}" = pkgsOld.haskell.packages."${compiler}".override (old: { + overrides = + let + extension = + haskellPackagesNew: haskellPackagesOld: { + # GHC 8.6.1 accidentally shipped with an unpublished + # unix-2.8 package. Normally we'd deal with that by + # using `pkgsNew.haskell.lib.jailbreak` but it doesn't + # work for dependencies guarded by conditions. See: + # + # https://github.com/peti/jailbreak-cabal/issues/7 + turtle = + pkgsNew.haskell.lib.appendPatch + haskellPackagesOld.turtle + ./turtle.patch; + }; + + in + pkgsNew.lib.composeExtensions + (old.overrides or (_: _: {})) + extension; + } + ); + }; + }; + }; + + + nixpkgs = fetchNixpkgs { rev = "1d4de0d552ae9aa66a5b8dee5fb0650a4372d148"; @@ -430,7 +462,10 @@ let overlays = [ overlayShared overlayCabal2nix ] - ++ (if compiler == "ghc7103" then [ overlayGHC7103 ] else []); + ++ ( if compiler == "ghc7103" then [ overlayGHC7103 ] + else if compiler == "ghc861" then [ overlayGHC861 ] + else [ ] + ); }; overlayStaticLinux = pkgsNew: pkgsOld: { diff --git a/nix/turtle.nix b/nix/turtle.nix new file mode 100644 index 0000000..8d5ffe5 --- /dev/null +++ b/nix/turtle.nix @@ -0,0 +1,21 @@ +{ mkDerivation, ansi-wl-pprint, async, base, bytestring, clock +, containers, criterion, directory, doctest, exceptions, foldl +, hostname, managed, optional-args, optparse-applicative, process +, semigroups, stdenv, stm, system-fileio, system-filepath +, temporary, text, time, transformers, unix, unix-compat +}: +mkDerivation { + pname = "turtle"; + version = "1.5.14"; + sha256 = "ff9835a739cb91ff5b60b9a50f23ef2096eff32c334ea7a7c8e50ba4635d5d83"; + libraryHaskellDepends = [ + ansi-wl-pprint async base bytestring clock containers directory + exceptions foldl hostname managed optional-args + optparse-applicative process semigroups stm system-fileio + system-filepath temporary text time transformers unix unix-compat + ]; + testHaskellDepends = [ base doctest system-filepath temporary ]; + benchmarkHaskellDepends = [ base criterion text ]; + description = "Shell programming, Haskell-style"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/nix/turtle.patch b/nix/turtle.patch new file mode 100644 index 0000000..7782f12 --- /dev/null +++ b/nix/turtle.patch @@ -0,0 +1,12 @@ +diff -Naur turtle-1.5.14.old/turtle.cabal turtle-1.5.14.new/turtle.cabal +--- turtle-1.5.14.old/turtle.cabal 2019-04-18 10:54:21.000000000 -0700 ++++ turtle-1.5.14.new/turtle.cabal 2019-04-24 11:27:46.000000000 -0700 +@@ -75,7 +75,7 @@ + if os(windows) + Build-Depends: Win32 >= 2.2.0.1 && < 2.9 + else +- Build-Depends: unix >= 2.5.1.0 && < 2.8 ++ Build-Depends: unix >= 2.5.1.0 && < 2.9 + Exposed-Modules: + Turtle, + Turtle.Bytes, diff --git a/stack-lts-12.yaml b/stack-lts-12.yaml index e6f2d71..0310e95 100644 --- a/stack-lts-12.yaml +++ b/stack-lts-12.yaml @@ -15,6 +15,7 @@ extra-deps: - base-noprelude-4.11.1.0 - haskell-lsp-0.8.1.0 - haskell-lsp-types-0.8.0.1 + - turtle-1.5.14 nix: packages: - ncurses