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

Fix running the type-inference failure tests (#1326)

Browse Source 
This fixes several bugs introduced in
fddce0b8cf.
This commit is contained in:
Simon Jakobi 2019-09-19 17:46:07 +02:00 committed by mergify[bot]
parent 8ead6012e9
commit 0ef00bf5e3
1 changed files with 28 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
dhall/tests/Dhall/Test/TypeInference.hs
View File

@ -2,7 +2,7 @@
module Dhall.Test.TypeInference where module Dhall.Test.TypeInference where
import Control.Exception (SomeException) import Control.Exception (SomeException(..))
import Data.Monoid (mempty, (<>)) import Data.Monoid (mempty, (<>))
import Data.Text (Text) import Data.Text (Text)
import Prelude hiding (FilePath) import Prelude hiding (FilePath)
@ -33,7 +33,7 @@ getTests = do
let failureTestFiles = Turtle.lstree (typeInferenceDirectory </> "failure") let failureTestFiles = Turtle.lstree (typeInferenceDirectory </> "failure")
failureTests <- Test.Util.discover (Turtle.chars <* "A.dhall") failureTest failureTestFiles failureTests <- Test.Util.discover (Turtle.chars <* ".dhall") failureTest failureTestFiles
let testTree = Tasty.testGroup "type-inference tests" let testTree = Tasty.testGroup "type-inference tests"
[ successTests [ successTests
@ -84,25 +84,36 @@ successTest prefix = do
Tasty.HUnit.assertEqual message resolvedExpectedType inferredType Tasty.HUnit.assertEqual message resolvedExpectedType inferredType
failureTest :: Text -> TestTree failureTest :: Text -> TestTree
failureTest path = do failureTest prefix = do
let skip = [ typeInferenceDirectory </> "failure/unit/MergeEmptyNeedsDirectAnnotation1.dhall" let skip = [ typeInferenceDirectory </> "failure/unit/MergeEmptyNeedsDirectAnnotation1"
-- Duplicate fields are incorrectly caught during parsing:
-- https://github.com/dhall-lang/dhall-haskell/issues/772
, typeInferenceDirectory </> "failure/unit/RecordLitDuplicateFields"
, typeInferenceDirectory </> "failure/unit/RecordTypeDuplicateFields"
, typeInferenceDirectory </> "failure/unit/UnionTypeDuplicateVariants1"
, typeInferenceDirectory </> "failure/unit/UnionTypeDuplicateVariants2"
] ]
Test.Util.testCase path skip $ do Test.Util.testCase prefix skip $ do
let dhallPath = Test.Util.toDhallPath path let prefixFP = Text.unpack prefix
expression <- Core.throws (Parser.exprFromText mempty dhallPath) code <- Text.IO.readFile (prefixFP <> ".dhall")
let io :: IO Bool expression <- case Parser.exprFromText mempty code of
io = do Left _ -> Tasty.HUnit.assertFailure (prefixFP <> " should have parsed")
_ <- Test.Util.load expression Right e -> return e
return True
let handler :: SomeException -> IO Bool tryResolvedExpr <-
handler _ = return False Exception.try
(Test.Util.loadRelativeTo
(FilePath.takeDirectory prefixFP)
Import.IgnoreSemanticCache
expression)
typeChecked <- Exception.handle handler io case tryResolvedExpr of
Left (SomeException _) -> return ()
if typeChecked Right resolved -> case TypeCheck.typeOf resolved of
then Tasty.HUnit.assertFailure (Text.unpack path <> " should not have type-checked") Left _ -> return ()
else return () Right _ -> Tasty.HUnit.assertFailure (prefixFP <> " should not have type-checked")