morley-1.19.1: app/REPL.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
{-|
Implements an REPL that can execute Morley instructions.  REPL starts with an
empty stack. At each instruction entered, the modified stack, or an error is
printed. Multiple instructions separated by semicolons should work as expected.
Available meta commads are:

 ':help', displays this help\n ':stack', prints the current stack
 ':loadstack filename', loads the stack from a file
 ':dumpstack filename', dumps the stack to a file
 ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."
-}
module REPL
  ( runRepl
  ) where

import Control.Exception (IOException)
import Control.Monad.Random (randomIO)
import Data.Aeson qualified as Aeson
import Data.ByteString.Base58 qualified as Base58
import Data.ByteString.Lazy qualified as BSL
import Data.List (stripPrefix)
import Data.Singletons (fromSing)
import Data.Text as T (length, replicate, strip)
import Data.Text qualified as T (stripPrefix)
import Data.Vinyl (Rec(..))
import Fmt (fmt, pretty)
import System.Console.Haskeline
  (InputT, Interrupt(..), defaultSettings, getInputLine, runInputT, withInterrupt)
import Text.Megaparsec (parse)

import Morley.Michelson.Interpret (interpretInstr)
import Morley.Michelson.Macro (ParsedOp, expand)
import Morley.Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_)
import Morley.Michelson.Parser.Types (MichelsonSource(..))
import Morley.Michelson.Printer (printDoc, printTypedValue)
import Morley.Michelson.Printer.Util (buildRenderDoc, doesntNeedParens)
import Morley.Michelson.Runtime.Dummy
import Morley.Michelson.Runtime.Import (readValue)
import Morley.Michelson.TypeCheck
  (SomeTcInstr(..), SomeTcInstrOut(..), TypeCheckOptions(..), runTypeCheckIsolated,
  typeCheckingWith)
import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)
import Morley.Michelson.TypeCheck.Types (HST(..))
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Crypto
import Morley.Util.Sing (castSing)
import Text.Hex (decodeHex, encodeHex)

data SomeStack = forall t. T.SingI t => SomeStack
  { stValues :: (Rec T.Value t)
  , stTypes :: HST t
  }

type ReplM = InputT (StateT SomeStack IO)

runRepl :: IO ()
runRepl = evalStateT (runInputT defaultSettings repl) emptyStack

-- | Prints an error message to stderr
printErr :: (MonadIO m) => Text -> m ()
printErr m = liftIO $ hPutStrLn stderr m

-- | Read commands or instructions from stdin and executes them.
-- If user presses Ctrl-c during execution of an instruction, it will be
-- caught and handled here itself. This ensures that REPL does not crash as
-- a result of user pressing Ctrl-c in an attempt to end a loop.
repl :: ReplM ()
repl = do
  printHelp
  repl_

repl_ :: ReplM ()
repl_ = do
   minput <- getInputLine "Morley>>> "
   case strStrip <$> minput of
     Nothing -> pass -- Ctrl D
     Just ":quit" -> pass
     Just input -> do
      case input of
        "" -> pass
        ":clear" -> lift $ put emptyStack
        ":stack" -> printStack
        ":help" -> printHelp
        (stripPrefixNonEmpty ":dumpstack" -> Just filename) ->
          dumpStackToFile $ toString $ strip $ toText filename
        (stripPrefixNonEmpty ":loadstack" -> Just filename) ->
          loadStackFromFile $ toString $ strip $ toText filename
        (stripPrefixNonEmpty ":parse" -> Just parseInput) ->
          tryParse $ strip $ toText parseInput
        (stripPrefixNonEmpty ":base58encode" -> Just parseInput) ->
          base58Encode $ strip $ toText parseInput
        (stripPrefix ":genkeys" -> Just mseed) -> do
           seed <- case mseed of
             "" -> show <$> (liftIO (randomIO @Word64))
             seed -> pure seed
           let sk = detSecretKey (encodeUtf8 seed)
           let pk = toPublic sk
           let pkh = hashKey pk
           printResult "Secret Key" (formatSecretKey sk)
           printResult "Public Key" (formatPublicKey pk)
           printResult "Public Key hash" (formatHash pkh)
        (stripPrefixNonEmpty ":" -> Just cmd) ->
          printErr $ "Unknown command or argument missing in `:"<> (toText cmd) <> "`. Use :help to see a list of commands"
        _ -> flip catch (\Interrupt -> putTextLn "Cancelled") $ withInterrupt $ runCode (toText input)
      repl_
  where
    strStrip = toString . strip . toText
    stripPrefixNonEmpty p i = case stripPrefix p i of
      Just "" -> Nothing
      x -> x

base58Encode :: Text -> ReplM ()
base58Encode inp = case decodeHex $ fromMaybe inp $ (T.stripPrefix "0x" inp) of
  Just b -> do
    printResult "Base58encode" $ decodeUtf8 $ Base58.encodeBase58 Base58.bitcoinAlphabet b
    printResult "Base58encode with checksum" $ encodeBase58Check b
  Nothing -> putTextLn "Can't parse input as hex-encoded bytes"

tryParseMichelsonValue :: forall (t :: T.T). (T.SingI t, T.HasNoOp t) => Text -> Text -> ReplM ()
tryParseMichelsonValue msg parseInput =
  case readValue @t MSStdin parseInput of
    Right s -> printResult msg $ (fmt . buildRenderDoc) s
    Left _ -> pass

underlined :: MonadIO m => Text -> m ()
underlined x = liftIO do
  putTextLn x
  putTextLn $ T.replicate (T.length x) "-"

printResult :: MonadIO m => Text -> Text -> m ()
printResult heading result = do
  underlined heading
  putTextLn result
  putTextLn ""

tryParse :: Text -> ReplM ()
tryParse parseInput = do
  tryParseMichelsonValue @'T.TKey "Michelson Key" parseInput
  tryParseMichelsonValue @'T.TUnit "Michelson Unit" parseInput
  tryParseMichelsonValue @'T.TSignature "Michelson Signature" parseInput
  tryParseMichelsonValue @'T.TChainId "Michelson ChainId" parseInput
  tryParseMichelsonValue @'T.TTimestamp "Michelson Timestamp" parseInput
  tryParseMichelsonValue @'T.TAddress "Michelson Address" parseInput
  tryParseMichelsonValue @'T.TString "Michelson String" parseInput
  tryParseMichelsonValue @'T.TInt "Michelson Int" parseInput
  tryParseMichelsonValue @'T.TNat "Michelson Nat" parseInput
  tryParseMichelsonValue @'T.TBytes "Michelson Bytes" parseInput
  tryParseMichelsonValue @'T.TMutez "Michelson Mutez" parseInput
  tryParseMichelsonValue @'T.TKeyHash "Michelson KeyHash" parseInput
  tryParseMichelsonValue @'T.TBls12381Fr "Michelson Bls12381Fr" parseInput
  tryParseMichelsonValue @'T.TBls12381G1 "Michelson Bls12381G1" parseInput
  tryParseMichelsonValue @'T.TBls12381G2 "Michelson Bls12381G2" parseInput
  tryParseMichelsonValue @'T.TBool "Michelson Bool" parseInput

  case parsePublicKey parseInput of
    Right p -> do
      printResult "Public Key" $ formatPublicKey p
    Left _ -> pass
  case parseSignature parseInput of
    Right p -> do
      printResult "Signature" $ formatSignature p
    Left _ -> pass
  case parseSecretKey parseInput of
    Right p -> do
      printResult "Secret Key" $ formatSecretKey p
    Left _ -> pass
  case parseHash @'HashKindPublicKey parseInput of
    Right p -> do
      printResult "KeyHash" $ formatHash p
    Left _ -> pass
  case Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 parseInput) of
    Just p -> do
      printResult "Base58 Encoded Bytes" $ "0x" <> (encodeHex p)
    Nothing -> pass
  case decodeBase58Check parseInput of
    Just p -> do
      printResult "Base58Check Encoded Bytes" $ "0x" <> (encodeHex p)
    Nothing -> pass

-- | Try to execute the given input string as a Morley instruction.
runCode :: Text -> ReplM ()
runCode code = do
  case parseInstructions code of
    Left err -> printErr err
    Right [] -> pass
    Right parsedOps -> do
      let expandedOps = expand <$> parsedOps
      lift get >>= \case
        SomeStack {..} -> case castSing stTypes of
          Just hstInp -> case typeCheckingWith tcOptions . runTypeCheckIsolated $
                                typeCheckList expandedOps hstInp of
            Right someInstr -> do
              case someInstr of
                _ :/ (instr ::: hstOut)-> case interpretInstr dummyContractEnv instr stValues of
                  Right recOut -> do
                    lift $ put (SomeStack recOut hstOut)
                    printStack
                  Left michelsonFail -> putTextLn (pretty michelsonFail)
                _ :/ (AnyOutInstr _) -> putTextLn "Encountered a FAILWITH instruction"
            Left err -> printErr $ pretty err
          Nothing -> printErr "Casting stack failed"

printHelp :: ReplM ()
printHelp = putTextLn "REPL starts with an empty stack. At each instruction entered,\
  \ the modified stack, or an error is printed. Multiple instructions separated by semicolons should work\
  \ as expected. Available meta commads are:\n\
  \ ':help', displays this help\n ':stack', prints the current stack\n\
  \ ':parse <input>', tries to parse the given string using known formats\n\
  \ ':base58encode <input>', prints the base58 encoding of a bytestring\n\
  \ ':genkeys <seed>', generates a key pair with hash using the seed string \n\
  \ ':loadstack <filename>', loads the stack from a file\n\
  \ ':dumpstack <filename>', dumps the stack to a file \n\
  \ ':clear', clears the current stack. Ctrl-D or ':quit' to end REPL."

printStack :: ReplM ()
printStack = lift get >>= \case
  SomeStack stk hst -> do
    putTextLn "--"
    putTextLn $ showStack stk hst

emptyStack :: SomeStack
emptyStack = SomeStack RNil SNil

parseInstructions :: Text -> Either Text [ParsedOp]
parseInstructions src =
  case parseNoEnv ops MSUnspecified src of
    Right p -> Right p
    Left err -> Left (toText $ errorBundlePretty err)

tcOptions :: TypeCheckOptions
tcOptions = TypeCheckOptions
  { tcVerbose = False
  , tcStrict = False
  }

-- helpers

addValueToHST
  :: forall t xs. T.SingI xs
  => T.Value t
  -> HST xs
  -> Either Text (T.Dict (T.SingI (t ': xs)), HST (t ': xs))
addValueToHST v hstIn = case T.valueTypeSanity v of
  T.Dict -> case T.getWTP @t of
    Right wtpDict -> Right (T.Dict, (T.sing @t, wtpDict) ::&  hstIn)
    Left (T.NotWellTyped t cause) -> let
      U.Ty t' tann = T.toUType t
      in Left $ "Value of type '" <> (renderT t' (U.fullAnnSet [tann] [] []))
                <> "' is not well typed in the provided Value because it "
                <> pretty cause <> "."

renderType :: T.SingT t -> Text
renderType notes = let
  U.Ty t tann = T.toUType (fromSing notes)
  in renderT t (U.fullAnnSet [tann] [] [])

renderT :: U.T -> U.AnnotationSet -> Text
renderT t annSet = toText $ printDoc True $ U.renderType t True doesntNeedParens annSet

dumpStackToFile :: FilePath -> ReplM ()
dumpStackToFile fname =
 lift get >>= \case
  SomeStack stk hst -> case dumpStack stk hst of
    Right stkd -> liftIO $ Prelude.catch (BSL.writeFile fname $ Aeson.encode stkd) handler
    Left err -> printErr err
  where
    handler :: IOException -> IO ()
    handler e = printErr $ toText $ displayException e

loadStackFromFile :: FilePath -> ReplM ()
loadStackFromFile fname = do
  mStack <- liftIO $ flip Prelude.catch handler $ do
    stackTxt <- BSL.readFile fname
    case Aeson.decode @[(Text, Text)] stackTxt of
      Just s -> pure $ loadStack s
      Nothing -> pure $ Left "Decoding error when parsing stack data from file"
  case mStack of
    Right stk -> lift $ put stk
    Left err -> printErr err
  where
    handler :: IOException -> IO (Either Text a)
    handler e = pure $ Left $ toText $ displayException e

-- | Dump stack as a lit of tuples that represent (value, type) pairs.
dumpStack :: forall t. Rec T.Value t -> HST t -> Either Text [(Text, Text)]
dumpStack RNil _ = Right []
dumpStack ((v :: T.Value a) :& rst) ((notes, _) ::& rHst) = case T.valueTypeSanity v of
  T.Dict -> case T.checkOpPresence (T.sing @a) of
    T.OpAbsent -> case dumpStack rst rHst of
      Right t -> Right ((toText $ printTypedValue True v, renderType notes) : t)
      Left e -> Left e
    T.OpPresent ->  Left "Cannot dump stack with operations"

-- | Overwrite the current stack with a stack loaded from a list of tuples
-- representing (value/type) pairs.
loadStack :: [(Text, Text)] -> Either Text SomeStack
loadStack = foldl' buildStack (Right emptyStack) . reverse
  where
    buildStack :: Either Text SomeStack -> (Text, Text) -> Either Text SomeStack
    buildStack (Left err) _ = Left err
    buildStack (Right (SomeStack stk hst)) (txVal, txTyp) = case
      (parseExpandValue "stack" txVal, parse type_ "" txTyp) of
        (Right val, Right typ) ->
          case typeCheckingWith tcOptions $ typeCheckParameter mempty typ val of
            Right (T.SomeValue tVal) ->
              case addValueToHST tVal hst of
                Right (T.Dict, newHst) -> Right $ SomeStack (tVal :& stk) newHst
                Left err -> Left err
            Left tcError -> Left $ pretty tcError
        (Left err, _) -> Left $ pretty err
        (_, Left err) -> Left $ toText $ errorBundlePretty err

showStack :: forall t. Rec T.Value t -> HST t -> Text
showStack RNil _ = "--"
showStack ((v :: T.Value a) :& rst) ((notes, _) ::& rHst)  = case T.valueTypeSanity v of
  T.Dict -> case T.checkOpPresence (T.sing @a) of
    T.OpAbsent -> -- print nice if value has no operations
      addSuffix (toText $ printTypedValue True v)
    _ ->          -- else just call show, and indicate value has operation inside
      case (v, T.sing @a) of
        (T.VList [], T.STList T.STOperation) -> "{ } :: list operation\n" <> showStack rst rHst
        _ -> addSuffix $ "(operations container:" <> pretty v <> ")"
  where
    addSuffix val = val <>" :: " <> renderType notes <> "\n" <> showStack rst rHst