-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
{-|
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 qualified Data.Aeson as Aeson
import qualified Data.ByteString.Base58 as Base58
import qualified Data.ByteString.Lazy as BSL
import Data.List (stripPrefix)
import Data.Text as T (length, replicate, strip)
import qualified Data.Text as T (stripPrefix)
import Data.Vinyl (Rec(..))
import Fmt (fmt, pretty)
import System.Console.Haskeline
import Text.Megaparsec (parse)
import Morley.Michelson.Interpret (interpretInstr)
import Morley.Michelson.Macro (ParsedOp, expandList)
import Morley.Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_)
import Morley.Michelson.Parser.Types (MichelsonSource(..), noLetEnv)
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
(SomeInstr(..), SomeInstrOut(..), TypeCheckOptions(..), getWTP, runTypeCheckIsolated,
typeCheckingWith)
import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)
import Morley.Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))
import qualified Morley.Michelson.Typed as T
import qualified Morley.Michelson.Untyped 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" (formatKeyHash 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 parseKeyHash parseInput of
Right p -> do
printResult "KeyHash" $ formatKeyHash 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 = expandList 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 $ show 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 $ 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 getWTP @t of
Right wtpDict -> Right (T.Dict, (T.starNotes @t, wtpDict, U.noAnn) ::& hstIn)
Left (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.SingI t => T.Notes t -> U.VarAnn -> Text
renderType notes vann = let
U.Ty t tann = T.mkUType notes
in renderT t (U.fullAnnSet [tann] [] [vann])
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, _, vann) ::& 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 vann) : 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 (runReaderT type_ noLetEnv) "" 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 $ show 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, _, vann) ::& 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:" <> show v <> ")"
where
addSuffix val = val <>" :: " <> renderType notes vann <> "\n" <> showStack rst rHst