ehmry/dhall-haskell
ehmry
/
dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Gabriel Gonzalez 2019-04-24 13:01:46 -07:00 committed by GitHub
parent 86ceb825cd
commit 7d31506be4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 628 additions and 1097 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
dhall/dhall.cabal
View File

@ -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

12
dhall/src/Dhall.hs
View File

@ -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.

11
dhall/src/Dhall/Core.hs
View File

@ -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

12
dhall/src/Dhall/Format.hs
View File

@ -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

12
dhall/src/Dhall/Import.hs
View File

@ -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)

26
dhall/src/Dhall/Main.hs
View File

@ -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

145
dhall/tests/Dhall/Test/Format.hs
View File

@ -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

135
dhall/tests/Dhall/Test/Import.hs
View File

@ -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 ()) )

78
dhall/tests/Dhall/Test/Lint.hs
View File

@ -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

53
dhall/tests/Dhall/Test/Main.hs
View File

@ -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

668
dhall/tests/Dhall/Test/Normalization.hs
View File

@ -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

281
dhall/tests/Dhall/Test/Parser.hs
View File

@ -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" )

165
dhall/tests/Dhall/Test/TypeCheck.hs
View File

@ -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 ()

52
dhall/tests/Dhall/Test/Util.hs
View File

@ -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 "\\" "/"

37
nix/shared.nix
View File

@ -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: {

21
nix/turtle.nix Normal file
View File

@ -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;
}

12
nix/turtle.patch Normal file
View File

@ -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,

1
stack-lts-12.yaml
View File

@ -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