Various fixes and additions to the testsuite (Prelude types in Plutus etc)

Author: bladyjoker

lambda-buffers-codegen/src/LambdaBuffers/Codegen/Plutarch.hs

@@ -48,4 +48,5 @@ plutarchPrintModuleEnv =
     , "DerivingStrategies"
     , "DeriveAnyClass"
     , "DeriveGeneric"
+    , "UndecidableInstances"
     ]

lambda-buffers-codegen/src/LambdaBuffers/Codegen/Purescript/Print/InstanceDef.hs

@@ -65,7 +65,7 @@ printShowInstance :: MonadPrint m => PC.TyDef -> m (Doc ann)
 printShowInstance tyd = do
   importClass showClass
   importValue genericShow
-  return $ printInstanceDef showClass (toSaturatedTyApp tyd) ("show" <+> equals <+> printPursQValName genericShow)
+  return $ printInstanceDef showClass (toSaturatedTyApp tyd) ("show x" <+> equals <+> printPursQValName genericShow <+> "x")
 
 {- | `printDerive qcn tyD` prints a Purescript `derive instance` statement for a type class `qcn` for a type definition `tyd`.
  For a `Show` type class on a `Maybe a` type definition it prints

lambda-buffers-codegen/src/LambdaBuffers/Codegen/Purescript/Print/LamVal.hs

@@ -14,7 +14,7 @@ import LambdaBuffers.Codegen.Purescript.Syntax (normalValName)
 import LambdaBuffers.Codegen.Purescript.Syntax qualified as Purs
 import LambdaBuffers.Compiler.LamTy qualified as LT
 import LambdaBuffers.ProtoCompat qualified as PC
-import Prettyprinter (Doc, Pretty (pretty), align, colon, comma, dot, dquotes, encloseSep, equals, group, hsep, lbrace, lbracket, line, lparen, parens, rbrace, rbracket, rparen, space, vsep, (<+>))
+import Prettyprinter (Doc, Pretty (pretty), align, colon, comma, dot, dquotes, encloseSep, equals, group, hardline, hsep, lbrace, lbracket, line, lparen, parens, rbrace, rbracket, rparen, space, vsep, (<+>))
 import Proto.Codegen_Fields qualified as P
 
 type MonadPrint m = LV.MonadPrint m Purs.QValName
@@ -52,11 +52,13 @@ printCaseE :: MonadPrint m => (PC.QTyName, LV.Sum) -> LV.ValueE -> ((LV.Ctor, [L
 printCaseE (qtyN, sumTy) caseVal ctorCont = do
   caseValDoc <- printValueE caseVal
   ctorCaseDocs <-
-    vsep
+    align . encloseSep mempty mempty mempty
       <$> for
         (OMap.assocs sumTy)
         ( \(cn, ty) -> case ty of -- TODO(bladyjoker): Cleanup by refactoring LT.Ty.
-            LT.TyProduct fields _ -> printCtorCase qtyN ctorCont (cn, fields)
+            LT.TyProduct fields _ -> do
+              ctorCaseDoc <- printCtorCase qtyN ctorCont (cn, fields)
+              return $ ctorCaseDoc <> hardline
             _ -> throwInternalError "Got a non-product in Sum."
         )
   return $ align $ "case" <+> caseValDoc <+> "of" <> line <> ctorCaseDocs

libs/lbf-plutus/Plutus/V1.lbf

@@ -13,7 +13,7 @@ instance Eq PlutusData
 instance Json PlutusData
 
 -- Instances for Prelude types
--- TODO(bladyjoker): Add other Prelude types (Maybe, Either, Text, Bytes etc.)
+-- TODO(bladyjoker): Add other Prelude types (Text, Bytes etc.)?
 instance PlutusData Bool
 instance PlutusData Integer
 instance PlutusData (Maybe a) :- PlutusData a

runtimes/haskell/lbr-plutarch/build.nix

@@ -57,10 +57,10 @@
           installPhase = "ln -s $src $out";
         };
 
-        # lbr-plutarch-tests = hsNixFlake.packages."lbr-plutarch:test:tests";
+        lbr-plutarch-tests = hsNixFlake.packages."lbr-plutarch:test:tests";
       };
 
-      # checks.check-lbr-plutarch = hsNixFlake.checks."lbr-plutarch:test:tests";
+      checks.check-lbr-plutarch = hsNixFlake.checks."lbr-plutarch:test:tests";
 
     };
 }

runtimes/haskell/lbr-plutus/src/LambdaBuffers/Runtime/Plutus/Json.hs

@@ -296,6 +296,29 @@ instance Json PlutusV1.TxOutRef where
           return $ PlutusV1.TxOutRef txId index
       )
 
+instance Json PlutusV1.TxOut where
+  toJson (PlutusV1.TxOut addr val datHash) = object ["address" .= toJson addr, "value" .= toJson val, "datum_hash" .= toJson datHash]
+  fromJson =
+    withObject
+      "Plutus.V1.TxOut"
+      ( \obj -> do
+          addr <- obj .: "address"
+          val <- obj .: "value"
+          datHash <- obj .: "datum_hash"
+          return $ PlutusV1.TxOut addr val datHash
+      )
+
+instance Json PlutusV1.TxInInfo where
+  toJson (PlutusV1.TxInInfo outRef out) = object ["reference" .= toJson outRef, "output" .= toJson out]
+  fromJson =
+    withObject
+      "Plutus.V1.TxInInfo"
+      ( \obj -> do
+          outRef <- obj .: "reference"
+          out <- obj .: "output"
+          return $ PlutusV1.TxInInfo outRef out
+      )
+
 instance Json PlutusV2.TxOut where
   toJson (PlutusV2.TxOut addr val dat mayRefScript) = object ["address" .= toJson addr, "value" .= toJson val, "datum" .= toJson dat, "reference_script" .= toJson mayRefScript]
   fromJson =

testsuites/lbt-plutus/api/Foo.lbf

@@ -3,7 +3,7 @@ module Foo
 import Foo.Bar
 import Plutus.V1 (PlutusData, Address, AssetClass, Bytes, Credential, CurrencySymbol, Datum, DatumHash, Extended, Interval, LowerBound, Map, POSIXTime, POSIXTimeRange, PlutusData, PubKeyHash, Redeemer, RedeemerHash, ScriptHash, StakingCredential, TokenName, TxId, TxOutRef, UpperBound, Value)
 import Plutus.V2 (OutputDatum, TxInInfo, TxOut)
-import Prelude (Eq, Json, Maybe, Either, List)
+import Prelude (Eq, Json, Maybe, Either, List, Integer)
 
 prod A = (FooSum Address Value Datum)
 
@@ -63,3 +63,15 @@ prod E a b = Address
 derive Eq (E a b)
 derive Json (E a b)
 derive PlutusData (E a b)
+
+prod FInt = (F Integer)
+
+derive Eq FInt
+derive Json FInt
+derive PlutusData FInt
+
+prod GInt = (G Integer)
+
+derive Eq GInt
+derive Json GInt
+derive PlutusData GInt

testsuites/lbt-plutus/api/Foo/Bar.lbf

@@ -29,4 +29,18 @@ record FooComplicated a b c = {
 
 derive Eq (FooComplicated a b c)
 derive Json (FooComplicated a b c)
-derive PlutusData (FooComplicated a b c)
+derive PlutusData (FooComplicated a b c)
+
+-- Making sure recursive definitions work.
+
+sum F a = Rec (G a) | Nil
+
+derive Eq (F a)
+derive Json (F a)
+derive PlutusData (F a)
+
+sum G a = Rec (F a) | Nil
+
+derive Eq (G a)
+derive Json (G a)
+derive PlutusData (G a)

testsuites/lbt-plutus/golden/Foo.FInt.0.pd.json

@@ -0,0 +1 @@
+{"fields":[1],"name":"Integer"}

testsuites/lbt-plutus/golden/Foo.FInt.1.pd.json

@@ -0,0 +1 @@
+{"fields":[{"fields":[{"fields":[1],"name":"Integer"}],"index":0}],"name":"Constr"}