ContractRegistry.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | This module contains various datatypes and functions which are
-- common for contract registry packages (e.g.
-- [morley-ledgers](https://gitlab.com/morley-framework/morley-ledgers/)).

module Lorentz.ContractRegistry
  ( -- * Registry types
    ContractInfo (..)
  , ContractRegistry (..)
  , (?::)

  -- * Things to do in @main@
  , CmdLnArgs (..)
  , argParser
  , runContractRegistry

  -- * Building blocks
  , printContractFromRegistryDoc
  ) where

import Data.Aeson.Encode.Pretty (encodePretty, encodePrettyToTextBuilder)
import Data.ByteString.Lazy.Char8 qualified as BS (putStrLn)
import Data.Constraint ((\\))
import Data.Map qualified as Map
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.IO.Utf8 qualified as Utf8 (writeFile)
import Fmt (Buildable(..), blockListF, nameF, pretty, (+|), (|+))
import Options.Applicative qualified as Opt

import Lorentz.Constraints
import Lorentz.Doc
import Lorentz.Print
import Lorentz.Run
import Morley.Micheline
import Morley.Michelson.Analyzer (analyze)
import Morley.Michelson.Printer (printTypedContract)
import Morley.Michelson.Typed (IsoValue(..), Notes)
import Morley.Michelson.Typed qualified as M
import Morley.Util.CLI (mkCommandParser)

data ContractInfo =
  forall cp st vd.
    (NiceStorage st) =>
  ContractInfo
  { ciContract :: Contract cp st vd
  , ciIsDocumented :: Bool
  , ciStorageParser :: Maybe (Opt.Parser st)
  -- ^ Specifies how to parse initial storage value.
  --
  -- Normally you pass some user data and call a function that
  -- constructs storage from that data.
  --
  -- If storage is simple and can be easilly constructed manually, you
  -- can use 'Nothing'.
  , ciStorageNotes :: Maybe (Notes (ToT st))
  -- ^ Rewrite annotations in storage.
  -- We don't won't to uncoditionally override storage notes since
  -- after #20 we require notes to be non-empty, so we wrap them into `Maybe`.
  }

(?::) :: Text -> a -> (Text, a)
(?::) = (,)

newtype ContractRegistry = ContractRegistry
  { unContractRegistry :: Map Text ContractInfo }

getContract :: Maybe Text -> ContractRegistry -> IO (ContractInfo, Text)
getContract mName registry =
  case mName of
    Just name ->
      case Map.lookup name (unContractRegistry registry) of
        Nothing ->
          die $ "No contract with name '" +| name |+ "' found\n" +| registry |+ ""
        Just c -> pure (c, name)
    Nothing ->
      -- When there is exactly one contract, return it.
      case Map.toList (unContractRegistry registry) of
        [(ci, n)] -> pure (n, ci)
        [] -> die $ "No contract found"
        _ ->
          die $ "Multiple contracts found. Please provide a name.\n" +| registry |+ ""

instance Buildable ContractRegistry where
  build registry =
    nameF "Available contracts" (blockListF $ keys (unContractRegistry registry))

printContractFromRegistryDoc :: Maybe Text -> ContractRegistry -> DGitRevision -> Maybe FilePath -> IO ()
printContractFromRegistryDoc mName contracts gitRev mOutput = do
  (ContractInfo{..}, name) <- getContract mName contracts
  if ciIsDocumented
  then
     writeFunc (toString name <> ".md") mOutput $
       buildMarkdownDoc $ attachDocCommons gitRev ciContract
  else die "This contract is not documented"

data SomeNiceStorage where
  SomeNiceStorage :: NiceStorage st => st -> SomeNiceStorage

-- | 'ContractRegistry' actions parsed from CLI.
data CmdLnArgs
  = List
  | Print (Maybe Text) (Maybe FilePath) Bool Bool
  | Document (Maybe Text) (Maybe FilePath) DGitRevision
  | Analyze (Maybe Text)
  | PrintStorage SomeNiceStorage Bool

argParser :: ContractRegistry -> DGitRevision -> Opt.Parser CmdLnArgs
argParser registry gitRev = Opt.subparser $ mconcat $
  [ listSubCmd
  , printSubCmd
  , documentSubCmd
  , analyzerSubCmd
  ] <> (
    case (nonEmpty $ Map.toList $ unContractRegistry registry) of
      Just (a :| []) ->
        -- When there is exactly one contract.
        mapMaybe storageSubCmdSingle [a]
      _ ->
        mapMaybe storageSubCmd (Map.toList $ unContractRegistry registry)
  )
  where
    listSubCmd =
      mkCommandParser "list"
      (pure List)
      "Show all available contracts"

    printSubCmd =
      mkCommandParser "print"
      (Print <$> mNameption <*> outputOptions <*> onelineOption <*> michelineOption)
      "Dump a contract in form of Michelson code"

    documentSubCmd =
      mkCommandParser "document"
      (Document <$> mNameption <*> outputOptions <*> pure gitRev)
      "Dump contract documentation in Markdown"

    analyzerSubCmd =
      mkCommandParser "analyze"
      (Analyze <$> mNameption)
      "Analyze the contract and prints statistics about it."

    mNameption = optional . Opt.strOption $ mconcat
      [ Opt.short 'n'
      , Opt.long "name"
      , Opt.metavar "IDENTIFIER"
      , Opt.help "Name of a contract returned by `list` command."
      ]

    outputOptions = optional . Opt.strOption $ mconcat
      [ Opt.short 'o'
      , Opt.long "output"
      , Opt.metavar "FILEPATH"
      , Opt.help $
        "File to use as output. If not specified, the file name " <>
        "will be constructed from the contract name." <>
        "Pass - to use stdout."
      ]

    onelineOption :: Opt.Parser Bool
    onelineOption = Opt.switch (
      Opt.long "oneline" <>
      Opt.help "Force single line output")

    michelineOption :: Opt.Parser Bool
    michelineOption = Opt.switch (
      Opt.long "micheline" <>
      Opt.help "Print using low-level Micheline representation")

    storageSubCmd ::
      (Text, ContractInfo) -> Maybe $ Opt.Mod Opt.CommandFields CmdLnArgs
    storageSubCmd (toString -> name, ContractInfo {..}) = do
      storageParser <- ciStorageParser
      pure $ mkCommandParser ("storage-" <> name)
        (PrintStorage . SomeNiceStorage <$> storageParser <*> michelineOption)
        ("Print initial storage for the contract '" <> name <> "'")

    -- | This will generated `storage` command instead of `storage-<contractName>` commands
    -- Useful when there is exactly one contract.
    storageSubCmdSingle ::
      (Text, ContractInfo) -> Maybe $ Opt.Mod Opt.CommandFields CmdLnArgs
    storageSubCmdSingle (toString -> name, ContractInfo {..}) = do
      storageParser <- ciStorageParser
      pure $ mkCommandParser "storage"
        (PrintStorage . SomeNiceStorage <$> storageParser <*> michelineOption)
        ("Print initial storage for the contract '" <> name <> "'")

-- | Run an action operating with 'ContractRegistry'.
runContractRegistry :: ContractRegistry -> CmdLnArgs -> IO ()
runContractRegistry registry = \case
  List -> pretty registry
  Print mName mOutput forceOneLine useMicheline -> do
    (ContractInfo{..}, name) <- getContract mName registry
    let
      compiledContract = case ciStorageNotes of
        Just notes -> (toMichelsonContract ciContract) { M.cStoreNotes = notes }
        Nothing -> toMichelsonContract ciContract
    writeFunc (toString name <> ".tz") mOutput $
      if useMicheline
      then toLazyText $ encodePrettyToTextBuilder $ toExpression compiledContract
      else printTypedContract forceOneLine $ compiledContract
  Document mName mOutput gitRev -> do
    printContractFromRegistryDoc mName registry gitRev mOutput
  Analyze mName -> do
    (ContractInfo{..}, _) <- getContract mName registry
    let compiledContract  =
          toMichelsonContract ciContract
    putTextLn $ pretty $ analyze $ M.unContractCode $ M.cCode compiledContract
  PrintStorage (SomeNiceStorage (storage :: st)) useMicheline ->
    if useMicheline
    then BS.putStrLn $ encodePretty $ toExpressionHelper storage
    else putStrLn $ printLorentzValue True storage
  where
    toExpressionHelper :: forall st'. NiceStorage st' => st' -> Expression
    toExpressionHelper = toExpression . toVal \\ niceStorageEvi @st'

writeFunc :: FilePath -> Maybe FilePath -> LText -> IO ()
writeFunc defName = \case
  Nothing -> Utf8.writeFile defName
  Just "-" -> putStrLn
  Just output -> Utf8.writeFile output