script

commit 8023377605abcf906dfb209cf085ba1f6485c39f
parent f3f58ca5a3d5992afdd13b559003b0aba433dd27
Author: Jared Tobin <jared@jtobin.io>
Date:   Sat, 18 Jan 2025 21:46:58 +0400

test: fix arbitrary instance for script

Diffstat:
M
lib/Bitcoin/Prim/Script.hs
 | 
17
++++++++++-------
M
test/Main.hs
 | 
22
++++++++++------------

2 files changed, 20 insertions(+), 19 deletions(-)
diff --git a/lib/Bitcoin/Prim/Script.hs b/lib/Bitcoin/Prim/Script.hs
@@ -390,13 +390,16 @@ from_base16 b16 = do
 
 -- | Pack a list of Script terms into a 'Script'.
 to_script :: [Term] -> Script
-to_script = Script . bs_to_ba . BS.pack . fmap term_to_byte where
-  term_to_byte :: Term -> Word8
-  term_to_byte = \case
-    OPCODE !op -> fi (fromEnum op)
-    BYTE !w8 -> w8
-  {-# INLINE term_to_byte #-}
-{-# NOINLINE to_script #-} -- don't even think about it
+to_script terms =
+    let !bs = BS.pack (fmap term_to_byte terms)
+    in  Script (bs_to_ba bs)
+  where
+    term_to_byte :: Term -> Word8
+    term_to_byte = \case
+      OPCODE !op -> fi (fromEnum op)
+      BYTE !w8 -> w8
+    {-# INLINE term_to_byte #-}
+{-# NOINLINE to_script #-} -- don't even think about removing this
 
 -- | Unpack a 'Script' into a list of Script terms.
 from_script :: Script -> [Term]
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -36,9 +37,12 @@ instance Q.Arbitrary BA.ByteArray where
     b <- bytes 10_000
     pure (bs_to_ba b)
 
--- do not use for testing things intended to run on 'real' scripts
 instance Q.Arbitrary Script where
-  arbitrary = fmap Script Q.arbitrary
+  arbitrary = do
+    l <- Q.chooseInt (0, 1024)
+    -- pushdata must be added with care; easy to blow up quickcheck
+    bs <- fmap BS.pack (Q.vectorOf l (Q.chooseEnum (100, 255)))
+    pure (Script (bs_to_ba bs))
 
 -- properties -----------------------------------------------------------------
 
@@ -54,14 +58,10 @@ from_base16_inverts_to_base16 s =
 
 to_script_inverts_from_script :: Script -> Bool
 to_script_inverts_from_script s =
-  let script = to_script (from_script s)
+  let !terms  = from_script s
+      !script = to_script terms
   in  script == s
 
-foo :: Script -> Bool
-foo s =
-  let terms = from_script s
-  in  length terms >= 0
-
 -- main -----------------------------------------------------------------------
 
 main :: IO ()
@@ -71,10 +71,8 @@ main = defaultMain $
         Q.withMaxSuccess 500 ba_to_bs_inverts_bs_to_ba
     , Q.testProperty "from_base16 . to_base16 ~ id" $
         Q.withMaxSuccess 500 from_base16_inverts_to_base16
-    -- XX need better arbitrary for script; otherwise we'll push insane amounts
-    --    of data
-    -- , Q.testProperty "to_script . from_script ~ id" $
-    --     Q.withMaxSuccess 100 to_script_inverts_from_script
+    , Q.testProperty "to_script . from_script ~ id" $
+        Q.withMaxSuccess 100 to_script_inverts_from_script
     ]
 
 -- p2pkh