Improve encoding/decoding speed (#1500)
... by not going through a `Term` intermediate
This gives a ~28% performance in decoding improvement, which means that
cache looks are not faster.
Here are the new decoding benchmarks before and after this change:
Before:
```
benchmarked Issue #108/Binary
time 266.5 μs (265.7 μs .. 267.4 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 266.3 μs (265.6 μs .. 267.1 μs)
std dev 2.418 μs (1.891 μs .. 3.436 μs)
benchmarking Kubernetes/Binary ... took 36.94 s, total 56 iterations
benchmarked Kubernetes/Binary
time 641.3 ms (623.0 ms .. 655.4 ms)
0.999 R² (0.997 R² .. 1.000 R²)
mean 679.7 ms (665.5 ms .. 702.6 ms)
std dev 29.48 ms (14.15 ms .. 39.05 ms)
```
After:
```
benchmarked Issue #108/Binary
time 282.2 μs (279.6 μs .. 284.7 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 281.9 μs (280.7 μs .. 287.7 μs)
std dev 7.089 μs (2.550 μs .. 15.44 μs)
variance introduced by outliers: 11% (moderately inflated)
benchmarking Kubernetes/Binary ... took 27.57 s, total 56 iterations
benchmarked Kubernetes/Binary
time 499.1 ms (488.1 ms .. 506.6 ms)
0.999 R² (0.998 R² .. 1.000 R²)
mean 498.9 ms (494.4 ms .. 503.9 ms)
std dev 8.539 ms (6.236 ms .. 12.56 ms)
```
There's a slight performance regression for the decoding microbenchmark, but
in practice my testing on real examples matches performance improvements seen
in the larger benchmark based on an example cache product from
`dhall-kubernetes`.
Note that is a breaking change because:
* There is no longer a `FromTerm` nor `ToTerm` class. Now we use the
`Serialise` class and `{encode,decode}Expression` now work on `ByteString`s
instead of `Term`s
* I further narrowed the types of several encoding/decoding utilites to expect a
`Void` for the first type parameter of `Expr`
* This is a regression with respect to stripping 55799 CBOR tags, mainly
because properly handling the tags at every possible point in the syntax tree
would considerably complicate the code
This commit is contained in:
Gabriel Gonzalez
GitHub
parent
5ceb8d9d60
commit
b843cae5d2
|
|
@ -165,5 +165,5 @@ normalize (WellTyped expr) = Normal $ Dhall.normalize expr
|
|||
-- Dhall's hash annotations (prefixed by "sha256:" and base-64 encoded).
|
||||
hashNormalToCode :: Normal -> Text
|
||||
hashNormalToCode (Normal expr) =
|
||||
Dhall.hashExpressionToCode alphaNormal
|
||||
Dhall.hashExpressionToCode (Dhall.denote alphaNormal)
|
||||
where alphaNormal = Dhall.alphaNormalize expr
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -6,7 +6,8 @@ module Main where
|
|||
import Control.Monad (forM)
|
||||
import Data.Map (Map, foldrWithKey, singleton, unions)
|
||||
import Data.Monoid ((<>))
|
||||
import Gauge (defaultMain, bgroup, bench, whnf, nfIO)
|
||||
import Data.Void (Void)
|
||||
import Gauge (defaultMain, bgroup, bench, nf, whnf, nfIO)
|
||||
|
||||
import System.Directory
|
||||
|
||||
|
|
@ -67,27 +68,25 @@ benchExprFromText name expr =
|
|||
|
||||
benchExprFromBytes
|
||||
:: String -> Data.ByteString.Lazy.ByteString -> Gauge.Benchmark
|
||||
benchExprFromBytes name bytes = bench name (whnf f bytes)
|
||||
benchExprFromBytes name bytes = bench name (nf f bytes)
|
||||
where
|
||||
f bytes = do
|
||||
term <- case Codec.Serialise.deserialiseOrFail bytes of
|
||||
Left _ -> Nothing
|
||||
Right term -> return term
|
||||
case Dhall.Binary.decodeExpression term
|
||||
:: Either Dhall.Binary.DecodingFailure (Dhall.Expr () Dhall.Import) of
|
||||
Left _ -> Nothing
|
||||
Right expression -> return expression
|
||||
case Dhall.Binary.decodeExpression bytes of
|
||||
Left exception -> error (show exception)
|
||||
Right expression -> expression :: Dhall.Expr Void Dhall.Import
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
prelude <- loadPreludeFiles
|
||||
issue108Text <- TIO.readFile "benchmark/examples/issue108.dhall"
|
||||
issue108Bytes <- Data.ByteString.Lazy.readFile "benchmark/examples/issue108.dhall.bin"
|
||||
kubernetesExample <- Data.ByteString.Lazy.readFile "benchmark/examples/kubernetes.dhall.bin"
|
||||
defaultMain
|
||||
[ bgroup "Issue #108"
|
||||
[ benchExprFromText "Text" issue108Text
|
||||
, benchExprFromBytes "Binary" issue108Bytes
|
||||
]
|
||||
, benchExprFromBytes "Kubernetes/Binary" kubernetesExample
|
||||
, benchExprFromText "Long variable names" (T.replicate 1000000 "x")
|
||||
, benchExprFromText "Large number of function arguments" (T.replicate 10000 "x ")
|
||||
, benchExprFromText "Long double-quoted strings" ("\"" <> T.replicate 1000000 "x" <> "\"")
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -26,7 +26,6 @@ import Data.Text (Text)
|
|||
import Data.Text.Prettyprint.Doc (Doc, Pretty)
|
||||
import Data.Void (Void)
|
||||
import Dhall.Syntax (Binding(..), Chunks (..), Const(..), DhallDouble(..), Expr(..), Var(..))
|
||||
import Dhall.Binary (ToTerm)
|
||||
import Dhall.Map (Map)
|
||||
import Dhall.Set (Set)
|
||||
import Dhall.Pretty.Internal (Ann)
|
||||
|
|
@ -156,7 +155,7 @@ rparen :: Diff
|
|||
rparen = token Internal.rparen
|
||||
|
||||
-- | Render the difference between the normal form of two expressions
|
||||
diffNormalized :: (Eq a, Pretty a, ToTerm a) => Expr s a -> Expr s a -> Diff
|
||||
diffNormalized :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff
|
||||
diffNormalized l0 r0 = Dhall.Diff.diff l1 r1
|
||||
where
|
||||
l1 = Dhall.Normalize.alphaNormalize (Dhall.Normalize.normalize l0)
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ freezeImport directory import_ = do
|
|||
Dhall.Core.alphaNormalize (Dhall.Core.normalize expression)
|
||||
|
||||
-- make sure the frozen import is present in the semantic cache
|
||||
Dhall.Import.writeExpressionToSemanticCache expression
|
||||
Dhall.Import.writeExpressionToSemanticCache (Dhall.Core.denote expression)
|
||||
|
||||
let expressionHash = Dhall.Import.hashExpression normalizedExpression
|
||||
|
||||
|
|
|
|||
|
|
@ -138,7 +138,6 @@ module Dhall.Import (
|
|||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Codec.CBOR.Term (Term(..))
|
||||
import Control.Exception (Exception, SomeException, IOException, toException)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Catch (throwM, MonadCatch(catch), handle)
|
||||
|
|
@ -180,6 +179,8 @@ import Dhall.Import.Types
|
|||
import Dhall.Parser (Parser(..), ParseError(..), Src(..), SourcedException(..))
|
||||
import Lens.Family.State.Strict (zoom)
|
||||
|
||||
import qualified Codec.CBOR.Encoding as Encoding
|
||||
import qualified Codec.CBOR.Write as Write
|
||||
import qualified Codec.Serialise
|
||||
import qualified Control.Monad.Trans.Maybe as Maybe
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
|
|
@ -504,6 +505,7 @@ loadImportWithSemanticCache
|
|||
case mCached of
|
||||
Just bytesStrict -> do
|
||||
let actualHash = Dhall.Crypto.sha256Hash bytesStrict
|
||||
|
||||
if semanticHash == actualHash
|
||||
then return ()
|
||||
else do
|
||||
|
|
@ -511,12 +513,10 @@ loadImportWithSemanticCache
|
|||
throwMissingImport (Imported _stack (HashMismatch {expectedHash = semanticHash, ..}))
|
||||
|
||||
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
|
||||
term <- case Codec.Serialise.deserialiseOrFail bytesLazy of
|
||||
Left err -> throwMissingImport (Imported _stack err)
|
||||
Right t -> return t
|
||||
importSemantics <- case Dhall.Binary.decodeExpression term of
|
||||
Left err -> throwMissingImport (Imported _stack err)
|
||||
Right sem -> return sem
|
||||
|
||||
importSemantics <- case Dhall.Binary.decodeExpression bytesLazy of
|
||||
Left err -> throwMissingImport (Imported _stack err)
|
||||
Right e -> return e
|
||||
|
||||
return (ImportSemantics {..})
|
||||
|
||||
|
|
@ -544,7 +544,7 @@ fetchFromSemanticCache expectedHash = Maybe.runMaybeT $ do
|
|||
|
||||
-- | Ensure that the given expression is present in the semantic cache. The
|
||||
-- given expression should be alpha-beta-normal.
|
||||
writeExpressionToSemanticCache :: Expr Src Void -> IO ()
|
||||
writeExpressionToSemanticCache :: Expr Void Void -> IO ()
|
||||
writeExpressionToSemanticCache expression = writeToSemanticCache hash bytes
|
||||
where
|
||||
bytes = encodeExpression NoVersion expression
|
||||
|
|
@ -592,18 +592,14 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Cod
|
|||
-- Check the semi-semantic cache. See
|
||||
-- https://github.com/dhall-lang/dhall-haskell/issues/1098 for the reasoning
|
||||
-- behind semi-semantic caching.
|
||||
let semisemanticHash = computeSemisemanticHash resolvedExpr
|
||||
let semisemanticHash = computeSemisemanticHash (Dhall.Core.denote resolvedExpr)
|
||||
mCached <- lift $ fetchFromSemisemanticCache semisemanticHash
|
||||
|
||||
importSemantics <- case mCached of
|
||||
Just bytesStrict -> do
|
||||
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
|
||||
|
||||
term <- case Codec.Serialise.deserialiseOrFail bytesLazy of
|
||||
Left err -> throwMissingImport (Imported _stack err)
|
||||
Right t -> return t
|
||||
|
||||
importSemantics <- case Dhall.Binary.decodeExpression term of
|
||||
importSemantics <- case Dhall.Binary.decodeExpression bytesLazy of
|
||||
Left err -> throwMissingImport (Imported _stack err)
|
||||
Right sem -> return sem
|
||||
|
||||
|
|
@ -659,7 +655,7 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Loc
|
|||
-- AST (without normalising or type-checking it first). See
|
||||
-- https://github.com/dhall-lang/dhall-haskell/issues/1098 for further
|
||||
-- discussion.
|
||||
computeSemisemanticHash :: Expr Src Void -> Dhall.Crypto.SHA256Digest
|
||||
computeSemisemanticHash :: Expr Void Void -> Dhall.Crypto.SHA256Digest
|
||||
computeSemisemanticHash resolvedExpr = hashExpression resolvedExpr
|
||||
|
||||
-- Fetch encoded normal form from "semi-semantic cache"
|
||||
|
|
@ -1012,7 +1008,7 @@ loadWith expr₀ = case expr₀ of
|
|||
ImportSemantics {..} <- loadImport child
|
||||
zoom stack (State.put _stack)
|
||||
|
||||
return importSemantics
|
||||
return (Dhall.Core.renote importSemantics)
|
||||
|
||||
ImportAlt a b -> loadWith a `catch` handler₀
|
||||
where
|
||||
|
|
@ -1109,33 +1105,30 @@ loadRelativeTo rootDirectory semanticCacheMode expression =
|
|||
(emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode }
|
||||
|
||||
encodeExpression
|
||||
:: forall s
|
||||
. StandardVersion
|
||||
:: StandardVersion
|
||||
-- ^ `NoVersion` means to encode without the version tag
|
||||
-> Expr s Void
|
||||
-> Expr Void Void
|
||||
-> Data.ByteString.ByteString
|
||||
encodeExpression _standardVersion expression = bytesStrict
|
||||
where
|
||||
intermediateExpression :: Expr s Import
|
||||
intermediateExpression :: Expr Void Import
|
||||
intermediateExpression = fmap absurd expression
|
||||
|
||||
term :: Term
|
||||
term = Dhall.Binary.encodeExpression intermediateExpression
|
||||
|
||||
taggedTerm :: Term
|
||||
taggedTerm =
|
||||
encoding =
|
||||
case _standardVersion of
|
||||
NoVersion -> term
|
||||
s -> TList [ TString v, term ]
|
||||
NoVersion ->
|
||||
Codec.Serialise.encode intermediateExpression
|
||||
s ->
|
||||
Encoding.encodeListLen 2
|
||||
<> Encoding.encodeString v
|
||||
<> Codec.Serialise.encode intermediateExpression
|
||||
where
|
||||
v = Dhall.Binary.renderStandardVersion s
|
||||
|
||||
bytesLazy = Codec.Serialise.serialise taggedTerm
|
||||
|
||||
bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy
|
||||
bytesStrict = Write.toStrictByteString encoding
|
||||
|
||||
-- | Hash a fully resolved expression
|
||||
hashExpression :: Expr s Void -> Dhall.Crypto.SHA256Digest
|
||||
hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest
|
||||
hashExpression expression =
|
||||
Dhall.Crypto.sha256Hash (encodeExpression NoVersion expression)
|
||||
|
||||
|
|
@ -1145,7 +1138,7 @@ hashExpression expression =
|
|||
In other words, the output of this function can be pasted into Dhall
|
||||
source code to add an integrity check to an import
|
||||
-}
|
||||
hashExpressionToCode :: Expr s Void -> Text
|
||||
hashExpressionToCode :: Expr Void Void -> Text
|
||||
hashExpressionToCode expr =
|
||||
"sha256:" <> Text.pack (show (hashExpression expr))
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ instance Pretty Chained where
|
|||
|
||||
-- | An import that has been fully interpeted
|
||||
data ImportSemantics = ImportSemantics
|
||||
{ importSemantics :: Expr Src Void
|
||||
{ importSemantics :: Expr Void Void
|
||||
-- ^ The fully resolved import, typechecked and beta-normal.
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,6 @@ import Text.Dot ((.->.))
|
|||
import qualified Codec.CBOR.JSON
|
||||
import qualified Codec.CBOR.Read
|
||||
import qualified Codec.CBOR.Write
|
||||
import qualified Codec.Serialise
|
||||
import qualified Control.Exception
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
import qualified Data.Aeson
|
||||
|
|
@ -673,9 +672,7 @@ command (Options {..}) = do
|
|||
Encode {..} -> do
|
||||
expression <- getExpression file
|
||||
|
||||
let term = Dhall.Binary.encodeExpression expression
|
||||
|
||||
let bytes = Codec.Serialise.serialise term
|
||||
let bytes = Dhall.Binary.encodeExpression (Dhall.Core.denote expression)
|
||||
|
||||
if json
|
||||
then do
|
||||
|
|
@ -696,7 +693,7 @@ command (Options {..}) = do
|
|||
InputFile f -> Data.ByteString.Lazy.readFile f
|
||||
StandardInput -> Data.ByteString.Lazy.getContents
|
||||
|
||||
term <- do
|
||||
expression <- do
|
||||
if json
|
||||
then do
|
||||
value <- case Data.Aeson.eitherDecode' bytes of
|
||||
|
|
@ -705,15 +702,14 @@ command (Options {..}) = do
|
|||
|
||||
let encoding = Codec.CBOR.JSON.encodeValue value
|
||||
|
||||
let cborBytes = Codec.CBOR.Write.toLazyByteString encoding
|
||||
Dhall.Core.throws (Codec.Serialise.deserialiseOrFail cborBytes)
|
||||
let cborgBytes = Codec.CBOR.Write.toLazyByteString encoding
|
||||
|
||||
Dhall.Core.throws (Dhall.Binary.decodeExpression cborgBytes)
|
||||
else do
|
||||
Dhall.Core.throws (Codec.Serialise.deserialiseOrFail bytes)
|
||||
Dhall.Core.throws (Dhall.Binary.decodeExpression bytes)
|
||||
|
||||
expression <- Dhall.Core.throws (Dhall.Binary.decodeExpression term)
|
||||
:: IO (Expr Src Import)
|
||||
|
||||
let doc = Dhall.Pretty.prettyCharacterSet characterSet expression
|
||||
let doc = Dhall.Pretty.prettyCharacterSet characterSet (Dhall.Core.renote expression :: Expr Src Import)
|
||||
|
||||
renderDoc System.IO.stdout doc
|
||||
|
||||
|
|
|
|||
|
|
@ -211,7 +211,7 @@ newtype DhallDouble = DhallDouble { getDhallDouble :: Double }
|
|||
--
|
||||
-- This instance is also consistent with with the binary encoding of Dhall @Double@s:
|
||||
--
|
||||
-- >>> toBytes n = Codec.Serialise.serialise (Dhall.Binary.encode (n :: DhallDouble))
|
||||
-- >>> toBytes n = Dhall.Binary.encodeExpression (DoubleLit n :: Expr Void Import)
|
||||
--
|
||||
-- prop> \a b -> (a == b) == (toBytes a == toBytes b)
|
||||
instance Eq DhallDouble where
|
||||
|
|
|
|||
|
|
@ -37,7 +37,6 @@ import Data.Text (Text)
|
|||
import Data.Text.Prettyprint.Doc (Doc, Pretty(..))
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Void (Void, absurd)
|
||||
import Dhall.Binary (ToTerm(..))
|
||||
import Dhall.Context (Context)
|
||||
import Dhall.Syntax (Binding(..), Const(..), Chunks(..), Expr(..), Var(..))
|
||||
import Dhall.Eval
|
||||
|
|
@ -1330,13 +1329,13 @@ data TypeMessage s a
|
|||
| CantMultiply (Expr s a) (Expr s a)
|
||||
deriving (Show)
|
||||
|
||||
shortTypeMessage :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> Doc Ann
|
||||
shortTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann
|
||||
shortTypeMessage msg =
|
||||
"\ESC[1;31mError\ESC[0m: " <> short <> "\n"
|
||||
where
|
||||
ErrorMessages {..} = prettyTypeMessage msg
|
||||
|
||||
longTypeMessage :: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> Doc Ann
|
||||
longTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann
|
||||
longTypeMessage msg =
|
||||
"\ESC[1;31mError\ESC[0m: " <> short <> "\n"
|
||||
<> "\n"
|
||||
|
|
@ -1357,8 +1356,7 @@ _NOT = "\ESC[1mnot\ESC[0m"
|
|||
insert :: Pretty a => a -> Doc Ann
|
||||
insert = Dhall.Util.insert
|
||||
|
||||
prettyTypeMessage
|
||||
:: (Eq a, Pretty a, ToTerm a) => TypeMessage s a -> ErrorMessages
|
||||
prettyTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages
|
||||
prettyTypeMessage (UnboundVariable x) = ErrorMessages {..}
|
||||
-- We do not need to print variable name here. For the discussion see:
|
||||
-- https://github.com/dhall-lang/dhall-haskell/pull/116
|
||||
|
|
@ -4252,12 +4250,12 @@ data TypeError s a = TypeError
|
|||
, typeMessage :: TypeMessage s a
|
||||
}
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a, ToTerm a) => Show (TypeError s a) where
|
||||
instance (Eq a, Pretty s, Pretty a) => Show (TypeError s a) where
|
||||
show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a, ToTerm a, Typeable s, Typeable a) => Exception (TypeError s a)
|
||||
instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (TypeError s a)
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a, ToTerm a) => Pretty (TypeError s a) where
|
||||
instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where
|
||||
pretty (TypeError _ expr msg)
|
||||
= Pretty.unAnnotate
|
||||
( "\n"
|
||||
|
|
@ -4425,12 +4423,12 @@ messageExpressions f m = case m of
|
|||
newtype DetailedTypeError s a = DetailedTypeError (TypeError s a)
|
||||
deriving (Typeable)
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a, ToTerm a) => Show (DetailedTypeError s a) where
|
||||
instance (Eq a, Pretty s, Pretty a) => Show (DetailedTypeError s a) where
|
||||
show = Pretty.renderString . Pretty.layoutPretty layoutOpts . Pretty.pretty
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a, ToTerm a, Typeable s, Typeable a) => Exception (DetailedTypeError s a)
|
||||
instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (DetailedTypeError s a)
|
||||
|
||||
instance (Eq a, Pretty s, Pretty a, ToTerm a) => Pretty (DetailedTypeError s a) where
|
||||
instance (Eq a, Pretty s, Pretty a) => Pretty (DetailedTypeError s a) where
|
||||
pretty (DetailedTypeError (TypeError ctx expr msg))
|
||||
= Pretty.unAnnotate
|
||||
( "\n"
|
||||
|
|
|
|||
|
|
@ -10,9 +10,6 @@ import Prelude hiding (FilePath)
|
|||
import Test.Tasty (TestTree)
|
||||
import Turtle (FilePath, (</>))
|
||||
|
||||
import qualified Codec.CBOR.Read as CBOR
|
||||
import qualified Codec.CBOR.Term as CBOR
|
||||
import qualified Codec.Serialise as Serialise
|
||||
import qualified Control.Monad as Monad
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
import qualified Data.ByteString as ByteString
|
||||
|
|
@ -26,6 +23,7 @@ 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
|
||||
|
|
@ -135,16 +133,16 @@ shouldParse path = do
|
|||
|
||||
expression <- Core.throws (Parser.exprFromText mempty text)
|
||||
|
||||
let term = Binary.encodeExpression expression
|
||||
let bytes = Binary.encodeExpression (Core.denote expression)
|
||||
|
||||
let bytes = Serialise.serialise term
|
||||
let render =
|
||||
concatMap (Printf.printf "%02x ")
|
||||
. ByteString.Lazy.unpack
|
||||
|
||||
Monad.unless (encoded == bytes) $ do
|
||||
("", expected) <- Core.throws (CBOR.deserialiseFromBytes CBOR.decodeTerm encoded)
|
||||
|
||||
let message = "The expected CBOR representation doesn't match the actual one\n"
|
||||
++ "expected: " ++ show expected ++ "\n but got: " ++ show term
|
||||
++ "\n expr: " ++ show expression
|
||||
++ "expected: " ++ render encoded ++ "\n but got: " ++ render bytes
|
||||
++ "\n expr: " ++ show (Core.denote expression :: Expr Void Import)
|
||||
|
||||
Tasty.HUnit.assertFailure message
|
||||
|
||||
|
|
@ -202,16 +200,29 @@ shouldNotParse path = do
|
|||
|
||||
shouldDecode :: Text -> TestTree
|
||||
shouldDecode pathText = do
|
||||
let expectedFailures = []
|
||||
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")
|
||||
|
||||
term <- Core.throws (Serialise.deserialiseOrFail bytes)
|
||||
|
||||
decodedExpression <- Core.throws (Binary.decodeExpression term)
|
||||
decodedExpression <- case Binary.decodeExpression bytes of
|
||||
Left exception ->
|
||||
Tasty.HUnit.assertFailure (show exception)
|
||||
Right decodedExpression ->
|
||||
return decodedExpression
|
||||
|
||||
text <- Text.IO.readFile (pathString <> "B.dhall")
|
||||
|
||||
|
|
@ -223,7 +234,7 @@ shouldDecode pathText = do
|
|||
let message =
|
||||
"The decoded expression didn't match the parsed expression"
|
||||
|
||||
Tasty.HUnit.assertEqual message decodedExpression strippedExpression )
|
||||
Tasty.HUnit.assertEqual message strippedExpression decodedExpression )
|
||||
|
||||
shouldNotDecode :: Text -> TestTree
|
||||
shouldNotDecode pathText = do
|
||||
|
|
@ -234,8 +245,6 @@ shouldNotDecode pathText = do
|
|||
Test.Util.testCase pathText expectedFailures (do
|
||||
bytes <- ByteString.Lazy.readFile (pathString <> ".dhallb")
|
||||
|
||||
term <- Core.throws (Serialise.deserialiseOrFail bytes)
|
||||
|
||||
case Binary.decodeExpression term :: Either Binary.DecodingFailure (Expr Void Import) of
|
||||
case Binary.decodeExpression bytes :: Either Binary.DecodingFailure (Expr Void Import) of
|
||||
Left _ -> return ()
|
||||
Right _ -> Tasty.HUnit.assertFailure "Unexpected successful decode" )
|
||||
|
|
|
|||
|
|
@ -10,10 +10,10 @@
|
|||
|
||||
module Dhall.Test.QuickCheck where
|
||||
|
||||
import Codec.Serialise (DeserialiseFailure(..))
|
||||
import Data.Either (isRight)
|
||||
import Data.Either.Validation (Validation(..))
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Void (Void)
|
||||
import Dhall (ToDhall(..), FromDhall(..), auto, extract, inject, embed, Vector)
|
||||
import Dhall.Map (Map)
|
||||
import Dhall.Core
|
||||
|
|
@ -53,8 +53,6 @@ import Test.Tasty.QuickCheck (QuickCheckTests(..))
|
|||
import Text.Megaparsec (SourcePos(..), Pos)
|
||||
|
||||
import qualified Control.Spoon
|
||||
import qualified Codec.Serialise
|
||||
import qualified Data.Coerce
|
||||
import qualified Data.List
|
||||
import qualified Data.Sequence
|
||||
import qualified Data.SpecialValues
|
||||
|
|
@ -78,13 +76,6 @@ import qualified Test.Tasty
|
|||
import qualified Test.Tasty.QuickCheck
|
||||
import qualified Text.Megaparsec as Megaparsec
|
||||
|
||||
newtype DeserialiseFailureWithEq = D DeserialiseFailure
|
||||
deriving (Show)
|
||||
|
||||
instance Eq DeserialiseFailureWithEq where
|
||||
D (DeserialiseFailure aL bL) == D (DeserialiseFailure aR bR) =
|
||||
aL == aR && bL == bR
|
||||
|
||||
instance (Arbitrary a, Ord a) => Arbitrary (Set a) where
|
||||
arbitrary = Dhall.Set.fromList <$> arbitrary
|
||||
shrink = map Dhall.Set.fromList . shrink . Dhall.Set.toList
|
||||
|
|
@ -412,21 +403,11 @@ instance Arbitrary Var where
|
|||
|
||||
binaryRoundtrip :: Expr () Import -> Property
|
||||
binaryRoundtrip expression =
|
||||
wrap
|
||||
(fmap
|
||||
Dhall.Binary.decodeExpression
|
||||
(Codec.Serialise.deserialiseOrFail
|
||||
(Codec.Serialise.serialise
|
||||
(Dhall.Binary.encodeExpression expression)
|
||||
)
|
||||
)
|
||||
)
|
||||
=== wrap (Right (Right (Dhall.Core.denote expression :: Expr () Import)))
|
||||
Dhall.Binary.decodeExpression (Dhall.Binary.encodeExpression denotedExpression)
|
||||
=== Right denotedExpression
|
||||
where
|
||||
wrap
|
||||
:: Either DeserialiseFailure a
|
||||
-> Either DeserialiseFailureWithEq a
|
||||
wrap = Data.Coerce.coerce
|
||||
denotedExpression :: Expr Void Import
|
||||
denotedExpression = Dhall.Core.denote expression
|
||||
|
||||
everythingWellTypedNormalizes :: Expr () () -> Property
|
||||
everythingWellTypedNormalizes expression =
|
||||
|
|
|
|||
Loading…
Reference in New Issue