ContractRegistry.hs

-- | This module contains various datatypes and functions which are
-- common for contract registry packages (e.g. @morley-ledgers@ and
-- @morley-multisig@).

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

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

  -- * Building blocks
  , getContract
  , 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 Tezos.V005.Micheline (Expression)

import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Doc
import Lorentz.Print
import Lorentz.Run
import Michelson.Printer (printTypedFullContract)
import Michelson.Typed (FullContract(..), IsoValue(..), Notes)
import Morley.Micheline
import Util.IO

data ContractInfo =
  forall cp st.
    (NiceParameterFull cp, NiceStorage st) =>
  ContractInfo
  { ciContract :: ContractCode 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'.
  , ciCompilationOptions :: CompilationOptions
  -- ^ How to compile this contract.
  , ciStorageNotes :: Notes (ToT st)
  -- ^ A temporary approach to add annotations to storage.
  -- TODO [#20]: invent something better.
  }

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

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

getContract :: Text -> ContractRegistry -> Either String ContractInfo
getContract name registry =
  case Map.lookup name (unContractRegistry registry) of
    Nothing ->
      Left $ "No contract with name '" +| name |+ "' found\n" +| registry |+ ""
    Just c -> Right 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{..} <- either die pure $ getContract name contracts
  if ciIsDocumented
  then
     writeFunc (toString name <> ".md") mOutput $
       contractDocToMarkdown $ buildLorentzDocWithGitRev 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 Text (Maybe FilePath) Bool Bool
  | Document Text (Maybe FilePath) DGitRevision
  | PrintStorage SomeNiceStorage Bool

argParser :: ContractRegistry -> DGitRevision -> Opt.Parser CmdLnArgs
argParser registry gitRev = Opt.subparser $ mconcat $
  [ listSubCmd
  , printSubCmd
  , documentSubCmd
  ] <> 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 <$> printOptions <*> outputOptions <*> onelineOption <*> michelineOption)
      "Dump a contract in form of Michelson code"

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

    printOptions = 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 ->
    case getContract name registry of
      Left err ->
        die err
      Right ContractInfo{..} ->
        let compiledContract  =
              (compileLorentzContractWithOptions ciCompilationOptions ciContract)
                {fcStoreNotes = ciStorageNotes} in
        writeFunc (toString name <> ".tz") mOutput $
          if useMicheline
          then toLazyText $ encodePrettyToTextBuilder $ toExpression compiledContract
          else printTypedFullContract forceOneLine $ compiledContract
  Document name mOutput gitRev -> do
    printContractFromRegistryDoc name registry gitRev mOutput
  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