-- 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 Morley.App.REPL
  ( runRepl
  ) where

import Prelude hiding (group)

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 (Doc, build, pretty)
import Prettyprinter (align, group, line, nest)
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, parseExpandValue, parseNoEnv, rawOpsSequence, type_)
import Morley.Michelson.Parser.Types (MichelsonSource(..))
import Morley.Michelson.Printer.Util (printRenderDoc)
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.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 :: IO ()
runRepl = StateT SomeStack IO () -> SomeStack -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Settings (StateT SomeStack IO)
-> InputT (StateT SomeStack IO) () -> StateT SomeStack IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings (StateT SomeStack IO)
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings InputT (StateT SomeStack IO) ()
repl) SomeStack
emptyStack

-- | Prints an error message to stderr
printErr :: (MonadIO m) => Text -> m ()
printErr :: forall (m :: * -> *). MonadIO m => Text -> m ()
printErr Text
m = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStrLn Handle
stderr Text
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 :: InputT (StateT SomeStack IO) ()
repl = do
  InputT (StateT SomeStack IO) ()
printHelp
  InputT (StateT SomeStack IO) ()
repl_

repl_ :: ReplM ()
repl_ :: InputT (StateT SomeStack IO) ()
repl_ = do
   Maybe String
minput <- String -> InputT (StateT SomeStack IO) (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
"Morley>>> "
   case String -> String
strStrip (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
minput of
     Maybe String
Nothing -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass -- Ctrl D
     Just String
":quit" -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
     Just String
input -> do
      case String
input of
        String
"" -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
        String
":clear" -> StateT SomeStack IO () -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SomeStack IO () -> InputT (StateT SomeStack IO) ())
-> StateT SomeStack IO () -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ SomeStack -> StateT SomeStack IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SomeStack
emptyStack
        String
":stack" -> InputT (StateT SomeStack IO) ()
printStack
        String
":help" -> InputT (StateT SomeStack IO) ()
printHelp
        (String -> String -> Maybe String
stripPrefixNonEmpty String
":dumpstack" -> Just String
filename) ->
          String -> InputT (StateT SomeStack IO) ()
dumpStackToFile (String -> InputT (StateT SomeStack IO) ())
-> String -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
filename
        (String -> String -> Maybe String
stripPrefixNonEmpty String
":loadstack" -> Just String
filename) ->
          String -> InputT (StateT SomeStack IO) ()
loadStackFromFile (String -> InputT (StateT SomeStack IO) ())
-> String -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
filename
        (String -> String -> Maybe String
stripPrefixNonEmpty String
":parse" -> Just String
parseInput) ->
          Text -> InputT (StateT SomeStack IO) ()
tryParse (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
parseInput
        (String -> String -> Maybe String
stripPrefixNonEmpty String
":base58encode" -> Just String
parseInput) ->
          Text -> InputT (StateT SomeStack IO) ()
base58Encode (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
parseInput
        (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
":genkeys" -> Just String
mseed) -> do
           String
seed <- case String
mseed of
             String
"" -> Word64 -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Word64 -> String)
-> InputT (StateT SomeStack IO) Word64
-> InputT (StateT SomeStack IO) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Word64 -> InputT (StateT SomeStack IO) Word64
forall a. IO a -> InputT (StateT SomeStack IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO @Word64))
             String
seed -> String -> InputT (StateT SomeStack IO) String
forall a. a -> InputT (StateT SomeStack IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
seed
           let sk :: SecretKey
sk = ByteString -> SecretKey
detSecretKey (String -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 String
seed)
           let pk :: PublicKey
pk = SecretKey -> PublicKey
toPublic SecretKey
sk
           let pkh :: KeyHash
pkh = PublicKey -> KeyHash
hashKey PublicKey
pk
           Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Secret Key" (SecretKey -> Text
formatSecretKey SecretKey
sk)
           Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Public Key" (PublicKey -> Text
formatPublicKey PublicKey
pk)
           Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Public Key hash" (KeyHash -> Text
forall (kind :: HashKind). Hash kind -> Text
formatHash KeyHash
pkh)
        (String -> String -> Maybe String
stripPrefixNonEmpty String
":" -> Just String
cmd) ->
          Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"Unknown command or argument missing in `:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. ToText a => a -> Text
toText String
cmd) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`. Use :help to see a list of commands"
        String
_ -> (InputT (StateT SomeStack IO) ()
 -> (Interrupt -> InputT (StateT SomeStack IO) ())
 -> InputT (StateT SomeStack IO) ())
-> (Interrupt -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
-> InputT (StateT SomeStack IO) ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip InputT (StateT SomeStack IO) ()
-> (Interrupt -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (\Interrupt
Interrupt -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
"Cancelled") (InputT (StateT SomeStack IO) ()
 -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
-> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ InputT (StateT SomeStack IO) () -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
withInterrupt (InputT (StateT SomeStack IO) ()
 -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
-> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text -> InputT (StateT SomeStack IO) ()
runCode (String -> Text
forall a. ToText a => a -> Text
toText String
input)
      InputT (StateT SomeStack IO) ()
repl_
  where
    strStrip :: String -> String
strStrip = Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText
    stripPrefixNonEmpty :: String -> String -> Maybe String
stripPrefixNonEmpty String
p String
i = case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
p String
i of
      Just String
"" -> Maybe String
forall a. Maybe a
Nothing
      Maybe String
x -> Maybe String
x

base58Encode :: Text -> ReplM ()
base58Encode :: Text -> InputT (StateT SomeStack IO) ()
base58Encode Text
inp = case Text -> Maybe ByteString
decodeHex (Text -> Maybe ByteString) -> Text -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
inp (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Maybe Text
T.stripPrefix Text
"0x" Text
inp) of
  Just ByteString
b -> do
    Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Base58encode" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Alphabet -> ByteString -> ByteString
Base58.encodeBase58 Alphabet
Base58.bitcoinAlphabet ByteString
b
    Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Base58encode with checksum" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeBase58Check ByteString
b
  Maybe ByteString
Nothing -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
"Can't parse input as hex-encoded bytes"

tryParseMichelsonValue :: forall (t :: T.T). (T.SingI t) => Text -> Text -> ReplM ()
tryParseMichelsonValue :: forall (t :: T).
SingI t =>
Text -> Text -> InputT (StateT SomeStack IO) ()
tryParseMichelsonValue Text
msg Text
parseInput =
  case forall (t :: T).
SingI t =>
MichelsonSource -> Text -> Either ValueReadError (Value t)
readValue @t MichelsonSource
MSStdin Text
parseInput of
    Right Value t
s -> Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
msg (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Value t -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty Value t
s
    Left ValueReadError
_ -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass

underlined :: MonadIO m => Text -> m ()
underlined :: forall (m :: * -> *). MonadIO m => Text -> m ()
underlined Text
x = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
x
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
x) Text
"-"

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

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

  case Text -> Either CryptoParseError PublicKey
parsePublicKey Text
parseInput of
    Right PublicKey
p -> do
      Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Public Key" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ PublicKey -> Text
formatPublicKey PublicKey
p
    Left CryptoParseError
_ -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
  case Text -> Either CryptoParseError Signature
parseSignature Text
parseInput of
    Right Signature
p -> do
      Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Signature" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Signature -> Text
formatSignature Signature
p
    Left CryptoParseError
_ -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
  case Text -> Either CryptoParseError SecretKey
parseSecretKey Text
parseInput of
    Right SecretKey
p -> do
      Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Secret Key" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ SecretKey -> Text
formatSecretKey SecretKey
p
    Left CryptoParseError
_ -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
  case forall (kind :: HashKind).
AllHashTags kind =>
Text -> Either CryptoParseError (Hash kind)
parseHash @'HashKindPublicKey Text
parseInput of
    Right KeyHash
p -> do
      Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"KeyHash" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ KeyHash -> Text
forall (kind :: HashKind). Hash kind -> Text
formatHash KeyHash
p
    Left CryptoParseError
_ -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
  case Alphabet -> ByteString -> Maybe ByteString
Base58.decodeBase58 Alphabet
Base58.bitcoinAlphabet (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
parseInput) of
    Just ByteString
p -> do
      Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Base58 Encoded Bytes" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"0x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
encodeHex ByteString
p)
    Maybe ByteString
Nothing -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
  case Text -> Maybe ByteString
decodeBase58Check Text
parseInput of
    Just ByteString
p -> do
      Text -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
printResult Text
"Base58Check Encoded Bytes" (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"0x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
encodeHex ByteString
p)
    Maybe ByteString
Nothing -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass

-- | Try to execute the given input string as a Morley instruction.
runCode :: Text -> ReplM ()
runCode :: Text -> InputT (StateT SomeStack IO) ()
runCode Text
code = do
  case Text -> Either Text [ParsedOp]
parseInstructions Text
code of
    Left Text
err -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr Text
err
    Right [] -> InputT (StateT SomeStack IO) ()
forall (f :: * -> *). Applicative f => f ()
pass
    Right [ParsedOp]
parsedOps -> do
      let expandedOps :: [ExpandedOp]
expandedOps = ParsedOp -> ExpandedOp
expand (ParsedOp -> ExpandedOp) -> [ParsedOp] -> [ExpandedOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsedOp]
parsedOps
      StateT SomeStack IO SomeStack
-> InputT (StateT SomeStack IO) SomeStack
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT SomeStack IO SomeStack
forall s (m :: * -> *). MonadState s m => m s
get InputT (StateT SomeStack IO) SomeStack
-> (SomeStack -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
forall a b.
InputT (StateT SomeStack IO) a
-> (a -> InputT (StateT SomeStack IO) b)
-> InputT (StateT SomeStack IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeStack {Rec Value t
HST t
stValues :: ()
stTypes :: ()
stValues :: Rec Value t
stTypes :: HST t
..} -> case HST t -> Maybe (HST t)
forall {k} (a :: k) (b :: k) (t :: k -> *).
(SingI a, SingI b, SDecide k) =>
t a -> Maybe (t b)
castSing HST t
stTypes of
          Just HST t
hstInp -> case TypeCheckOptions
-> TypeCheckResult ExpandedOp (SomeTcInstr t)
-> Either (TcError' ExpandedOp) (SomeTcInstr t)
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
tcOptions (TypeCheckResult ExpandedOp (SomeTcInstr t)
 -> Either (TcError' ExpandedOp) (SomeTcInstr t))
-> (ReaderT
      (TypeCheckEnv ExpandedOp)
      (ReaderT TypeCheckOptions (ExceptT (TcError' ExpandedOp) Identity))
      (SomeTcInstr t)
    -> TypeCheckResult ExpandedOp (SomeTcInstr t))
-> ReaderT
     (TypeCheckEnv ExpandedOp)
     (ReaderT TypeCheckOptions (ExceptT (TcError' ExpandedOp) Identity))
     (SomeTcInstr t)
-> Either (TcError' ExpandedOp) (SomeTcInstr t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  (TypeCheckEnv ExpandedOp)
  (ReaderT TypeCheckOptions (ExceptT (TcError' ExpandedOp) Identity))
  (SomeTcInstr t)
-> TypeCheckResult ExpandedOp (SomeTcInstr t)
TypeCheck ExpandedOp (SomeTcInstr t)
-> TypeCheckResult ExpandedOp (SomeTcInstr t)
forall op (t :: [T]).
TypeCheck op (SomeTcInstr t) -> TypeCheckResult op (SomeTcInstr t)
runTypeCheckIsolated (ReaderT
   (TypeCheckEnv ExpandedOp)
   (ReaderT TypeCheckOptions (ExceptT (TcError' ExpandedOp) Identity))
   (SomeTcInstr t)
 -> Either (TcError' ExpandedOp) (SomeTcInstr t))
-> ReaderT
     (TypeCheckEnv ExpandedOp)
     (ReaderT TypeCheckOptions (ExceptT (TcError' ExpandedOp) Identity))
     (SomeTcInstr t)
-> Either (TcError' ExpandedOp) (SomeTcInstr t)
forall a b. (a -> b) -> a -> b
$
                                [ExpandedOp] -> HST t -> TypeCheck ExpandedOp (SomeTcInstr t)
forall (inp :: [T]).
SingI inp =>
[ExpandedOp] -> HST inp -> TypeCheck ExpandedOp (SomeTcInstr inp)
typeCheckList [ExpandedOp]
expandedOps HST t
hstInp of
            Right SomeTcInstr t
someInstr -> do
              case SomeTcInstr t
someInstr of
                HST t
_ :/ (Instr t out
instr ::: HST out
hstOut)-> case ContractEnv
-> Instr t out
-> Rec Value t
-> Either (MichelsonFailureWithStack Void) (Rec Value out)
forall (inp :: [T]) (out :: [T]).
ContractEnv
-> Instr inp out
-> Rec Value inp
-> Either (MichelsonFailureWithStack Void) (Rec Value out)
interpretInstr ContractEnv
forall (m :: * -> *). Applicative m => ContractEnv' m
dummyContractEnv Instr t out
instr Rec Value t
stValues of
                  Right Rec Value out
recOut -> do
                    StateT SomeStack IO () -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SomeStack IO () -> InputT (StateT SomeStack IO) ())
-> StateT SomeStack IO () -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ SomeStack -> StateT SomeStack IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Rec Value out -> HST out -> SomeStack
forall (t :: [T]). SingI t => Rec Value t -> HST t -> SomeStack
SomeStack Rec Value out
recOut HST out
hstOut)
                    InputT (StateT SomeStack IO) ()
printStack
                  Left MichelsonFailureWithStack Void
michelsonFail -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (MichelsonFailureWithStack Void -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty MichelsonFailureWithStack Void
michelsonFail)
                HST t
_ :/ (AnyOutInstr forall (out :: [T]). Instr t out
_) -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
"Encountered a FAILWITH instruction"
            Left TcError' ExpandedOp
err -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ TcError' ExpandedOp -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty TcError' ExpandedOp
err
          Maybe (HST t)
Nothing -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr Text
"Casting stack failed"

printHelp :: ReplM ()
printHelp :: InputT (StateT SomeStack IO) ()
printHelp = Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
"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 :: InputT (StateT SomeStack IO) ()
printStack = StateT SomeStack IO SomeStack
-> InputT (StateT SomeStack IO) SomeStack
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT SomeStack IO SomeStack
forall s (m :: * -> *). MonadState s m => m s
get InputT (StateT SomeStack IO) SomeStack
-> (SomeStack -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
forall a b.
InputT (StateT SomeStack IO) a
-> (a -> InputT (StateT SomeStack IO) b)
-> InputT (StateT SomeStack IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  SomeStack Rec Value t
stk HST t
hst -> do
    Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
"--"
    Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> InputT (StateT SomeStack IO) ())
-> Text -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ Doc -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty (Doc -> Text) -> Doc -> Text
forall a b. (a -> b) -> a -> b
$ Rec Value t -> HST t -> Doc
forall (t :: [T]). Rec Value t -> HST t -> Doc
showStack Rec Value t
stk HST t
hst

emptyStack :: SomeStack
emptyStack :: SomeStack
emptyStack = Rec Value '[] -> HST '[] -> SomeStack
forall (t :: [T]). SingI t => Rec Value t -> HST t -> SomeStack
SomeStack Rec Value '[]
forall {u} (a :: u -> *). Rec a '[]
RNil HST '[]
SNil

parseInstructions :: Text -> Either Text [ParsedOp]
parseInstructions :: Text -> Either Text [ParsedOp]
parseInstructions Text
src =
  case Parser [ParsedOp]
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) [ParsedOp]
forall a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv (Parser () -> Parser [ParsedOp]
forall a. Parser a -> Parser [ParsedOp]
rawOpsSequence (Parser () -> Parser [ParsedOp]) -> Parser () -> Parser [ParsedOp]
forall a b. (a -> b) -> a -> b
$ () -> Parser ()
forall a. a -> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) MichelsonSource
MSUnspecified Text
src of
    Right [ParsedOp]
p -> [ParsedOp] -> Either Text [ParsedOp]
forall a b. b -> Either a b
Right [ParsedOp]
p
    Left ParseErrorBundle Text CustomParserException
err -> Text -> Either Text [ParsedOp]
forall a b. a -> Either a b
Left (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomParserException -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text CustomParserException
err)

tcOptions :: TypeCheckOptions
tcOptions :: TypeCheckOptions
tcOptions = TypeCheckOptions
  { tcVerbose :: Bool
tcVerbose = Bool
False
  , tcStrict :: Bool
tcStrict = Bool
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 :: forall (t :: T) (xs :: [T]).
SingI xs =>
Value t
-> HST xs -> Either Text (Dict (SingI (t : xs)), HST (t : xs))
addValueToHST Value t
v HST xs
hstIn = case Value t -> Dict (SingI t)
forall (instr :: [T] -> [T] -> *) (t :: T).
Value' instr t -> Dict (SingI t)
T.valueTypeSanity Value t
v of
  Dict (SingI t)
T.Dict -> case forall (t :: T).
SingI t =>
Either NotWellTyped (Dict (WellTyped t))
T.getWTP @t of
    Right Dict (WellTyped t)
wtpDict -> (Dict (SingI (t : xs)), HST (t : xs))
-> Either Text (Dict (SingI (t : xs)), HST (t : xs))
forall a b. b -> Either a b
Right (Dict (SingI (t : xs))
forall (a :: Constraint). a => Dict a
T.Dict, (forall {k} (a :: k). SingI a => Sing a
forall (a :: T). SingI a => Sing a
T.sing @t, Dict (WellTyped t)
wtpDict) (SingT t, Dict (WellTyped t)) -> HST xs -> HST (t : xs)
forall (x :: T) (xs :: [T]).
(SingI x, SingI xs) =>
(SingT x, Dict (WellTyped x)) -> HST xs -> HST (x : xs)
::&  HST xs
hstIn)
    Left NotWellTyped
e -> Text -> Either Text (Dict (SingI (t : xs)), HST (t : xs))
forall a b. a -> Either a b
Left (Text -> Either Text (Dict (SingI (t : xs)), HST (t : xs)))
-> Text -> Either Text (Dict (SingI (t : xs)), HST (t : xs))
forall a b. (a -> b) -> a -> b
$ NotWellTyped -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty NotWellTyped
e

dumpStackToFile :: FilePath -> ReplM ()
dumpStackToFile :: String -> InputT (StateT SomeStack IO) ()
dumpStackToFile String
fname =
 StateT SomeStack IO SomeStack
-> InputT (StateT SomeStack IO) SomeStack
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT SomeStack IO SomeStack
forall s (m :: * -> *). MonadState s m => m s
get InputT (StateT SomeStack IO) SomeStack
-> (SomeStack -> InputT (StateT SomeStack IO) ())
-> InputT (StateT SomeStack IO) ()
forall a b.
InputT (StateT SomeStack IO) a
-> (a -> InputT (StateT SomeStack IO) b)
-> InputT (StateT SomeStack IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  SomeStack Rec Value t
stk HST t
hst -> case Rec Value t -> HST t -> Either Text [(Text, Text)]
forall (t :: [T]).
Rec Value t -> HST t -> Either Text [(Text, Text)]
dumpStack Rec Value t
stk HST t
hst of
    Right [(Text, Text)]
stkd -> IO () -> InputT (StateT SomeStack IO) ()
forall a. IO a -> InputT (StateT SomeStack IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT (StateT SomeStack IO) ())
-> IO () -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Prelude.catch (String -> ByteString -> IO ()
BSL.writeFile String
fname (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode [(Text, Text)]
stkd) IOException -> IO ()
handler
    Left Text
err -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr Text
err
  where
    handler :: IOException -> IO ()
    handler :: IOException -> IO ()
handler IOException
e = Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e

loadStackFromFile :: FilePath -> ReplM ()
loadStackFromFile :: String -> InputT (StateT SomeStack IO) ()
loadStackFromFile String
fname = do
  Either Text SomeStack
mStack <- IO (Either Text SomeStack)
-> InputT (StateT SomeStack IO) (Either Text SomeStack)
forall a. IO a -> InputT (StateT SomeStack IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text SomeStack)
 -> InputT (StateT SomeStack IO) (Either Text SomeStack))
-> IO (Either Text SomeStack)
-> InputT (StateT SomeStack IO) (Either Text SomeStack)
forall a b. (a -> b) -> a -> b
$ (IO (Either Text SomeStack)
 -> (IOException -> IO (Either Text SomeStack))
 -> IO (Either Text SomeStack))
-> (IOException -> IO (Either Text SomeStack))
-> IO (Either Text SomeStack)
-> IO (Either Text SomeStack)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Either Text SomeStack)
-> (IOException -> IO (Either Text SomeStack))
-> IO (Either Text SomeStack)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Prelude.catch IOException -> IO (Either Text SomeStack)
forall a. IOException -> IO (Either Text a)
handler (IO (Either Text SomeStack) -> IO (Either Text SomeStack))
-> IO (Either Text SomeStack) -> IO (Either Text SomeStack)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
stackTxt <- String -> IO ByteString
BSL.readFile String
fname
    case forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode @[(Text, Text)] ByteString
stackTxt of
      Just [(Text, Text)]
s -> Either Text SomeStack -> IO (Either Text SomeStack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text SomeStack -> IO (Either Text SomeStack))
-> Either Text SomeStack -> IO (Either Text SomeStack)
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Either Text SomeStack
loadStack [(Text, Text)]
s
      Maybe [(Text, Text)]
Nothing -> Either Text SomeStack -> IO (Either Text SomeStack)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text SomeStack -> IO (Either Text SomeStack))
-> Either Text SomeStack -> IO (Either Text SomeStack)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text SomeStack
forall a b. a -> Either a b
Left Text
"Decoding error when parsing stack data from file"
  case Either Text SomeStack
mStack of
    Right SomeStack
stk -> StateT SomeStack IO () -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SomeStack IO () -> InputT (StateT SomeStack IO) ())
-> StateT SomeStack IO () -> InputT (StateT SomeStack IO) ()
forall a b. (a -> b) -> a -> b
$ SomeStack -> StateT SomeStack IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SomeStack
stk
    Left Text
err -> Text -> InputT (StateT SomeStack IO) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
printErr Text
err
  where
    handler :: IOException -> IO (Either Text a)
    handler :: forall a. IOException -> IO (Either Text a)
handler IOException
e = Either Text a -> IO (Either Text a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> IO (Either Text a))
-> Either Text a -> IO (Either Text a)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e

-- | Dump stack as a list of tuples that represent (value, type) pairs.
dumpStack :: forall t. Rec T.Value t -> HST t -> Either Text [(Text, Text)]
dumpStack :: forall (t :: [T]).
Rec Value t -> HST t -> Either Text [(Text, Text)]
dumpStack Rec Value t
RNil HST t
_ = [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right []
dumpStack ((Value r
v :: T.Value a) :& Rec Value rs
rst) ((SingT x
notes, Dict (WellTyped x)
_) ::& HST xs
rHst) = case Value r -> Dict (SingI r)
forall (instr :: [T] -> [T] -> *) (t :: T).
Value' instr t -> Dict (SingI t)
T.valueTypeSanity Value r
v of
  Dict (SingI r)
T.Dict -> case Sing 'PSOp -> Sing r -> TPresence 'PSOp r
forall (p :: TPredicateSym) (ty :: T).
Sing p -> Sing ty -> TPresence p ty
T.checkTPresence Sing 'PSOp
SingTPredicateSym 'PSOp
T.SPSOp (forall {k} (a :: k). SingI a => Sing a
forall (a :: T). SingI a => Sing a
T.sing @a) of
    TPresence 'PSOp r
T.TAbsent -> case Rec Value rs -> HST rs -> Either Text [(Text, Text)]
forall (t :: [T]).
Rec Value t -> HST t -> Either Text [(Text, Text)]
dumpStack Rec Value rs
rst HST rs
HST xs
rHst of
      Right [(Text, Text)]
t -> [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. b -> Either a b
Right ([(Text, Text)] -> Either Text [(Text, Text)])
-> [(Text, Text)] -> Either Text [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Value r -> Text
forall a b. (RenderDoc a, FromSimpleDoc b) => Bool -> a -> b
printRenderDoc Bool
True Value r
v, Bool -> Demote T -> Text
forall a b. (RenderDoc a, FromSimpleDoc b) => Bool -> a -> b
printRenderDoc Bool
True (Sing r -> Demote T
forall k (a :: k). SingKind k => Sing a -> Demote k
forall (a :: T). Sing a -> Demote T
fromSing Sing r
SingT x
notes)) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
t
      Left Text
e -> Text -> Either Text [(Text, Text)]
forall a b. a -> Either a b
Left Text
e
    TPresence 'PSOp r
T.TPresent ->  Text -> Either Text [(Text, Text)]
forall a b. a -> Either a b
Left Text
"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 :: [(Text, Text)] -> Either Text SomeStack
loadStack = (Either Text SomeStack
 -> Element [(Text, Text)] -> Either Text SomeStack)
-> Either Text SomeStack -> [(Text, Text)] -> Either Text SomeStack
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
forall b.
(b -> Element [(Text, Text)] -> b) -> b -> [(Text, Text)] -> b
foldl' Either Text SomeStack -> (Text, Text) -> Either Text SomeStack
Either Text SomeStack
-> Element [(Text, Text)] -> Either Text SomeStack
buildStack (SomeStack -> Either Text SomeStack
forall a b. b -> Either a b
Right SomeStack
emptyStack) ([(Text, Text)] -> Either Text SomeStack)
-> ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)]
-> Either Text SomeStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a]
reverse
  where
    buildStack :: Either Text SomeStack -> (Text, Text) -> Either Text SomeStack
    buildStack :: Either Text SomeStack -> (Text, Text) -> Either Text SomeStack
buildStack (Left Text
err) (Text, Text)
_ = Text -> Either Text SomeStack
forall a b. a -> Either a b
Left Text
err
    buildStack (Right (SomeStack Rec Value t
stk HST t
hst)) (Text
txVal, Text
txTyp) = case
      (MichelsonSource -> Text -> Either ParserException Value
parseExpandValue MichelsonSource
"stack" Text
txVal, Parsec CustomParserException Text Ty
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) Ty
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec CustomParserException Text Ty
type_ String
"" Text
txTyp) of
        (Right Value
val, Right Ty
typ) ->
          case TypeCheckOptions
-> TypeCheckResult ExpandedOp SomeValue
-> Either (TcError' ExpandedOp) SomeValue
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
tcOptions (TypeCheckResult ExpandedOp SomeValue
 -> Either (TcError' ExpandedOp) SomeValue)
-> TypeCheckResult ExpandedOp SomeValue
-> Either (TcError' ExpandedOp) SomeValue
forall a b. (a -> b) -> a -> b
$ TcOriginatedContracts
-> Ty -> Value -> TypeCheckResult ExpandedOp SomeValue
typeCheckParameter TcOriginatedContracts
forall a. Monoid a => a
mempty Ty
typ Value
val of
            Right (T.SomeValue Value t
tVal) ->
              case Value t -> HST t -> Either Text (Dict (SingI (t : t)), HST (t : t))
forall (t :: T) (xs :: [T]).
SingI xs =>
Value t
-> HST xs -> Either Text (Dict (SingI (t : xs)), HST (t : xs))
addValueToHST Value t
tVal HST t
hst of
                Right (Dict (SingI (t : t))
T.Dict, HST (t : t)
newHst) -> SomeStack -> Either Text SomeStack
forall a b. b -> Either a b
Right (SomeStack -> Either Text SomeStack)
-> SomeStack -> Either Text SomeStack
forall a b. (a -> b) -> a -> b
$ Rec Value (t : t) -> HST (t : t) -> SomeStack
forall (t :: [T]). SingI t => Rec Value t -> HST t -> SomeStack
SomeStack (Value t
tVal Value t -> Rec Value t -> Rec Value (t : t)
forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Value t
stk) HST (t : t)
newHst
                Left Text
err -> Text -> Either Text SomeStack
forall a b. a -> Either a b
Left Text
err
            Left TcError' ExpandedOp
tcError -> Text -> Either Text SomeStack
forall a b. a -> Either a b
Left (Text -> Either Text SomeStack) -> Text -> Either Text SomeStack
forall a b. (a -> b) -> a -> b
$ TcError' ExpandedOp -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty TcError' ExpandedOp
tcError
        (Left ParserException
err, Either (ParseErrorBundle Text CustomParserException) Ty
_) -> Text -> Either Text SomeStack
forall a b. a -> Either a b
Left (Text -> Either Text SomeStack) -> Text -> Either Text SomeStack
forall a b. (a -> b) -> a -> b
$ ParserException -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty ParserException
err
        (Either ParserException Value
_, Left ParseErrorBundle Text CustomParserException
err) -> Text -> Either Text SomeStack
forall a b. a -> Either a b
Left (Text -> Either Text SomeStack) -> Text -> Either Text SomeStack
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomParserException -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text CustomParserException
err

showStack :: forall t. Rec T.Value t -> HST t -> Doc
showStack :: forall (t :: [T]). Rec Value t -> HST t -> Doc
showStack Rec Value t
RNil HST t
_ = Doc
"--"
showStack ((Value r
v :: T.Value a) :& Rec Value rs
rst) ((SingT x
notes, Dict (WellTyped x)
_) ::& HST xs
rHst)  = case Value r -> Dict (SingI r)
forall (instr :: [T] -> [T] -> *) (t :: T).
Value' instr t -> Dict (SingI t)
T.valueTypeSanity Value r
v of
  Dict (SingI r)
T.Dict -> case Sing 'PSOp -> Sing r -> TPresence 'PSOp r
forall (p :: TPredicateSym) (ty :: T).
Sing p -> Sing ty -> TPresence p ty
T.checkTPresence Sing 'PSOp
SingTPredicateSym 'PSOp
T.SPSOp (forall {k} (a :: k). SingI a => Sing a
forall (a :: T). SingI a => Sing a
T.sing @a) of
    TPresence 'PSOp r
T.TAbsent -> -- print nice if value has no operations
      Doc -> Doc
addSuffix (Value r -> Doc
forall a. Buildable a => a -> Doc
build Value r
v)
    TPresence 'PSOp r
T.TPresent ->          -- else just call show, and indicate value has operation inside
      case (Value r
v, forall {k} (a :: k). SingI a => Sing a
forall (a :: T). SingI a => Sing a
T.sing @a) of
        (T.VList [], T.STList Sing n
SingT t1
T.STOperation) -> Doc
"{ } :: list operation\n" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Rec Value rs -> HST rs -> Doc
forall (t :: [T]). Rec Value t -> HST t -> Doc
showStack Rec Value rs
rst HST rs
HST xs
rHst
        (Value r, SingT r)
_ -> Doc -> Doc
addSuffix (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"(operations container:" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Value r -> Doc
forall a b. (Buildable a, FromDoc b) => a -> b
pretty Value r
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")"
  where
    addSuffix :: Doc -> Doc
addSuffix Doc
val =
      Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc -> Doc
forall ann. Doc ann -> Doc ann
group (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
val Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
forall ann. Doc ann
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
":: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
forall ann. Doc ann -> Doc ann
align (SingT x -> Doc
forall a b. (Buildable a, FromDoc b) => a -> b
pretty SingT x
notes)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
forall ann. Doc ann
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Rec Value rs -> HST rs -> Doc
forall (t :: [T]). Rec Value t -> HST t -> Doc
showStack Rec Value rs
rst HST rs
HST xs
rHst