-- 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 = 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) => Text -> Text -> ReplM ()
tryParseMichelsonValue msg parseInput =
case readValue @t MSStdin parseInput of
Right s -> printResult msg $ pretty 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 ', tries to parse the given string using known formats\n\
\ ':base58encode ', prints the base58 encoding of a bytestring\n\
\ ':genkeys ', generates a key pair with hash using the seed string \n\
\ ':loadstack ', loads the stack from a file\n\
\ ':dumpstack ', 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 $ pretty $ showStack stk hst
emptyStack :: SomeStack
emptyStack = SomeStack RNil SNil
parseInstructions :: Text -> Either Text [ParsedOp]
parseInstructions src =
case parseNoEnv (rawOpsSequence $ pure ()) 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 e -> Left $ pretty e
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 list 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.checkTPresence T.SPSOp (T.sing @a) of
T.TAbsent -> case dumpStack rst rHst of
Right t -> Right $ (printRenderDoc True v, printRenderDoc True (fromSing notes)) : t
Left e -> Left e
T.TPresent -> 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 -> Doc
showStack RNil _ = "--"
showStack ((v :: T.Value a) :& rst) ((notes, _) ::& rHst) = case T.valueTypeSanity v of
T.Dict -> case T.checkTPresence T.SPSOp (T.sing @a) of
T.TAbsent -> -- print nice if value has no operations
addSuffix (build v)
T.TPresent -> -- 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 =
nest 2 (group $ val <> line <> ":: " <> align (pretty notes)) <> line <> showStack rst rHst