feedback for PR #6173

Author: mgmeier

bench/cardano-profile/src/Cardano/Benchmarking/Profile.hs

@@ -12,6 +12,7 @@ module Cardano.Benchmarking.Profile
 
 import           Prelude
 import           Control.Monad (foldM)
+import           Data.Maybe (catMaybes)
 import           System.IO.Unsafe (unsafePerformIO)
 import           GHC.Stack (HasCallStack)
 -- Package: aeson.
@@ -478,20 +479,7 @@ unionWithKey _ _ b = b
 addEras :: Map.Map String Types.Profile -> Map.Map String Types.Profile
 addEras = foldMap
   (\profile -> Map.fromList $
-    let
-        -- TODO: Profiles properties other than the "name" and "era" of
-        --       type string are the only thing that change ??? Remove the
-        --       concept of eras from the profile definitions and make it a
-        --       workbench-level feature (???).
-        addEra p era suffix
-          | Just (major, _) <- Types.profileProtocolVersion p
-          , era < Types.firstEraForMajorVersion major
-            = mempty
-          | otherwise
-            = let name = Types.name p
-                  newName = name ++ "-" ++ suffix
-              in [(newName, p {Types.name = newName, Types.era = era})]
-    in mconcat
+      catMaybes
         [ addEra profile Types.Shelley "shey"
         , addEra profile Types.Allegra "alra"
         , addEra profile Types.Mary    "mary"
@@ -500,3 +488,13 @@ addEras = foldMap
         , addEra profile Types.Conway  "coay"
         ]
   )
+
+addEra :: Types.Profile -> Types.Era -> String -> Maybe (String, Types.Profile)
+addEra p era suffix
+  | Just (major, _) <- Types.profileProtocolVersion p
+  , era < Types.firstEraForMajorVersion major
+    = Nothing
+  | otherwise
+    = let name = Types.name p
+          newName = name ++ "-" ++ suffix
+      in Just (newName, p {Types.name = newName, Types.era = era})

bench/cardano-profile/test/Main.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
 module Main (main) where
@@ -766,13 +766,19 @@ testGroupMap = Tasty.testGroup
             )
   , testCase "Profiles (Duplicate names)" $
       let
-        go (set, duplicates) name
-          | name `Set.member` set = (set, name:duplicates)
-          | otherwise             = (name `Set.insert` set, duplicates)
+        go (T set duplicates) name
+          | name `Set.member` set = T set (name:duplicates)
+          | otherwise             = T (name `Set.insert` set) duplicates
       in assertEqual "Duplicate definition(s) for profile(s)" []
-          $ snd $ foldl' go (Set.empty, []) (map Types.name profilesRaw)
+          $ sndT $ foldl' go (T Set.empty []) (map Types.name profilesRaw)
   ]
 
+-- little helper type for tuples strict in the first element
+data TupleStrictFirst a b = T !a b
+
+sndT :: TupleStrictFirst a b -> b
+sndT (T _ b) = b
+
 --------------------------------------------------------------------------------
 
 -- The overlay to apply.

bench/tx-generator/src-calibrate/Cardano/TxGenerator/Calibrate/Utils.hs

@@ -17,7 +17,6 @@ import           Data.Aeson (eitherDecodeFileStrict')
 import           Data.Aeson.Encode.Pretty
 import           Data.Bool (bool)
 import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, putStrLn)
-import           Data.Functor ((<&>))
 import           System.Directory (doesFileExist)
 import           System.FilePath
 
@@ -62,18 +61,18 @@ resolveRedeemerQuiet quiet = \case
       -- NB: while scripts-fallback/ content might be used in production, data/ should *NEVER* be - it's for tx-generator development and testing only
       Left n -> do
          let fallbackName = "data" </> n <.> "redeemer" <.> "json"
-         fileExists     <- maybe (pure False) doesFileExist plutusRedeemer
-         fallbackFile   <- try (getDataFileName fallbackName) <&> either (\SomeException{} -> "") id
-         loader $ if fileExists then plutusRedeemer else Just fallbackFile
+         fileExists     <- or <$> forM plutusRedeemer doesFileExist
+         fallbackFile   <- either (\SomeException{} -> Nothing) Just <$> try (getDataFileName fallbackName)
+         loader $ if fileExists then plutusRedeemer else fallbackFile
 
   Right{} -> pure $ Left $ TxGenError "resolveRedeemer: no Plutus script defined"
 
   where
     loader = \case
-      Just f@(_:_) -> do
+      Just f -> do
         unless quiet $ putStrLn $ "--> will read redeemer from: " ++ f
         readScriptData f
-      _ -> pure $ Left $ TxGenError "resolveRedeemer: no redeemer file resolved"
+      Nothing -> pure $ Left $ TxGenError "resolveRedeemer: no redeemer file resolved"
 
 printScriptData :: ScriptData -> IO ()
 printScriptData =

bench/tx-generator/tx-generator.cabal

@@ -26,6 +26,8 @@ common project-config
   if os(windows)
     buildable: False
 
+  default-language:     Haskell2010
+
 common with-library
   -- This is the inverse to the "buildable" GHC version constraint in plutus-scripts-bench.
   -- It makes sure, we only depend on that package if it is buildable.
@@ -38,6 +40,7 @@ common maybe-unix
   if !os(windows)
     build-depends:      unix
 
+
 library
   import:               project-config, with-library, maybe-unix
 
@@ -168,14 +171,12 @@ library
                       , scientific
                       , cardano-ledger-babbage
 
-  default-language:     Haskell2010
   default-extensions:   OverloadedStrings
 
 executable tx-generator
   import:               project-config
   hs-source-dirs:       app
   main-is:              tx-generator.hs
-  default-language:     Haskell2010
   ghc-options:          -threaded
                         -Wall
                         -rtsopts
@@ -190,9 +191,8 @@ executable calibrate-script
   hs-source-dirs:       app
                         src-calibrate
   main-is:              calibrate-script.hs
-  default-language:     Haskell2010
-  ghc-options:          -threaded
-                        -Wall
+
+  ghc-options:          -Wall
                         -rtsopts
                         "-with-rtsopts=-T"
                         -Wno-deprecations
@@ -207,9 +207,6 @@ executable calibrate-script
                       , filepath
                       , optparse-applicative-fork
                       , cardano-api
-                      , cardano-cli
-                      , cardano-node
-                      , plutus-tx
                       , text
                       , transformers
                       , transformers-except
@@ -228,9 +225,8 @@ test-suite tx-generator-apitest
                         test
   main-is:              ApiTest.hs
   type:                 exitcode-stdio-1.0
-  default-language:     Haskell2010
-  ghc-options:          -threaded
-                        -Wall
+
+  ghc-options:          -Wall
                         -rtsopts
                         "-with-rtsopts=-T"
                         -Wno-deprecations
@@ -266,8 +262,6 @@ test-suite tx-generator-test
                       , tasty-hunit
                       , tx-generator
 
-  default-language:     Haskell2010
-
   ghc-options:          -Weverything
                         -fno-warn-missing-import-lists
                         -fno-warn-safe
@@ -285,8 +279,6 @@ benchmark tx-generator-bench
                       , stm
                       , tx-generator
 
-  default-language:     Haskell2010
-
   ghc-options:          -Weverything
                         -fno-warn-missing-import-lists
                         -fno-warn-safe