Merge pull request #359 from zkFold/TurtlePU/UPLC-tests

Simple UPLC Converter tests
zkFold · Nov 15, 2024 · 6da2598 · 6da2598
2 parents 365ab2a + 2823ff6
commit 6da2598
Show file tree

Hide file tree

Showing 4 changed files with 109 additions and 12 deletions.
diff --git a/symbolic-base/src/ZkFold/Symbolic/Data/Maybe.hs b/symbolic-base/src/ZkFold/Symbolic/Data/Maybe.hs
@@ -81,7 +81,7 @@ maybe :: forall a b c .
     (Symbolic c, SymbolicData b, Context b ~ c) =>
     (Representable (Layout b), Traversable (Layout b)) =>
     b -> (a -> b) -> Maybe c a -> b
-maybe d h x@(Maybe _ v) = bool @(Bool c) d (h v) $ isNothing x
+maybe d h x@(Maybe _ v) = bool @(Bool c) d (h v) $ isJust x
 
 find :: forall a c t .
     (Symbolic c, SymbolicData a, Context a ~ c, Support a ~ Proxy c) =>

diff --git a/zkfold-uplc/src/ZkFold/Symbolic/UPLC/Converter.hs b/zkfold-uplc/src/ZkFold/Symbolic/UPLC/Converter.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 
-module ZkFold.Symbolic.UPLC.Converter (ScriptType (..), SomeCircuit (..), convert) where
+module ZkFold.Symbolic.UPLC.Converter where
 
 import           Data.Function                               (($))
 import           GHC.Generics                                (Par1)

diff --git a/zkfold-uplc/test/Test.hs b/zkfold-uplc/test/Test.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds   #-}
+{-# LANGUAGE TypeOperators    #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+import           Control.Applicative                         ((<*>))
+import           Control.Monad                               (return)
+import           Data.Eq                                     (Eq)
+import           Data.Function                               (const, ($))
+import           Data.Functor                                (Functor, (<$>))
+import           GHC.Generics                                (Par1 (..), U1 (..), (:*:) (..))
+import           System.IO                                   (IO)
+import           Test.Hspec                                  (describe, hspec)
+import           Test.Hspec.QuickCheck                       (prop)
+import           Test.QuickCheck
+import           Text.Show                                   (Show)
+
+import           ZkFold.Base.Algebra.Basic.Field             (Zp)
+import           ZkFold.Base.Algebra.EllipticCurve.BLS12_381 (BLS12_381_Base)
+import           ZkFold.Symbolic.Compiler                    (ArithmeticCircuit, compile)
+import           ZkFold.Symbolic.Compiler.ArithmeticCircuit  (eval)
+import           ZkFold.Symbolic.Data.Bool                   (false, true)
+import           ZkFold.Symbolic.Data.Class                  (SymbolicData (..))
+import           ZkFold.Symbolic.Data.Input                  (SymbolicInput)
+import           ZkFold.Symbolic.UPLC.Converter              (contractV3)
+import           ZkFold.UPLC.BuiltinFunction
+import           ZkFold.UPLC.Term
+
+areSame ::
+  ( SymbolicData f, Context f ~ c, Support f ~ s, Layout f ~ l
+  , c ~ ArithmeticCircuit a i, Arbitrary (i a), Show (i a)
+  , SymbolicInput s, Context s ~ c, Layout s ~ i
+  , Functor l, Eq (l a), Show (l a)
+  , a ~ Zp BLS12_381_Base) =>
+  (Term -> f) -> Term -> f -> Property
+areSame v t f =
+  let acT = compile (v t)
+      acF = compile f
+   in property $ \i -> eval acT i === eval acF i
+
+instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary ((f :*: g) a) where
+  arbitrary = (:*:) <$> arbitrary <*> arbitrary
+
+instance Arbitrary (U1 a) where
+  arbitrary = return U1
+
+instance Arbitrary a => Arbitrary (Par1 a) where
+  arbitrary = Par1 <$> arbitrary
+
+tFalse, tTrue, tUnit :: Term
+tFalse = TConstant (CBool false)
+tTrue = TConstant (CBool true)
+tUnit = TConstant (CUnit ())
+
+infixl 1 $$
+($$) :: Term -> Term -> Term
+($$) = TApp
+
+main :: IO ()
+main = hspec $ describe "UPLC tests" $ do
+  prop "false is ok" $ areSame contractV3 (TLam tFalse) (const true)
+  prop "error is not ok" $ areSame contractV3 (TLam TError) (const false)
+  prop "substitution is ok" $
+    areSame contractV3 (TLam $ TLam (TVariable 0) $$ tTrue) (const true)
+  prop "pair is ok" $ areSame contractV3
+    (TLam $ TBuiltin (BFPoly FstPair) $$ TConstant (CPair (CUnit ()) (CBool false)))
+    (const true)
+  prop "bool is not a pair" $
+    areSame contractV3 (TLam $ TBuiltin (BFPoly SndPair) $$ tTrue) (const false)
+  prop "trivial if if ok" $ areSame contractV3
+    (TLam $ TBuiltin (BFPoly IfThenElse) $$ tTrue $$ tTrue $$ tFalse)
+    (const true)
+  prop "lazy error in if is ok" $ areSame contractV3
+    (TLam $ TBuiltin (BFPoly IfThenElse) $$ tTrue $$ tUnit $$ TError)
+    (const true)
+  prop "error propagation in if" $ areSame contractV3
+    (TLam $ TBuiltin (BFPoly IfThenElse) $$ tFalse $$ tUnit $$ TError)
+    (const false)
+  prop "if as an argument is ok" $ areSame contractV3
+    (TLam $ TLam (TVariable 0 $$ tTrue $$ tUnit $$ TError) $$ TBuiltin (BFPoly IfThenElse))
+    (const true)
diff --git a/zkfold-uplc/zkfold-uplc.cabal b/zkfold-uplc/zkfold-uplc.cabal
@@ -21,7 +21,20 @@ Flag Pedantic
     Manual: True
     Default: False
 
+common options
+    default-language:   Haskell2010
+    default-extensions:
+      NoImplicitPrelude
+    ghc-options:
+      -Wall
+      -O2
+      -threaded
+    if flag(Pedantic)
+      ghc-options:
+        -Werror
+
 library
+    import:             options
     exposed-modules:
       ZkFold.Symbolic.UPLC.Converter
       ZkFold.Symbolic.UPLC.Data
@@ -36,13 +49,15 @@ library
       symbolic-base,
       text
     hs-source-dirs:     src
-    default-language:   Haskell2010
-    default-extensions:
-      NoImplicitPrelude
-    ghc-options:
-      -Wall
-      -O2
-      -threaded
-    if flag(Pedantic)
-      ghc-options:
-        -Werror
+
+test-suite zkfold-uplc-test
+    import:             options
+    type:               exitcode-stdio-1.0
+    main-is:            Test.hs
+    build-depends:
+      base         ,
+      hspec        ,
+      symbolic-base,
+      QuickCheck   ,
+      zkfold-uplc
+    hs-source-dirs:     test