PLT-6750: Parsing pretty printed Marlowe contracts

marlowe-cli/changelog.d/20230817_095044_yves.hauser_PLT_6750.md

@@ -0,0 +1,40 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Removed
+
+- A bullet item for the Removed category.
+
+-->
+### Added
+
+- Format conversion with `marlowe-cli format`
+
+<!--
+### Changed
+
+- A bullet item for the Changed category.
+
+-->
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

marlowe-cli/command/Language/Marlowe/CLI/Command.hs

@@ -27,6 +27,7 @@ import Cardano.Api (AlonzoEra, BabbageEra, IsShelleyBasedEra, NetworkId, ScriptD
 import Control.Monad.Except (MonadError, MonadIO, liftIO, runExceptT)
 import Data.Foldable (Foldable (fold), asum)
 import Language.Marlowe.CLI.Command.Contract (ContractCommand, parseContractCommand, runContractCommand)
+import Language.Marlowe.CLI.Command.Format (FormatCommand, parseFormatCommand, runFormatCommand)
 import Language.Marlowe.CLI.Command.Input (InputCommand, parseInputCommand, runInputCommand)
 import Language.Marlowe.CLI.Command.Role (RoleCommand, parseRoleCommand, runRoleCommand)
 import Language.Marlowe.CLI.Command.Run (RunCommand, parseRunCommand, runRunCommand)
@@ -67,6 +68,8 @@ data Command era
     UtilCommand (UtilCommand era)
   | -- | Test-related commands.
     TestCommand (TestCommand era)
+  | -- | Format-related commands.
+    FormatCommand FormatCommand
 
 data SomeCommand = forall era. SomeCommand (ScriptDataSupportedInEra era) (Command era)
 
@@ -112,6 +115,7 @@ runCommand era cmd = flip runReaderT CliEnv{..} case cmd of
   TemplateCommand command outputFiles -> runTemplateCommand command outputFiles
   TransactionCommand command -> runTransactionCommand command
   UtilCommand command -> runUtilCommand command
+  FormatCommand command -> runFormatCommand command
 
 -- | Command parseCommand for the tool version.
 mkCommandParser
@@ -182,6 +186,9 @@ mkCommandParser networkId socketPath version = do
               , O.command "test" $
                   O.info (TestCommand <$> testCommandParser) $
                     O.progDesc "Run test scenario described using yaml based DSL."
+              , O.command "format" $
+                  O.info (FormatCommand <$> parseFormatCommand) $
+                    O.progDesc "Convert between formats and pretty-print Marlowe contracts."
               ]
         , O.hsubparser $
             fold

marlowe-cli/command/Language/Marlowe/CLI/Command/Format.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+--
+-- Module      :  Language.Marlowe.CLI.Command.Format
+-- License     :  Apache 2.0
+--
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-----------------------------------------------------------------------------
+
+-- | Format Marlowe contracts in the CLI tool.
+module Language.Marlowe.CLI.Command.Format (
+  -- * Marlowe CLI Commands
+  FormatCommand (..),
+  runFormatCommand,
+  parseFormatCommand,
+) where
+
+import Control.Monad.Except (MonadError, MonadIO (..))
+import Data.Char (toUpper)
+import Language.Marlowe.CLI.Format (
+  maybeWriteJson,
+  maybeWritePretty,
+  maybeWriteYaml,
+  readContractJson,
+  readContractPretty,
+  readContractYaml,
+ )
+import Language.Marlowe.CLI.Types (CliError (..))
+import Options.Applicative qualified as O
+import System.FilePath (takeExtension)
+
+-- | Marlowe CLI options for formatting contracts.
+data FormatCommand
+  = -- | Format a contract.
+    Format
+    { inputFile :: Maybe FilePath
+    -- ^ The Marlowe file containing the contract to be formatted.
+    , outputFile :: Maybe FilePath
+    -- ^ The output file for the formatted Marlowe contract.
+    , inFormat :: Maybe Format
+    -- ^ Format of the input Marlowe contract.
+    , outFormat :: Maybe Format
+    -- ^ Format of the output Marlowe contract.
+    }
+  deriving stock (Eq, Show)
+
+-- | Format a Marlowe contract.
+runFormatCommand
+  :: (MonadError CliError m)
+  => (MonadIO m)
+  => FormatCommand
+  -- ^ The command.
+  -> m ()
+  -- ^ Action for runninng the command.
+runFormatCommand Format{..} =
+  do
+    contract <- case inFormat of
+      Just Json -> readContractJson inputFile
+      Just Yaml -> readContractYaml inputFile
+      Just Pretty -> readContractPretty inputFile
+      Nothing ->
+        case inputFile of
+          Just fileName ->
+            case takeExtension fileName of
+              ".json" -> readContractJson inputFile
+              ".yaml" -> readContractYaml inputFile
+              ".marlowe" -> readContractPretty inputFile
+              _ -> readContractJson inputFile
+          Nothing -> readContractJson inputFile
+    case outFormat of
+      Just Json -> maybeWriteJson outputFile contract
+      Just Yaml -> maybeWriteYaml outputFile contract
+      Just Pretty -> maybeWritePretty outputFile contract
+      Nothing ->
+        case outputFile of
+          Just fileName ->
+            case takeExtension fileName of
+              ".json" -> maybeWriteJson outputFile contract
+              ".yaml" -> maybeWriteYaml outputFile contract
+              ".marlowe" -> maybeWritePretty outputFile contract
+              _ -> maybeWriteJson outputFile contract
+          Nothing -> maybeWriteJson outputFile contract
+
+-- | Parser for format commands.
+parseFormatCommand :: O.Parser FormatCommand
+parseFormatCommand =
+  Format
+    <$> inFile
+    <*> outFile
+    <*> inFormatParser
+    <*> outFormatParser
+  where
+    inFile =
+      O.optional . O.strOption $
+        mconcat
+          [ O.long "in-file"
+          , O.metavar "MARLOWE_FILE"
+          , O.help "The Marlowe file containing the contract. If omitted, the Marlowe contract is read from stdin."
+          ]
+    outFile =
+      O.optional . O.strOption $
+        mconcat
+          [ O.long "out-file"
+          , O.metavar "MARLOWE_FILE"
+          , O.help "The Marlowe file the output contract is written to. If omitted, the Marlowe contract is written to stdout."
+          ]
+    inFormatParser =
+      O.optional . O.option formatReader $
+        mconcat
+          [ O.long "in-format"
+          , O.metavar "FORMAT"
+          , O.help $
+              "The format of the input Marlowe contract. Known formats are: Json (default), Yaml, Marlowe. "
+                <> "If omitted and in-file is specified, the format is inferred from the file extension."
+          ]
+    outFormatParser =
+      O.optional . O.option formatReader $
+        mconcat
+          [ O.long "out-format"
+          , O.metavar "FORMAT"
+          , O.help $
+              "The format of the output Marlowe contract. Known formats are: Json (default), Yaml, Marlowe. "
+                <> "If omitted and out-file is specified, the format is inferred from the file extension."
+          ]
+
+data Format = Json | Yaml | Pretty
+  deriving stock (Eq, Read, Show)
+
+formatReader :: O.ReadM Format
+formatReader = readFormat =<< O.str
+  where
+    readFormat arg =
+      case map toUpper arg of
+        "JSON" -> return Json
+        "YAML" -> return Yaml
+        "MARLOWE" -> return Pretty
+        _ -> O.readerError $ "cannot parse argument '" <> arg <> "'. Valid are: json, yaml, marlowe. Default: json"

marlowe-cli/marlowe-cli.cabal

@@ -74,6 +74,7 @@ library
     Language.Marlowe.CLI.Data.Foldable
     Language.Marlowe.CLI.Examples
     Language.Marlowe.CLI.Export
+    Language.Marlowe.CLI.Format
     Language.Marlowe.CLI.IO
     Language.Marlowe.CLI.Merkle
     Language.Marlowe.CLI.Orphans
@@ -107,10 +108,12 @@ library
     , errors
     , extra
     , marlowe-cardano
+    , megaparsec
     , memory
     , mtl
     , ouroboros-consensus
     , ouroboros-network
+    , parser-combinators
     , plutus-core
     , plutus-ledger
     , plutus-ledger-ada
@@ -221,6 +224,7 @@ library command
   exposed-modules:
     Language.Marlowe.CLI.Command
     Language.Marlowe.CLI.Command.Contract
+    Language.Marlowe.CLI.Command.Format
     Language.Marlowe.CLI.Command.Input
     Language.Marlowe.CLI.Command.Parse
     Language.Marlowe.CLI.Command.Role
@@ -238,6 +242,7 @@ library command
     , cardano-api
     , cardano-slotting
     , containers
+    , filepath
     , marlowe-actus
     , marlowe-cardano
     , marlowe-cli:{marlowe-cli, cli-test}
@@ -278,17 +283,24 @@ test-suite marlowe-cli-test
   hs-source-dirs: tests
   type:           exitcode-stdio-1.0
   main-is:        Spec.hs
-  other-modules:  Spec.Analysis
+  other-modules:
+    Spec.Analysis
+    Spec.Format
+
   build-depends:
     , aeson
     , base >=4.9 && <5
     , cardano-api
     , containers
     , marlowe-cardano
     , marlowe-cli
+    , marlowe-test
+    , megaparsec
     , mtl
     , plutus-ledger-api
     , plutus-ledger-slot
     , plutus-tx
     , tasty
     , tasty-hunit
+    , tasty-quickcheck
+    , text