Pact Aeson2

.github/workflows/applications.yml

@@ -13,20 +13,20 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ['8.10.7']
-        cabal: ['3.8']
+        ghc: ['8.10.7', '9.2', '9.4.5', '9.6']
+        cabal: ['3.10']
         os: ['ubuntu-20.04', 'ubuntu-22.04', 'macOS-latest']
         cabalcache: ['true']
         flags: ['+build-tool']
         include:
         - os: 'ubuntu-22.04'
-          ghc: '8.10.7'
-          cabal: '3.8'
+          ghc: '9.6'
+          cabal: '3.10'
           cabalcache: 'true'
           flags: '-build-tool'
         - os: 'ubuntu-22.04'
           ghc: '9.0.2'
-          cabal: '3.8'
+          cabal: '3.10'
           cabalcache: 'true'
           flags: '+build-tool'
 
@@ -98,14 +98,13 @@ jobs:
           benchmarks: True
           documentation: False
           optimization: 1
-          flags: ${{ matrix.flags }}
+          flags: ${{ matrix.flags }} +cryptonite-ed25519
         EOF
     - name: Extend cabal.project.local for GHC-9.0.2
       if: "startsWith(matrix.ghc, '9')"
       shell: bash
       run: |
         cat >> cabal.project.local <<EOF
-        allow-newer: hashable:*
         package pact
           ghc-options: -Wwarn -Wunused-packages
         EOF
@@ -207,7 +206,7 @@ jobs:
       fail-fast: false
       matrix:
         include:
-        - ghc: "8.10.7"
+        - ghc: "9.6"
           os: "ubuntu-20.04"
     env:
       OS: ${{ matrix.os }}

bench/PactJson.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- |
+-- Module: PactJson
+-- Copyright: Copyright © 2023 Kadena LLC.
+-- License: MIT
+-- Maintainer: Lars Kuhtz <lars@kadena.io>
+-- Stability: experimental
+--
+-- benchmarks for pact-json
+--
+module Main
+( main
+) where
+
+import Bound
+
+import Criterion
+import Criterion.Main
+
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+
+import qualified Pact.JSON.Encode as J
+
+import System.IO.Unsafe
+
+import Test.QuickCheck
+
+-- internal modules
+import Pact.Types.Command
+import Pact.Types.Names
+import Pact.Types.RowData
+import Pact.Types.SPV
+import Pact.Types.Term
+import Pact.Types.Term.Arbitrary ()
+
+
+-- -------------------------------------------------------------------------- --
+-- Main
+
+main :: IO ()
+main = defaultMain [benchmarks]
+
+-- -------------------------------------------------------------------------- --
+-- Benchmarks
+
+benchmarks :: Benchmark
+benchmarks = bgroup "JsonEncoding"
+  [ bgroup "pact"
+    [ group "module" pactModule
+    , group "RowData" rowData
+    , group "CommandResult" commandResult
+    , group "ContProof" contProof
+    ]
+  ]
+
+group
+  :: J.Encode a
+  => String
+  -> a
+  -> Benchmark
+group l a = bgroup l
+  [ bench_encode a
+  ]
+
+-- -------------------------------------------------------------------------- --
+-- Benchmark Functions
+
+bench_encode :: J.Encode a => a -> Benchmark
+bench_encode a = bench "bench_encode" $ nf run_encode a
+
+run_encode :: J.Encode a => a -> BL.ByteString
+run_encode = J.encode
+{-# NOINLINE run_encode #-}
+
+-- -------------------------------------------------------------------------- --
+-- Orphans
+
+deriving newtype instance A.ToJSON a => A.ToJSON (J.Aeson a)
+deriving newtype instance A.FromJSON a => A.FromJSON (J.Aeson a)
+deriving newtype instance Show a => Show (J.Aeson a)
+deriving newtype instance Eq a => Eq (J.Aeson a)
+deriving newtype instance Arbitrary a => Arbitrary (J.Aeson a)
+deriving instance Functor J.Aeson
+deriving instance Foldable J.Aeson
+deriving instance Traversable J.Aeson
+
+instance J.Encode [J.Aeson ()] where
+  build a = J.build $ J.Array a
+
+instance J.Encode [Var Int [J.Aeson ()]] where
+  build a = J.build $ J.Array a
+
+-- -------------------------------------------------------------------------- --
+-- Benchmark Data
+--
+
+type A = J.Aeson
+
+pactModule :: Module Name
+pactModule = unsafeDupablePerformIO $ generate $ arbitrary
+{-# NOINLINE pactModule #-}
+
+rowData :: RowData
+rowData = unsafeDupablePerformIO $ generate $ arbitrary
+{-# NOINLINE rowData #-}
+
+commandResult :: CommandResult (A ())
+commandResult = unsafeDupablePerformIO $ generate $ arbitrary
+{-# NOINLINE commandResult #-}
+
+contProof :: ContProof
+contProof = unsafeDupablePerformIO $ generate $ arbitrary
+{-# NOINLINE contProof #-}
+

cabal.project

@@ -1,18 +1,52 @@
 packages: .
 
-allow-older: libBF:hashable
-
 -- temporary upper bounds
 constraints: sbv <10
 
 -- these upper bounds are required in order to not break payload validation in chainweb
-constraints: aeson <2
 constraints: base16-bytestring <1
-constraints: base64-bytestring <1.1
-constraints: hashable <1.3.1
 constraints: prettyprinter <1.6.1
-constraints: unordered-containers <0.2.16
+constraints: base64-bytestring <1.1
+
+allow-newer: base64-bytestring:*
+allow-newer: base16-bytestring:*
+allow-newer: prettyprinter:*
 
 -- test upper bounds
 constraints: hspec-golden <0.2,
 
+-- The following fork provides trifecta-2.`1.1.1 which is compatible with
+-- hashable >=1.4 and prettyprinter <1.7
+--
+-- trifeta >=2.1.2 requires a prettyprinter >=1.7, which isn't supported by
+-- pact (because it would break mainnet replays). trifecta ==2.1.1 does not
+-- support hashable >=1.4.
+--
+source-repository-package
+  type: git
+  tag: f991ffb74a1a1ab86f14e751d7c4f4ba549785b3
+  location: https://github.com/hackage-package-forks/trifecta
+
+source-repository-package
+  type: git
+  tag: e43073d0b8d89d9b300980913b842f4be339846d
+  location: https://github.com/kadena-io/pact-json
+
+-- Required for GHC-9.6
+
+allow-newer: *:template-haskell
+allow-newer: *:base
+
+-- Patch merged into master (upcoming verison 10.0). We are currently using 9.2
+source-repository-package
+  type: git
+  tag: b66e3a04c20f753213fe7e5115a95b3fe34109f9
+  location: https://github.com/larskuhtz/sbv
+
+-- Servant is notoriously forcing outdated upper bounds onto its users.
+-- It is usually safe to just ignore those.
+--
+allow-newer: servant-server:*
+allow-newer: servant-client-core:*
+allow-newer: servant-client:*
+allow-newer: servant:*

executables/ReplGhcjs.hs

@@ -5,12 +5,19 @@
 
 module Main where
 
+import Control.Monad.State.Strict
+
+import Data.Aeson hiding ((.=),Object)
+
 import GHCJS.Marshal
 import GHCJS.Foreign.Callback
 import GHCJS.Types
+
 import Prelude hiding (log)
 
-import Pact.Repl (evalString)
+import qualified Pact.JSON.Encode as J
+import Pact.Repl
+import Pact.Repl.Types
 
 foreign import javascript unsafe "evalCmd = $1"
     evalCmd :: Callback (JSVal -> JSVal -> IO JSVal) -> IO ()
@@ -23,3 +30,16 @@ main = do
       r <- evalString log' cmd'
       toJSVal_aeson r
     evalCmd callback
+
+-- -------------------------------------------------------------------------- --
+-- Utils
+
+evalString :: Bool -> String -> IO Value
+evalString showLog cmd = do
+  (er,s) <- initReplState StringEval Nothing >>= runStateT (evalRepl' cmd)
+  return $ J.object $ case (showLog,er) of
+    (False,Right v) -> [ "success" J..= v]
+    (True,Right _) -> ["success" J..= trim (_rOut s) ]
+    (False,Left e) -> ["failure" J..= e ]
+    (True,Left e) -> ["failure" J..= (_rOut s ++ e) ]
+