feat: initial commit of testgen-hs, random Haskell error generator

Related to #42

flake.nix

@@ -37,9 +37,12 @@
         pkgs,
         ...
       }: {
-        packages =
+        packages = let
+          internal = inputs.self.internal.${system};
+        in
           {
-            default = inputs.self.internal.${system}.package;
+            default = internal.package;
+            inherit (internal) tx-build cardano-address testgen-hs;
           }
           // (inputs.nixpkgs.lib.optionalAttrs (system == "x86_64-linux") {
             default-x86_64-windows = inputs.self.internal.x86_64-windows.package;
@@ -49,7 +52,9 @@
 
         treefmt = {pkgs, ...}: {
           projectRootFile = "flake.nix";
-          programs.alejandra.enable = true;
+          programs.alejandra.enable = true; # Nix
+          programs.ormolu.enable = true; # Haskell
+          programs.cabal-fmt.enable = true;
           programs.prettier.enable = true;
           settings.formatter.prettier.options = [
             "--config"
@@ -60,7 +65,7 @@
           ];
           programs.rustfmt.enable = true;
           programs.yamlfmt.enable = true;
-          programs.taplo.enable = true;
+          programs.taplo.enable = true; # TOML
           programs.shfmt.enable = true;
         };
       };

nix/devshells.nix

@@ -50,6 +50,11 @@ in {
       category = "handy";
       package = internal.tx-build;
     }
+    {
+      category = "handy";
+      name = "testgen-hs";
+      package = internal.testgen-hs;
+    }
   ];
 
   language.c.compiler =

nix/internal/unix.nix

@@ -125,6 +125,32 @@ in rec {
       ln -sf $out/libexec/cardano-address $out/bin/
     '';
 
+  testgen-hs = let
+    patched-flake = let
+      unpatched = inputs.cardano-node;
+    in
+      (import inputs.flake-compat {
+        src = {
+          outPath = toString (pkgs.runCommandNoCC "source" {} ''
+            cp -r ${unpatched} $out
+            chmod -R +w $out
+            cd $out
+            echo ${lib.escapeShellArg (builtins.toJSON [targetSystem])} $out/nix/supported-systems.nix
+            cp -r ${../../testgen-hs} ./testgen-hs
+            sed -r '/^packages:/ a\  testgen-hs' -i cabal.project
+          '');
+          inherit (unpatched) rev shortRev lastModified lastModifiedDate;
+        };
+      })
+      .defaultNix;
+  in
+    {
+      x86_64-linux = patched-flake.hydraJobs.x86_64-linux.musl.testgen-hs;
+      x86_64-darwin = patched-flake.packages.x86_64-darwin.testgen-hs;
+      aarch64-darwin = patched-flake.packages.aarch64-darwin.testgen-hs;
+    }
+    .${targetSystem};
+
   tx-build = let
     onPath = with pkgs; [
       bash

testgen-hs/CLI.hs

@@ -0,0 +1,105 @@
+module CLI (Options (..), Seed (..), GenSize (..), NumCases (..), Command (..), parse) where
+
+import Options.Applicative as O
+
+newtype Seed = Seed Int deriving (Show)
+
+newtype GenSize = GenSize Int deriving (Show)
+
+newtype NumCases = NumCases Int deriving (Show)
+
+data Options = Options (Maybe Seed) GenSize NumCases Command deriving (Show)
+
+data Command
+  = GHCInteger
+  | DataText
+  | ExampleADT
+  | TxValidationErrorInCardanoMode
+  | ApplyTxError'Byron
+  | ApplyTxError'Shelley
+  | ApplyTxError'Allegra
+  | ApplyTxError'Mary
+  | ApplyTxError'Alonzo
+  | ApplyTxError'Babbage
+  | ApplyTxError'Conway
+  deriving (Show)
+
+parse :: IO Options
+parse = execParser opts
+
+-------------------------------------------------------------------------------------
+
+opts :: ParserInfo Options
+opts =
+  info
+    (optionsParser <**> helper)
+    ( fullDesc
+        <> progDesc "Test case generator for cross-checking CBOR (de)serializers"
+    )
+
+optionsParser :: Parser Options
+optionsParser =
+  Options
+    <$> optional
+      ( Seed
+          <$> option
+            auto
+            ( long "seed"
+                <> short 's'
+                <> metavar "SEED"
+                <> help "Random seed integer (UNIX timestamp by default)"
+            )
+      )
+    <*> ( GenSize
+            <$> option
+              auto
+              ( long "generator-size"
+                  <> short 'g'
+                  <> metavar "SIZE"
+                  <> value 300
+                  <> help "Set the relative ‘size’ of the test cases"
+              )
+        )
+    <*> ( NumCases
+            <$> option
+              positive
+              ( long "number"
+                  <> short 'n'
+                  <> metavar "NUM"
+                  <> value 10
+                  <> help "How many test cases to generate"
+              )
+        )
+    <*> commandParser
+
+positive :: ReadM Int
+positive = do
+  n <- auto
+  if n > 0
+    then return n
+    else readerError "NUM must be positive"
+
+commandParser :: Parser Command
+commandParser =
+  subparser
+    ( mempty
+        <> mkCommand ApplyTxError'Byron
+        <> mkCommand ApplyTxError'Shelley
+        <> mkCommand ApplyTxError'Allegra
+        <> mkCommand ApplyTxError'Mary
+        <> mkCommand ApplyTxError'Alonzo
+        <> mkCommand ApplyTxError'Babbage
+        <> mkCommand ApplyTxError'Conway
+        <> mkCommand TxValidationErrorInCardanoMode
+        <> mkCommand GHCInteger
+        <> mkCommand DataText
+        <> mkCommand ExampleADT
+    )
+
+mkCommand :: Command -> Mod CommandFields Command
+mkCommand cmd =
+  command
+    (replaceQuotes . show $ cmd)
+    (info (pure cmd) (progDesc ("Generate CBOR of " ++ show cmd)))
+  where
+    replaceQuotes = ((\c -> if c == '\'' then '_' else c) <$>)

testgen-hs/Generators.hs

@@ -0,0 +1,147 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Generators where
+
+import qualified Cardano.Api.Eon.ShelleyBasedEra as CAPI
+import qualified Cardano.Api.Eras.Core as CAPI
+import qualified Cardano.Api.InMode as CAPI
+import qualified Cardano.Api.Modes as CAPI
+import Cardano.Api.Orphans ()
+import Cardano.Binary (FromCBOR (..), ToCBOR (..))
+import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
+import Codec.Serialise (Serialise)
+import qualified Codec.Serialise
+import Data.Aeson (ToJSON)
+import GHC.Generics (Generic)
+import Generic.Random (GenericArbitraryU (..))
+import qualified Ouroboros.Consensus.Byron.Ledger as Consensus
+import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as O
+import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Consensus
+import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
+import Test.Consensus.Cardano.Generators ()
+import Test.QuickCheck (Arbitrary)
+import qualified Test.QuickCheck as QC
+
+genTxValidationErrorInCardanoMode :: QC.Gen CAPI.TxValidationErrorInCardanoMode
+genTxValidationErrorInCardanoMode = QC.arbitrary
+
+-- FIXME: where is it originally???
+-- FIXME: maybe here? https://github.com/IntersectMBO/ouroboros-consensus/blob/358305b09f8fa1a85f076b20a51b4af03e827071/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs#L175-L178
+-- instance ToCBOR CAPI.TxValidationErrorInCardanoMode where
+--   toCBOR
+-- deriving instance EncCBOR CAPI.TxValidationErrorInCardanoMode
+
+genApplyTxError'Byron :: QC.Gen (Consensus.ApplyTxErr Consensus.ByronBlock)
+genApplyTxError'Byron = QC.arbitrary
+
+genApplyTxError'Shelley ::
+  QC.Gen
+    ( Consensus.ApplyTxErr
+        ( Consensus.ShelleyBlock
+            (CAPI.ConsensusProtocol CAPI.ShelleyEra)
+            (CAPI.ShelleyLedgerEra CAPI.ShelleyEra)
+        )
+    )
+genApplyTxError'Shelley = QC.arbitrary
+
+genApplyTxError'Allegra ::
+  QC.Gen
+    ( Consensus.ApplyTxErr
+        ( Consensus.ShelleyBlock
+            (CAPI.ConsensusProtocol CAPI.AllegraEra)
+            (CAPI.ShelleyLedgerEra CAPI.AllegraEra)
+        )
+    )
+genApplyTxError'Allegra = QC.arbitrary
+
+genApplyTxError'Mary ::
+  QC.Gen
+    ( Consensus.ApplyTxErr
+        ( Consensus.ShelleyBlock
+            (CAPI.ConsensusProtocol CAPI.MaryEra)
+            (CAPI.ShelleyLedgerEra CAPI.MaryEra)
+        )
+    )
+genApplyTxError'Mary = QC.arbitrary
+
+genApplyTxError'Alonzo ::
+  QC.Gen
+    ( Consensus.ApplyTxErr
+        ( Consensus.ShelleyBlock
+            (CAPI.ConsensusProtocol CAPI.AlonzoEra)
+            (CAPI.ShelleyLedgerEra CAPI.AlonzoEra)
+        )
+    )
+genApplyTxError'Alonzo = QC.arbitrary
+
+genApplyTxError'Babbage ::
+  QC.Gen
+    ( Consensus.ApplyTxErr
+        ( Consensus.ShelleyBlock
+            (CAPI.ConsensusProtocol CAPI.BabbageEra)
+            (CAPI.ShelleyLedgerEra CAPI.BabbageEra)
+        )
+    )
+genApplyTxError'Babbage = QC.arbitrary
+
+genApplyTxError'Conway ::
+  QC.Gen
+    ( Consensus.ApplyTxErr
+        ( Consensus.ShelleyBlock
+            (CAPI.ConsensusProtocol CAPI.ConwayEra)
+            (CAPI.ShelleyLedgerEra CAPI.ConwayEra)
+        )
+    )
+genApplyTxError'Conway = QC.arbitrary
+
+instance Arbitrary CAPI.TxValidationErrorInCardanoMode where
+  arbitrary =
+    QC.frequency
+      [ ( 5,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ByronTxValidationError
+            <$> genApplyTxError'Byron
+        ),
+        ( 5,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ShelleyTxValidationError CAPI.ShelleyBasedEraShelley
+            <$> genApplyTxError'Shelley
+        ),
+        ( 5,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ShelleyTxValidationError CAPI.ShelleyBasedEraAllegra
+            <$> genApplyTxError'Allegra
+        ),
+        ( 5,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ShelleyTxValidationError CAPI.ShelleyBasedEraMary
+            <$> genApplyTxError'Mary
+        ),
+        ( 5,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ShelleyTxValidationError CAPI.ShelleyBasedEraAlonzo
+            <$> genApplyTxError'Alonzo
+        ),
+        ( 5,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ShelleyTxValidationError CAPI.ShelleyBasedEraBabbage
+            <$> genApplyTxError'Babbage
+        ),
+        ( 15,
+          CAPI.TxValidationErrorInCardanoMode . CAPI.ShelleyTxValidationError CAPI.ShelleyBasedEraConway
+            <$> genApplyTxError'Conway
+        ),
+        (5, CAPI.TxValidationEraMismatch <$> QC.arbitrary)
+      ]
+
+instance Arbitrary O.EraMismatch where
+  arbitrary = do
+    (a, b) <- QC.oneof [pure ("Byron", "Shelley"), pure ("Shelley", "Byron")]
+    pure (O.EraMismatch a b)
+
+data ExampleADT
+  = SAOne Integer
+  | SATwo String
+  | SAThree Double
+  deriving (Eq, Show, Generic, ToJSON, Serialise, EncCBOR, DecCBOR)
+  deriving (Arbitrary) via (GenericArbitraryU ExampleADT)
+
+instance FromCBOR ExampleADT where
+  fromCBOR = Codec.Serialise.decode
+
+instance ToCBOR ExampleADT where
+  toCBOR = Codec.Serialise.encode