b3b6bb4e1d
* Partially fix whitespace parsing performance regression This undoes some of the performance regression introduced in https://github.com/dhall-lang/dhall-haskell/pull/1483 Before #1483: ``` benchmarked Line comment time 11.86 ms (11.69 ms .. 11.98 ms) 0.999 R² (0.999 R² .. 1.000 R²) mean 11.84 ms (11.79 ms .. 11.89 ms) std dev 129.4 μs (107.2 μs .. 164.1 μs) benchmarked Block comment time 13.20 ms (13.00 ms .. 13.41 ms) 0.999 R² (0.998 R² .. 1.000 R²) mean 13.59 ms (13.41 ms .. 13.94 ms) std dev 600.0 μs (142.2 μs .. 953.7 μs) ``` After #1483: ``` benchmarked Line comment time 288.7 ms (282.8 ms .. 294.7 ms) 1.000 R² (0.999 R² .. 1.000 R²) mean 292.3 ms (290.8 ms .. 294.6 ms) std dev 3.156 ms (2.216 ms .. 4.546 ms) benchmarked Block comment time 286.2 ms (280.9 ms .. 292.6 ms) 0.999 R² (0.998 R² .. 1.000 R²) mean 290.6 ms (288.3 ms .. 292.9 ms) std dev 3.875 ms (2.866 ms .. 5.500 ms) ``` After this change: ``` benchmarked Line comment time 61.44 ms (60.37 ms .. 63.03 ms) 0.999 R² (0.997 R² .. 1.000 R²) mean 61.41 ms (60.74 ms .. 62.25 ms) std dev 1.341 ms (945.0 μs .. 1.901 ms) benchmarked Block comment time 61.83 ms (60.97 ms .. 63.14 ms) 0.999 R² (0.998 R² .. 1.000 R²) mean 61.16 ms (60.33 ms .. 61.85 ms) std dev 1.396 ms (1.011 ms .. 1.907 ms) ``` * Correctly parse `https://example.com usingBla` ... as caught by @sjakobi
239 lines
8.4 KiB
Haskell
239 lines
8.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Dhall.Test.Parser where
|
|
|
|
import Data.Monoid ((<>))
|
|
import Data.Text (Text)
|
|
import Data.Void (Void)
|
|
import Dhall.Core (Binding(..), Expr(..), Import, Var(..))
|
|
import Prelude hiding (FilePath)
|
|
import Test.Tasty (TestTree)
|
|
import Turtle (FilePath, (</>))
|
|
|
|
import qualified Control.Monad as Monad
|
|
import qualified Data.Bifunctor as Bifunctor
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.ByteString.Lazy as ByteString.Lazy
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.IO as Text.IO
|
|
import qualified Data.Text.Encoding as Text.Encoding
|
|
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 Text.Printf as Printf
|
|
import qualified Turtle
|
|
|
|
parseDirectory :: FilePath
|
|
parseDirectory = "./dhall-lang/tests/parser"
|
|
|
|
binaryDecodeDirectory :: FilePath
|
|
binaryDecodeDirectory = "./dhall-lang/tests/binary-decode"
|
|
|
|
getTests :: IO TestTree
|
|
getTests = do
|
|
let successFiles = Turtle.lstree (parseDirectory </> "success")
|
|
|
|
successTests <- do
|
|
Test.Util.discover (Turtle.chars <* "A.dhall") shouldParse successFiles
|
|
|
|
let failureFiles = Turtle.lstree (parseDirectory </> "failure")
|
|
|
|
failureTests <- do
|
|
Test.Util.discover (Turtle.chars <> ".dhall") shouldNotParse failureFiles
|
|
|
|
let binaryDecodeSuccessFiles =
|
|
Turtle.lstree (binaryDecodeDirectory </> "success")
|
|
|
|
binaryDecodeSuccessTests <- do
|
|
Test.Util.discover (Turtle.chars <* "A.dhallb") shouldDecode binaryDecodeSuccessFiles
|
|
|
|
let binaryDecodeFailureFiles = Turtle.lstree (binaryDecodeDirectory </> "failure")
|
|
|
|
binaryDecodeFailureTests <- do
|
|
Test.Util.discover (Turtle.chars <* ".dhallb") shouldNotDecode binaryDecodeFailureFiles
|
|
|
|
let testTree =
|
|
Tasty.testGroup "parser tests"
|
|
[ successTests
|
|
, failureTests
|
|
, internalTests
|
|
, binaryDecodeSuccessTests
|
|
, binaryDecodeFailureTests
|
|
]
|
|
|
|
return testTree
|
|
|
|
internalTests :: TestTree
|
|
internalTests =
|
|
Tasty.testGroup "internal"
|
|
[ notesInLetInLet ]
|
|
|
|
notesInLetInLet :: TestTree
|
|
notesInLetInLet = do
|
|
Tasty.HUnit.testCase "Notes in let-in-let" $ do
|
|
let code = "let x = 0 let y = 1 in let z = 2 in x"
|
|
|
|
expression <- Core.throws (Parser.exprFromText mempty code)
|
|
|
|
let simplifyNotes = Bifunctor.first Parser.srcText
|
|
|
|
let expected =
|
|
(Note code
|
|
(Let
|
|
(Binding
|
|
(Just " ")
|
|
"x"
|
|
(Just " ")
|
|
Nothing
|
|
(Just " ")
|
|
(Note "0 " (Note "0" (NaturalLit 0)))
|
|
)
|
|
-- This 'Let' isn't wrapped in a 'Note'!
|
|
(Let
|
|
(Binding
|
|
(Just " ")
|
|
"y"
|
|
(Just " ")
|
|
Nothing
|
|
(Just " ")
|
|
(Note "1 " (Note "1" (NaturalLit 1)))
|
|
)
|
|
(Note "let z = 2 in x"
|
|
(Let
|
|
(Binding
|
|
(Just " ")
|
|
"z"
|
|
(Just " ")
|
|
Nothing
|
|
(Just " ")
|
|
(Note "2 " (Note "2" (NaturalLit 2)))
|
|
)
|
|
(Note "x" (Var (V "x" 0)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
let msg = "Unexpected parse result"
|
|
|
|
Tasty.HUnit.assertEqual msg expected (simplifyNotes expression)
|
|
|
|
shouldParse :: Text -> TestTree
|
|
shouldParse path = do
|
|
let expectedFailures =
|
|
-- This is a bug created by a parsing performance
|
|
-- improvement
|
|
[ parseDirectory </> "success/unit/MergeParenAnnotation"
|
|
|
|
-- https://github.com/dhall-lang/dhall-haskell/issues/1454
|
|
, parseDirectory </> "success/missingFoo"
|
|
, parseDirectory </> "success/missingSlash"
|
|
]
|
|
|
|
let pathString = Text.unpack path
|
|
|
|
Test.Util.testCase path expectedFailures $ do
|
|
text <- Text.IO.readFile (pathString <> "A.dhall")
|
|
|
|
encoded <- ByteString.Lazy.readFile (pathString <> "B.dhallb")
|
|
|
|
expression <- case Parser.exprFromText mempty text of
|
|
Left exception -> Tasty.HUnit.assertFailure (show exception)
|
|
Right expression -> return expression
|
|
|
|
let bytes = Binary.encodeExpression (Core.denote expression)
|
|
|
|
let render =
|
|
concatMap (Printf.printf "%02x ")
|
|
. ByteString.Lazy.unpack
|
|
|
|
Monad.unless (encoded == bytes) $ do
|
|
let message = "The expected CBOR representation doesn't match the actual one\n"
|
|
++ "expected: " ++ render encoded ++ "\n but got: " ++ render bytes
|
|
++ "\n expr: " ++ show (Core.denote expression :: Expr Void Import)
|
|
|
|
Tasty.HUnit.assertFailure message
|
|
|
|
|
|
shouldNotParse :: Text -> TestTree
|
|
shouldNotParse path = do
|
|
let expectedFailures =
|
|
[ -- For parsing performance reasons the implementation
|
|
-- treats a missing type annotation on an empty list as
|
|
-- as a type-checking failure instead of a parse failure,
|
|
-- but this might be fixable.
|
|
parseDirectory </> "failure/unit/ListLitEmptyMissingAnnotation.dhall"
|
|
, parseDirectory </> "failure/unit/ListLitEmptyAnnotation.dhall"
|
|
|
|
-- The same performance improvements also broke the
|
|
-- precedence of parsing empty list literals
|
|
, parseDirectory </> "failure/unit/ListLitEmptyPrecedence.dhall"
|
|
]
|
|
|
|
let pathString = Text.unpack path
|
|
|
|
Test.Util.testCase path expectedFailures (do
|
|
bytes <- ByteString.readFile pathString
|
|
|
|
case Text.Encoding.decodeUtf8' bytes of
|
|
Left _ -> return ()
|
|
Right text -> do
|
|
case Parser.exprFromText mempty text of
|
|
Left _ -> return ()
|
|
Right _ -> Tasty.HUnit.assertFailure "Unexpected successful parse" )
|
|
|
|
shouldDecode :: Text -> TestTree
|
|
shouldDecode pathText = do
|
|
let expectedFailures =
|
|
[ {- Note that this test actually successfully decodes the value, but
|
|
mistakenly decodes the value to `_` instead of `x`. This is
|
|
because the 55799 tag causes normal decoding to fail, so it falls
|
|
back to treating the `"x"` as a version tag instead of a label.
|
|
|
|
Either way, fixing 55799 decoding would cause this test to pass
|
|
again.
|
|
-}
|
|
binaryDecodeDirectory </> "success/unit/SelfDescribeCBORX2"
|
|
, binaryDecodeDirectory </> "success/unit/SelfDescribeCBORX3"
|
|
]
|
|
|
|
let pathString = Text.unpack pathText
|
|
|
|
Test.Util.testCase pathText expectedFailures (do
|
|
bytes <- ByteString.Lazy.readFile (pathString <> "A.dhallb")
|
|
|
|
decodedExpression <- case Binary.decodeExpression bytes of
|
|
Left exception ->
|
|
Tasty.HUnit.assertFailure (show exception)
|
|
Right decodedExpression ->
|
|
return decodedExpression
|
|
|
|
text <- Text.IO.readFile (pathString <> "B.dhall")
|
|
|
|
parsedExpression <- Core.throws (Parser.exprFromText mempty text)
|
|
|
|
let strippedExpression :: Expr Void Import
|
|
strippedExpression = Core.denote parsedExpression
|
|
|
|
let message =
|
|
"The decoded expression didn't match the parsed expression"
|
|
|
|
Tasty.HUnit.assertEqual message strippedExpression decodedExpression )
|
|
|
|
shouldNotDecode :: Text -> TestTree
|
|
shouldNotDecode pathText = do
|
|
let expectedFailures = []
|
|
|
|
let pathString = Text.unpack pathText
|
|
|
|
Test.Util.testCase pathText expectedFailures (do
|
|
bytes <- ByteString.Lazy.readFile (pathString <> ".dhallb")
|
|
|
|
case Binary.decodeExpression bytes :: Either Binary.DecodingFailure (Expr Void Import) of
|
|
Left _ -> return ()
|
|
Right _ -> Tasty.HUnit.assertFailure "Unexpected successful decode" )
|