ContractRegistry.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | 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 qualified Data.ByteString.Lazy.Char8 as BS (putStrLn)
import Data.Constraint ((\\))
import qualified Data.Map as Map
import Data.Text.Lazy.Builder (toLazyText)
import Fmt (Buildable(..), blockListF, nameF, pretty, (+|), (|+))
import qualified Options.Applicative as Opt

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

data ContractInfo =
  forall cp st.
    (NiceParameterFull cp, NiceStorage st) =>
  ContractInfo
  { ciContract :: Contract cp st
  , 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 :: Text -> ContractRegistry -> IO ContractInfo
getContract name registry =
  case Map.lookup name (unContractRegistry registry) of
    Nothing ->
      die $ "No contract with name '" +| name |+ "' found\n" +| registry |+ ""
    Just c -> pure c

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

printContractFromRegistryDoc :: Text -> ContractRegistry -> DGitRevision -> Maybe FilePath -> IO ()
printContractFromRegistryDoc name contracts gitRev mOutput = do
  ContractInfo{..} <- getContract name contracts
  if ciIsDocumented
  then
     writeFunc (toString name <> ".md") mOutput $
       contractDocToMarkdown $ buildLorentzDocWithGitRev gitRev $ cCode 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 Text (Maybe FilePath) Bool Bool
  | Document Text (Maybe FilePath) DGitRevision
  | Analyze Text
  | PrintStorage SomeNiceStorage Bool

argParser :: ContractRegistry -> DGitRevision -> Opt.Parser CmdLnArgs
argParser registry gitRev = Opt.subparser $ mconcat $
  [ listSubCmd
  , printSubCmd
  , documentSubCmd
  , analyzerSubCmd
  ] <> mapMaybe storageSubCmd (Map.toList $ unContractRegistry registry)
  where
    mkCommandParser commandName parser desc =
      Opt.command commandName $
      Opt.info (Opt.helper <*> parser) $
      Opt.progDesc desc

    listSubCmd =
      mkCommandParser "list"
      (pure List)
      "Show all available contracts"

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

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

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

    nameOption = 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 <> "'")

-- | Run an action operating with 'ContractRegistry'.
runContractRegistry :: ContractRegistry -> CmdLnArgs -> IO ()
runContractRegistry registry = \case
  List -> pretty registry
  Print name mOutput forceOneLine useMicheline -> do
    ContractInfo{..} <- getContract name registry
    let
      compiledContract = case ciStorageNotes of
        Just notes -> (compileLorentzContract ciContract) { M.cStoreNotes = notes }
        Nothing -> compileLorentzContract ciContract
    writeFunc (toString name <> ".tz") mOutput $
      if useMicheline
      then toLazyText $ encodePrettyToTextBuilder $ toExpression compiledContract
      else printTypedContract forceOneLine $ compiledContract
  Document name mOutput gitRev -> do
    printContractFromRegistryDoc name registry gitRev mOutput
  Analyze name -> do
    ContractInfo{..} <- getContract name registry
    let compiledContract  =
          compileLorentzContract ciContract
    putTextLn $ pretty $ analyze $ 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 -> writeFileUtf8 defName
  Just "-" -> putStrLn
  Just output -> writeFileUtf8 output