wb | allow to code overlays

Author: fmaste

bench/cardano-profile/app/cardano-profile.hs

@@ -77,9 +77,9 @@ playgroundProfiles = profilesNoEraPlayground
 --------------------------------------------------------------------------------
 
 data Cli =
-    Names
-  | NamesNoEra
+    NamesNoEra
   | NamesCloudNoEra
+  | Names
   | All
   | ByName PrettyPrint String
   | LibMK
@@ -94,11 +94,14 @@ data PrettyPrint =
 --------------------------------------------------------------------------------
 
 -- | Construct Map with profile name as key, without eras (in name and object).
-toMap :: HasCallStack => Aeson.Object -> [Types.Profile] -> Map.Map String Types.Profile
-toMap obj ps = Map.fromList $ map
+toMap :: HasCallStack => Maybe Aeson.Object -> [Types.Profile] -> Map.Map String Types.Profile
+toMap maybeObj ps = Map.fromList $ map
   (\p ->
     ( Types.name p
-    , Profile.realize obj p 
+    , Profile.realize $
+        case maybeObj of
+          Nothing    ->  p
+          (Just obj) -> (p {Types.overlay = obj})
     )
   )
   ps
@@ -132,20 +135,22 @@ main :: IO ()
 main = do
   cli <- getOpts
   case cli of
-    -- Print all profile names (does not apply overlays).
-    Names -> BSL8.putStrLn $ Aeson.encode $ Map.keys $ addEras $ toMap mempty allProfiles
     -- Print all profile names without the era suffix (does not apply overlays).
     NamesNoEra -> BSL8.putStrLn $ Aeson.encode $ map Types.name allProfiles
-    -- Print all cloud profile (-nomadperf) names.
+    -- Print all cloud profile (-nomadperf) names (does not apply overlays).
     NamesCloudNoEra -> BSL8.putStrLn $ Aeson.encode $ map Types.name cloudProfiles
+    -- Print all profile names (applies overlays!!!!!).
+    Names -> do
+      maybeObj <- lookupOverlay -- Ignored by `NamesNoEra` and `NamesCloudNoEra`.
+      BSL8.putStrLn $ Aeson.encode $ Map.keys $ addEras $ toMap maybeObj allProfiles
     -- Print a map with all profiles, with an optional overlay.
     All -> do
-      obj <- lookupOverlay
-      BSL8.putStrLn $ Aeson.encode $ addEras $ toMap obj allProfiles
+      maybeObj <- lookupOverlay -- Ignored by `NamesNoEra` and `NamesCloudNoEra`.
+      BSL8.putStrLn $ Aeson.encode $ addEras $ toMap maybeObj allProfiles
     -- Print a single profiles, with an optional overlay.
     (ByName prettyPrint profileName) -> do
-      obj <- lookupOverlay
-      let profiles = addEras $ toMap obj allProfiles
+      maybeObj <- lookupOverlay -- Ignored by `NamesNoEra` and `NamesCloudNoEra`.
+      let profiles = addEras $ toMap maybeObj allProfiles
       case Map.lookup profileName profiles of
         Nothing -> error $ "No profile named \"" ++ profileName ++ "\""
         (Just profile) ->
@@ -181,13 +186,13 @@ main = do
         (Left errorMsg) -> fail errorMsg
         (Right profile) -> print (profile :: Types.Profile)
 
-lookupOverlay :: IO Aeson.Object
+lookupOverlay :: IO (Maybe Aeson.Object)
 lookupOverlay = do
   maybeOverlay <- lookupEnv "WB_PROFILE_OVERLAY"
-  case maybeOverlay of
-    Nothing -> mempty
+  return $ case maybeOverlay of
+    Nothing -> Nothing
     (Just str) -> case Aeson.decode (BSL8.pack str) of
-                    (Just (Aeson.Object keyMap)) -> return keyMap
+                    (Just (Aeson.Object keyMap)) -> Just keyMap
                     _ -> error ""
 
 getOpts :: IO Cli
@@ -200,12 +205,6 @@ getOpts = OA.execParser $
 
 cliParser :: OA.Parser Cli
 cliParser = OA.hsubparser $
-      OA.command "names"
-        (OA.info
-          (pure Names)
-          (OA.fullDesc <> OA.header "names" <> OA.progDesc "All profiles names")
-        )
-  <>
       OA.command "names-noera"
         (OA.info
           (pure NamesNoEra)
@@ -217,6 +216,12 @@ cliParser = OA.hsubparser $
           (pure NamesCloudNoEra)
           (OA.fullDesc <> OA.header "names-cloud-noera" <> OA.progDesc "All cloud profiles names (no era suffix)")
         )
+  <>
+      OA.command "names"
+        (OA.info
+          (pure Names)
+          (OA.fullDesc <> OA.header "names" <> OA.progDesc "All profiles names")
+        )
   <>
       OA.command "all"
         (OA.info

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

@@ -25,22 +25,22 @@ import qualified Paths_cardano_profile as Paths
 
 --------------------------------------------------------------------------------
 
-realize :: HasCallStack => Aeson.Object -> Types.Profile -> Types.Profile
-realize obj profile =
+realize :: HasCallStack => Types.Profile -> Types.Profile
+realize =
     -- Compose the profile in the same order as the `jq` profile machinery!
     -- 1) `addUnusedDefaults`: Adds all properties that are the same for all
     --                         profiles. This are all candidates to be removed
     --                         when we finally switch from `jq` to this.
-    -- 2) `overlay`: Applies an optional JSON object as an "overlay". The
-    --               object is read from an envar ("WB_PROFILE_OVERLAY") in
-    --               the `main` function and can override anything (some may
-    --               overridden by later steps) as long as the result is a
-    --               valid `Profile`.
-    -- 3) `shelleyAlonzoConway`: Given an epoch number ("pparamsEpoch"
+    -- 2) `shelleyAlonzoConway`: Given an epoch number ("pparamsEpoch"
     --                           property) creates the "genesis" property
     --                           using "epoch-timeline.json" and applying the
     --                           genesis specific overlays ("pparamsOverlays"
     --                           property).
+    -- 3) `overlay`: Applies an optional JSON object as an "overlay". The
+    --               object is read from an envar ("WB_PROFILE_OVERLAY") in
+    --               the `main` function and can override anything (some may
+    --               overridden by later steps) as long as the result is a
+    --               valid `Profile`.
     -- 4)  `derive`: Fills the "derive" property.
     -- 5)  `finalize`: Applies fixes (porting infelicities) needed to fill
     --                 the "cli_args" property that is also filled here.
@@ -50,10 +50,9 @@ realize obj profile =
     preset
   . finalize
   . derive
+  . overlay
   . shelleyAlonzoConway
-  . overlay obj
   . addUnusedDefaults
-  $ profile
 
 {-
 
@@ -106,15 +105,6 @@ addUnusedDefaults p =
 -- Step 2.
 --------------------------------------------------------------------------------
 
--- Merges the profile with a JSON file and stores the overlay contents in the
--- profile.
-overlay :: HasCallStack => Aeson.Object -> Types.Profile -> Types.Profile
-overlay overlaykeyMap profile =
-  (applyOverlay overlaykeyMap profile) {Types.overlay = overlaykeyMap}
-
--- Step 3.
---------------------------------------------------------------------------------
-
 -- | Fill the "genesis" object "shelley", "alonzo" and "conway" properties
 --   using the profile's epoch number and overlay names.
 shelleyAlonzoConway :: Types.Profile -> Types.Profile
@@ -194,6 +184,17 @@ genesisOverlay overlayName epochParams = do
       KeyMap.unionWithKey unionWithKey epochParams keyMap
     _ -> error $ "Not an Aeson Object: \"" ++ fp ++ "\""
 
+-- Step 3.
+--------------------------------------------------------------------------------
+
+-- Merges the profile with a JSON object stored in the "overlay" property.
+overlay :: HasCallStack => Types.Profile -> Types.Profile
+overlay profile =
+  let overlaykeyMap = Types.overlay profile -- An `Aeson.Object`.
+  in if overlaykeyMap /= mempty
+     then applyOverlay overlaykeyMap profile
+     else profile
+
 -- Step 4.
 --------------------------------------------------------------------------------
 

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

@@ -99,6 +99,7 @@ module Cardano.Benchmarking.Profile.Primitives (
   , cBlockMinimumAdoptions
 
   , preset
+  , overlay
 
 ) where
 
@@ -914,8 +915,14 @@ cBlockMinimumAdoptions i = analysisExpressionAppend
 
 --------------------------------------------------------------------------------
 
-preset :: String -> Types.Profile -> Types.Profile
+preset :: HasCallStack => String -> Types.Profile -> Types.Profile
 preset str p =
   if isJust (Types.preset p)
   then error "preset: `preset` already set (not Nothing)."
   else p {Types.preset = Just str}
+
+overlay :: HasCallStack => Aeson.Object -> Types.Profile -> Types.Profile
+overlay obj p =
+  if Types.overlay p /= mempty
+  then error "overlay: `overlay` already set (not an empty JSON object)."
+  else p {Types.overlay = obj}

bench/cardano-profile/test/Main.hs

@@ -477,7 +477,7 @@ profiles :: Map.Map String Types.Profile
 profiles = Map.fromList $ map
   (\p ->
     ( Types.name p
-    , Profile.realize mempty p
+    , Profile.realize p -- No overlay added!
     )
   )
   (
@@ -740,7 +740,7 @@ testGroupOverlay = Tasty.testGroup
       case eitherAns of
         (Left err) -> fail err
         (Right profile) -> do
-          let profileWithOverlay = Profile.realize overlay profile
+          let profileWithOverlay = Profile.realize (profile {Types.overlay = overlay})
           assertEqual "New name"
             "HOLA!"
             (Types.name profileWithOverlay)