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 qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile)
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

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 -> Utf8.writeFile defName
  Just "-" -> putStrLn
  Just output -> Utf8.writeFile output