Add Flat encoding test coverage across all packages

plutus-core/changelog.d/20260318_173434_yuriy.lazaryev_flat_test_coverage.md

@@ -0,0 +1,6 @@
+### Added
+
+- Roundtrip and stable byte encoding tests for all Flat instances across
+  flat, plutus-core, plutus-ir, and untyped-plutus-core packages.
+- Standalone encoding generator executable (`cabal run flat-encoding-generator`)
+  for reproducing expected byte constants.

plutus-core/flat/test/Spec.hs

@@ -1,3 +1,4 @@
+{- FOURMOLU_DISABLE -}
 {-# LANGUAGE BinaryLiterals            #-}
 {-# LANGUAGE CPP                       #-}
 {-# LANGUAGE FlexibleContexts          #-}
@@ -42,21 +43,29 @@ import Test.E
 import Test.E.Arbitrary ()
 import Test.E.Flat
 import Test.Tasty
+import Test.Tasty.Golden (goldenVsStringDiff)
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck as QC hiding (getSize)
 -- import Test.QuickCheck.Arbitrary
 import Data.Complex qualified as B
+import Data.Fixed qualified as DF
+import Data.Functor.Identity (Identity (..))
 import Data.IntMap.Lazy qualified as CL
 import Data.IntMap.Strict qualified as CS
 import Data.Map qualified as C
 import Data.Map.Lazy qualified as CL
 import Data.Map.Strict qualified as CS
+import Data.Monoid qualified as Monoid
 import Data.Ratio qualified as B
+import Data.Semigroup qualified as Semigroup
+import Data.Set qualified as DSet
+import Data.Tree qualified as DTree
 -- import           Data.List
 -- import           Data.Ord
 #if MIN_VERSION_base(4,9,0)
 import Data.List.NonEmpty qualified as BI
 #endif
+import PlutusCore.Flat.Filler (Filler (..), PreAligned, preAligned)
 
 instance Arbitrary UTF8Text where
   arbitrary = UTF8Text <$> arbitrary
@@ -106,7 +115,13 @@ testEncDec = testGroup
 
 testFlat = testGroup
   "flat/unflat"
-  [testSize, testLargeEnum, testContainers, flatUnflatRT, flatTests]
+  [ testSize
+  , testLargeEnum
+  , testContainers
+  , flatUnflatRT
+  , flatTests
+  , testEncodingStability
+  ]
 
 -- Flat.Endian tests (to run, need to modify imports and cabal file)
 testEndian = testGroup
@@ -383,6 +398,31 @@ testContainers =
   testGroup "containers" [trip longSeq, trip dataMap, trip listMap]
 
     -- , trip intMap
+
+-- | Stable byte encoding tests for flat library container/composite types.
+-- Wrapper types (Identity, All, Any, Dual, etc.) only have roundtrip tests
+-- since their encoding stability is not critical (they are never on-chain).
+-- Use @cabal test flat-test --test-options --accept@ to update golden files.
+testEncodingStability =
+  goldenVsStringDiff "stable byte encodings"
+    (\expected actual -> ["diff", "-u", expected, actual])
+    "flat/test/golden/encoding-stability.golden"
+    (pure . L.pack . map (fromIntegral . ord) $ unlines
+      [ enc "Nothing :: Maybe Bool" (Nothing :: Maybe Bool)
+      , enc "Just True :: Maybe Bool" (Just True :: Maybe Bool)
+      , enc "Right () :: Either Bool ()" (Right () :: Either Bool ())
+      , enc "True :| [False]" (True BI.:| [False])
+      , enc "4 :+ 2 :: Complex Word8" (4 B.:+ 2 :: B.Complex Word8)
+      , enc "3 % 4 :: Ratio Word8" (3 B.% 4 :: B.Ratio Word8)
+      , enc "Set.fromList [1,2,3] :: Set Word8" (DSet.fromList [1, 2, 3] :: DSet.Set Word8)
+      , enc "Node 1 [Node 2 []] :: Tree Word8" (DTree.Node 1 [DTree.Node 2 []] :: DTree.Tree Word8)
+      , enc "fromList [(1,True)] :: Map Int Bool" (C.fromList [(1 :: Int, True)])
+      , enc "Seq.fromList [1,2] :: Seq Word8" (Seq.fromList [1, 2] :: Seq.Seq Word8)
+      , enc "FillerEnd" FillerEnd
+      , enc "preAligned 42 :: PreAligned Word8" (preAligned (42 :: Word8))
+      ])
+  where
+    enc label v = label ++ " = " ++ show (serRaw v)
 flatUnflatRT = testGroup
   "unflat (flat v) == v"
   [ rt "()" (prop_Flat_roundtrip :: RT ())
@@ -438,7 +478,27 @@ flatUnflatRT = testGroup
   , rt "B" (prop_Flat_roundtrip :: RT B)
     -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool))
     -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N))
-  , rt "List N" (prop_Flat_roundtrip :: RT (List N))]
+  , rt "List N" (prop_Flat_roundtrip :: RT (List N))
+  , rt "Tree Word8" (prop_Flat_roundtrip :: RT (DTree.Tree Word8))
+  , rt "Set Word8" (prop_Flat_roundtrip :: RT (DSet.Set Word8))
+  , rt "Identity Bool" (prop_Flat_roundtrip :: RT (Identity Bool))
+  , rt "Monoid.All" (prop_Flat_roundtrip :: RT Monoid.All)
+  , rt "Monoid.Any" (prop_Flat_roundtrip :: RT Monoid.Any)
+  , rt "Monoid.Dual Word8" (prop_Flat_roundtrip :: RT (Monoid.Dual Word8))
+  , rt "Monoid.Sum Int" (prop_Flat_roundtrip :: RT (Monoid.Sum Int))
+  , rt "Monoid.Product Int" (prop_Flat_roundtrip :: RT (Monoid.Product Int))
+  , rt "Semigroup.Min Int" (prop_Flat_roundtrip :: RT (Semigroup.Min Int))
+  , rt "Semigroup.Max Int" (prop_Flat_roundtrip :: RT (Semigroup.Max Int))
+  , rt "Semigroup.First Word8" (prop_Flat_roundtrip :: RT (Semigroup.First Word8))
+  , rt "Semigroup.Last Word8" (prop_Flat_roundtrip :: RT (Semigroup.Last Word8))
+  , rt "Monoid.Alt Maybe Bool" (prop_Flat_roundtrip :: RT (Monoid.Alt Maybe Bool))
+  , rt "DF.Fixed DF.E0" (prop_Flat_roundtrip :: RT (DF.Fixed DF.E0))
+  , testCase "PreAligned roundtrip" test_preAlignedRoundtrip
+  , testCase "String roundtrip \"hello world\"" $
+      (unflat (flat "hello world" :: B.ByteString) :: Decoded String) @?= Right "hello world"
+  , testCase "String roundtrip \"\"" $
+      (unflat (flat "" :: B.ByteString) :: Decoded String) @?= Right ""
+  ]
 
 rt n = QC.testProperty (unwords ["round trip", n])
 
@@ -823,6 +883,33 @@ prop_common_unsigned n _ = let n2 :: h = fromIntegral n
 -- b1 = BLOB UTF8 (preAligned (List255 [97,98,99]))
 -- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))
 
-
-
+-- Arbitrary instances for Semigroup wrappers not provided by QuickCheck.
+-- QuickCheck provides: Identity, Dual, Sum, Product, All, Any, Alt, Fixed,
+-- Monoid.First, Monoid.Last. But not these Semigroup wrappers:
+instance Arbitrary a => Arbitrary (Semigroup.Min a) where
+  arbitrary = Semigroup.Min <$> arbitrary
+  shrink (Semigroup.Min x) = Semigroup.Min <$> shrink x
+
+instance Arbitrary a => Arbitrary (Semigroup.Max a) where
+  arbitrary = Semigroup.Max <$> arbitrary
+  shrink (Semigroup.Max x) = Semigroup.Max <$> shrink x
+
+instance Arbitrary a => Arbitrary (Semigroup.First a) where
+  arbitrary = Semigroup.First <$> arbitrary
+  shrink (Semigroup.First x) = Semigroup.First <$> shrink x
+
+instance Arbitrary a => Arbitrary (Semigroup.Last a) where
+  arbitrary = Semigroup.Last <$> arbitrary
+  shrink (Semigroup.Last x) = Semigroup.Last <$> shrink x
+
+-- | PreAligned roundtrip: the filler may change after re-encoding,
+-- so we only check the inner value survives.
+test_preAlignedRoundtrip :: Assertion
+test_preAlignedRoundtrip = do
+  let v = preAligned (42 :: Word8)
+      encoded = flat v :: B.ByteString
+      decoded = unflat encoded :: Decoded (PreAligned Word8)
+  case decoded of
+    Right pa -> preValue pa @?= 42
+    Left err -> assertFailure $ "decode failed: " ++ show err
 

plutus-core/flat/test/golden/encoding-stability.golden

@@ -0,0 +1,12 @@
+Nothing :: Maybe Bool = [0]
+Just True :: Maybe Bool = [192]
+Right () :: Either Bool () = [128]
+True :| [False] = [192]
+4 :+ 2 :: Complex Word8 = [4,2]
+3 % 4 :: Ratio Word8 = [3,4]
+Set.fromList [1,2,3] :: Set Word8 = [128,192,160,96]
+Node 1 [Node 2 []] :: Tree Word8 = [1,129,0]
+fromList [(1,True)] :: Map Int Bool = [129,64]
+Seq.fromList [1,2] :: Seq Word8 = [128,192,128]
+FillerEnd = [1]
+preAligned 42 :: PreAligned Word8 = [1,42]

plutus-core/plutus-core.cabal

@@ -375,6 +375,7 @@ test-suite plutus-core-test
     CostModelSafety.Spec
     Evaluation.Machines
     Evaluation.Spec
+    Flat.Spec
     Generators.QuickCheck.Utils
     Names.Spec
     Normalization.Check
@@ -935,6 +936,7 @@ executable print-cost-model
     , bytestring
     , plutus-core  ^>=1.60
 
+-- Golden file generator for Flat encoding stability tests.
 ----------------------------------------------
 -- satint
 ----------------------------------------------
@@ -1129,6 +1131,7 @@ test-suite flat-test
     , QuickCheck
     , quickcheck-text
     , tasty
+    , tasty-golden
     , tasty-hunit
     , tasty-quickcheck
     , text

plutus-core/plutus-core/test/Flat/Spec.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Flat.Spec (tests) where
+
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Set qualified as Set
+import Data.Word (Word8)
+import PlutusCore
+  ( Kind (..)
+  , Name (..)
+  , Normalized (..)
+  , TyName (..)
+  , Unique (..)
+  , Version (..)
+  )
+import PlutusCore.Annotation (SrcSpan (..), SrcSpans (..))
+import PlutusCore.DeBruijn
+  ( DeBruijn (..)
+  , Index (..)
+  , NamedDeBruijn (..)
+  , NamedTyDeBruijn (..)
+  , TyDeBruijn (..)
+  , toFake
+  )
+import PlutusCore.Default (DefaultFun (..), DefaultUni (..))
+import PlutusCore.Flat qualified as Flat
+import PlutusCore.Flat.Bits (asBytes, bits)
+import Test.Tasty
+import Test.Tasty.Golden (goldenVsStringDiff)
+import Test.Tasty.HUnit
+import Universe (SomeTypeIn (..))
+
+flatBytes :: Flat.Flat a => a -> [Word8]
+flatBytes = asBytes . bits
+
+enc :: Flat.Flat a => String -> a -> String
+enc label v = label ++ " = " ++ show (flatBytes v)
+
+{-| Stable byte encoding tests for TPLC types.
+These capture the exact byte representation to detect encoding changes.
+Use @cabal test plutus-core-test --test-options --accept@ to update golden files. -}
+test_flatStaticEncoding :: TestTree
+test_flatStaticEncoding =
+  goldenVsStringDiff
+    "Flat stable encoding"
+    (\expected actual -> ["diff", "-u", expected, actual])
+    "plutus-core/test/Flat/golden/encoding-stability.golden"
+    ( pure . LBS.pack $
+        unlines
+          [ "-- Core types"
+          , enc "Version 1 1 0" (Version 1 1 0)
+          , enc "Name \"x\" (Unique 0)" (Name "x" (Unique 0))
+          , enc "Kind: Type ()" (Type () :: Kind ())
+          , enc "DeBruijn (Index 1)" (DeBruijn (Index 1))
+          , enc "NamedDeBruijn \"x\" (Index 42)" (NamedDeBruijn "x" (Index 42))
+          , enc "Index 1" (Index 1)
+          , enc "SrcSpan \"f\" 1 2 3 4" (SrcSpan "f" 1 2 3 4)
+          , let sp = SrcSpan "f" 1 2 3 4
+             in enc "SrcSpans (Set.fromList [sp])" (SrcSpans (Set.fromList [sp]))
+          , ""
+          , "-- DefaultFun"
+          , enc "AddInteger" AddInteger
+          , enc "SubtractInteger" SubtractInteger
+          , ""
+          , "-- DefaultUni"
+          , enc "SomeTypeIn DefaultUniInteger" (SomeTypeIn DefaultUniInteger)
+          ]
+    )
+
+-- | Roundtrip tests for TPLC types.
+test_flatRoundtrip :: TestTree
+test_flatRoundtrip =
+  testGroup
+    "Flat roundtrip"
+    [ testCase "SrcSpan" $
+        let sp = SrcSpan "f" 1 2 3 4
+         in Flat.unflat (Flat.flat sp) @?= Right sp
+    , testCase "SrcSpans" $
+        let sp = SrcSpan "test.hs" 1 2 3 4
+            sps = SrcSpans (Set.fromList [sp])
+         in Flat.unflat (Flat.flat sps) @?= Right sps
+    , testCase "NamedDeBruijn" $
+        let ndb = NamedDeBruijn "x" (Index 42)
+         in Flat.unflat (Flat.flat ndb) @?= Right ndb
+    , testCase "Version" $
+        let v = Version 1 1 0
+         in Flat.unflat (Flat.flat v) @?= Right v
+    , testCase "Name" $
+        let n = Name "x" (Unique 0)
+         in Flat.unflat (Flat.flat n) @?= Right n
+    , testCase "Kind Type ()" $
+        let k = Type () :: Kind ()
+         in Flat.unflat (Flat.flat k) @?= Right k
+    ]
+
+{-| Tests for newtype wrappers: verify they encode the same as their
+underlying type and roundtrip correctly.
+Note: Binder tests are in the UPLC testlib (Flat.Spec) since Binder
+is not publicly exported from plutus-core. -}
+test_flatNewtypeWrappers :: TestTree
+test_flatNewtypeWrappers =
+  testGroup
+    "Flat newtype wrappers"
+    [ testGroup
+        "Roundtrip"
+        [ testCase "TyName" $
+            let v = TyName (Name "x" (Unique 0))
+             in Flat.unflat (Flat.flat v) @?= Right v
+        , testCase "Unique" $
+            let v = Unique 42
+             in Flat.unflat (Flat.flat v) @?= Right v
+        , testCase "TyDeBruijn" $
+            let v = TyDeBruijn (DeBruijn (Index 1))
+             in Flat.unflat (Flat.flat v) @?= Right v
+        , testCase "NamedTyDeBruijn" $
+            let v = NamedTyDeBruijn (NamedDeBruijn "x" (Index 42))
+             in Flat.unflat (Flat.flat v) @?= Right v
+        , testCase "Normalized" $
+            let v = Normalized True
+             in Flat.unflat (Flat.flat v) @?= Right v
+        , testCase "FakeNamedDeBruijn" $
+            let v = toFake (DeBruijn (Index 1))
+             in Flat.unflat (Flat.flat v) @?= Right v
+        ]
+    , testGroup
+        "Encoding delegation"
+        [ testCase "TyName encodes same as Name" $
+            flatBytes (TyName (Name "x" (Unique 0)))
+              @?= flatBytes (Name "x" (Unique 0))
+        , testCase "TyDeBruijn encodes same as DeBruijn" $
+            flatBytes (TyDeBruijn (DeBruijn (Index 1)))
+              @?= flatBytes (DeBruijn (Index 1))
+        , testCase "NamedTyDeBruijn encodes same as NamedDeBruijn" $
+            flatBytes (NamedTyDeBruijn (NamedDeBruijn "x" (Index 42)))
+              @?= flatBytes (NamedDeBruijn "x" (Index 42))
+        , testCase "FakeNamedDeBruijn encodes same as DeBruijn" $
+            flatBytes (toFake (DeBruijn (Index 1)))
+              @?= flatBytes (DeBruijn (Index 1))
+        ]
+    ]
+
+-- | Combined test tree.
+tests :: TestTree
+tests =
+  testGroup
+    "Flat serialization"
+    [ test_flatStaticEncoding
+    , test_flatRoundtrip
+    , test_flatNewtypeWrappers
+    ]

plutus-core/plutus-core/test/Flat/golden/encoding-stability.golden

@@ -0,0 +1,16 @@
+-- Core types
+Version 1 1 0 = [1,1,0]
+Name "x" (Unique 0) = [1,1,120,0,0]
+Kind: Type () = [0]
+DeBruijn (Index 1) = [1]
+NamedDeBruijn "x" (Index 42) = [1,1,120,0,42]
+Index 1 = [1]
+SrcSpan "f" 1 2 3 4 = [179,0,129,1,130,0]
+SrcSpans (Set.fromList [sp]) = [217,128,64,128,193,0]
+
+-- DefaultFun
+AddInteger = [0]
+SubtractInteger = [2]
+
+-- DefaultUni
+SomeTypeIn DefaultUniInteger = [128]

plutus-core/plutus-core/test/Spec.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Main
   ( main
@@ -16,6 +15,7 @@ import Check.Spec qualified as Check
 import CostModelInterface.Spec
 import CostModelSafety.Spec
 import Evaluation.Spec (test_evaluation)
+import Flat.Spec qualified as FlatSpec
 import Generators.QuickCheck.Utils (test_utils)
 import Names.Spec
 import Normalization.Check
@@ -269,4 +269,5 @@ allTests plcFiles rwFiles typeFiles typeErrorFiles =
     , Parser.tests
     , Value.tests
     , test_utils
+    , FlatSpec.tests
     ]

plutus-core/plutus-core/test/Value/Spec.hs

@@ -17,6 +17,7 @@ import Data.Maybe
 import Safe.Foldable (maximumMay)
 import Test.QuickCheck
 import Test.Tasty
+import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 
 import PlutusCore.Builtin (BuiltinResult (..))
@@ -558,4 +559,10 @@ tests =
     , testProperty
         "cborDecodeZeroQuantity"
         prop_cborDecodeZeroQuantity
+    , testCase "K encodes as ByteString" $
+        let Just myK = V.k "abc"
+         in Flat.flat myK @?= Flat.flat ("abc" :: ByteString)
+    , testCase "Quantity encodes as Integer" $
+        let Just myQ = V.quantity 42
+         in Flat.flat myQ @?= Flat.flat (42 :: Integer)
     ]