-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Michelson.Parser
  ( -- * Main parser type
    Parser

  -- * Parsers
  , program
  , value

  -- * Errors
  , CustomParserException (..)
  , ParseErrorBundle
  , ParserException (..)
  , StringLiteralParserException (..)

  -- * Additional helpers
  , MichelsonSource (..)
  , codeSrc
  , parseNoEnv
  , parseValue
  , parseExpandValue
  , parseType
  , rawOpsSequence

  -- * For tests
  , codeEntry
  , ops
  , type_
  , stringLiteral
  , bytesLiteral
  , intLiteral
  , parsedOp
  , cbParameterBare

  -- * Quoters
  , utypeQ
  , uparamTypeQ
  , notes

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import Data.Default (def)
import Fmt (nameF, pretty, unlinesF, (+|), (|+))
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Text.Megaparsec
  (Parsec, choice, eitherP, eof, errorBundlePretty, getSourcePos, hidden, parse, sepEndBy, try)
import Text.Megaparsec.Pos (SourcePos(..), unPos)

import Morley.Michelson.ErrorPos (SrcPos(..), mkPos)
import Morley.Michelson.Macro
import Morley.Michelson.Parser.Common
import Morley.Michelson.Parser.Error
import Morley.Michelson.Parser.Instr
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Macro
import Morley.Michelson.Parser.Type
import Morley.Michelson.Parser.Types
import Morley.Michelson.Parser.Value
import Morley.Michelson.Typed.Extract (withUType)
import Morley.Michelson.Untyped
import Morley.Michelson.Untyped qualified as U

{- $setup
>>> import Morley.Michelson.Parser.Lexer
>>> import Text.Megaparsec (sepEndBy)
-}

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Parse with empty environment
parseNoEnv
  :: Parser a
  -> MichelsonSource
  -> Text
  -> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv :: forall a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser a
p MichelsonSource
src = Parser a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser a
p Parser a
-> ParsecT CustomParserException Text Identity () -> Parser a
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomParserException Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) (MichelsonSource -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty MichelsonSource
src)

-------------------------------------------------------------------------------
-- Parsers
-------------------------------------------------------------------------------

-- Contract
------------------

-- | Michelson contract
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program = Parsec CustomParserException Text (Contract' ParsedOp)
programInner Parsec CustomParserException Text (Contract' ParsedOp)
-> ParsecT CustomParserException Text Identity ()
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomParserException Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

programInner :: Parser (Contract' ParsedOp)
programInner :: Parsec CustomParserException Text (Contract' ParsedOp)
programInner = ParsecT CustomParserException Text Identity ()
mSpace ParsecT CustomParserException Text Identity ()
-> Parsec CustomParserException Text (Contract' ParsedOp)
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec CustomParserException Text (Contract' ParsedOp)
contract

cbParameter :: Parser ParameterType
cbParameter :: Parser ParameterType
cbParameter = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"parameter" ParsecT CustomParserException Text Identity ()
-> Parser ParameterType -> Parser ParameterType
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ParameterType
cbParameterBare

cbParameterBare :: Parser ParameterType
cbParameterBare :: Parser ParameterType
cbParameterBare = (Ty -> RootAnn -> ParameterType) -> (Ty, RootAnn) -> ParameterType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ty -> RootAnn -> ParameterType
ParameterType ((Ty, RootAnn) -> ParameterType)
-> ((RootAnn, Ty) -> (Ty, RootAnn))
-> (RootAnn, Ty)
-> ParameterType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RootAnn, Ty) -> (Ty, RootAnn)
forall a b. (a, b) -> (b, a)
swap ((RootAnn, Ty) -> ParameterType)
-> ParsecT CustomParserException Text Identity (RootAnn, Ty)
-> Parser ParameterType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity (RootAnn, Ty)
field

cbStorage :: Parser Ty
cbStorage :: Parser Ty
cbStorage = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"storage" ParsecT CustomParserException Text Identity ()
-> Parser Ty -> Parser Ty
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Ty
type_

cbCode :: Parser ParsedOp
cbCode :: Parser ParsedOp
cbCode = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Text
Tokens Text
"code" ParsecT CustomParserException Text Identity ()
-> Parser ParsedOp -> Parser ParsedOp
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ParsedOp
codeEntry

cbView :: Parser (View' ParsedOp)
cbView :: Parser (View' ParsedOp)
cbView = do
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Text
Tokens Text
"view"
  ViewName
viewName <- Parser ViewName
viewName_
  Ty
viewArgument <- Parser Ty
type_
  Ty
viewReturn <- Parser Ty
type_
  ParsedOp
viewCode <- Parser ParsedOp
codeEntry
  return View{Ty
ViewName
ParsedOp
viewName :: ViewName
viewArgument :: Ty
viewReturn :: Ty
viewCode :: ParsedOp
viewName :: ViewName
viewArgument :: Ty
viewReturn :: Ty
viewCode :: ParsedOp
..}

contractBlock :: Parser (ContractBlock ParsedOp)
contractBlock :: Parser (ContractBlock ParsedOp)
contractBlock = [Parser (ContractBlock ParsedOp)]
-> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ (ParameterType -> ContractBlock ParsedOp
forall op. ParameterType -> ContractBlock op
CBParam (ParameterType -> ContractBlock ParsedOp)
-> Parser ParameterType -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParameterType
cbParameter)
  , (Ty -> ContractBlock ParsedOp
forall op. Ty -> ContractBlock op
CBStorage (Ty -> ContractBlock ParsedOp)
-> Parser Ty -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Ty
cbStorage)
  , (ParsedOp -> ContractBlock ParsedOp
forall op. op -> ContractBlock op
CBCode (ParsedOp -> ContractBlock ParsedOp)
-> Parser ParsedOp -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedOp
cbCode)
  , (View' ParsedOp -> ContractBlock ParsedOp
forall op. View' op -> ContractBlock op
CBView (View' ParsedOp -> ContractBlock ParsedOp)
-> Parser (View' ParsedOp) -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (View' ParsedOp)
cbView)
  ]

-- | This ensures that the error message will point to the correct line.
ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate :: [ContractBlock ParsedOp]
-> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
ensureNotDuplicate [ContractBlock ParsedOp]
blocks ContractBlock ParsedOp
result =
  let
    failDuplicateField :: a -> m a
failDuplicateField a
a = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ Doc
"Duplicate contract field: " Doc -> Doc -> String
forall b. FromDoc b => Doc -> Doc -> b
+| a
a a -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
  in
    case (ContractBlock ParsedOp
result, [ContractBlock ParsedOp]
blocks) of
      (CBParam ParameterType
_, CBParam ParameterType
_ : [ContractBlock ParsedOp]
_) -> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
forall {m :: * -> *} {a} {a}.
(MonadFail m, Buildable a) =>
a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (CBStorage Ty
_, CBStorage Ty
_: [ContractBlock ParsedOp]
_) -> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
forall {m :: * -> *} {a} {a}.
(MonadFail m, Buildable a) =>
a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (CBCode ParsedOp
_, CBCode ParsedOp
_: [ContractBlock ParsedOp]
_) -> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
forall {m :: * -> *} {a} {a}.
(MonadFail m, Buildable a) =>
a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (CBView View{viewName :: forall op. View' op -> ViewName
viewName=ViewName
n1}, CBView View{viewName :: forall op. View' op -> ViewName
viewName=ViewName
n2} : [ContractBlock ParsedOp]
_)
        | ViewName
n1 ViewName -> ViewName -> Bool
forall a. Eq a => a -> a -> Bool
== ViewName
n2 -> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
forall {m :: * -> *} {a} {a}.
(MonadFail m, Buildable a) =>
a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (ContractBlock ParsedOp
_, ContractBlock ParsedOp
_:[ContractBlock ParsedOp]
xs) -> [ContractBlock ParsedOp]
-> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
ensureNotDuplicate [ContractBlock ParsedOp]
xs ContractBlock ParsedOp
result
      (ContractBlock ParsedOp
_, []) -> () -> ParsecT CustomParserException Text Identity ()
forall a. a -> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Michelson contract
contract :: Parser (Contract' ParsedOp)
contract :: Parsec CustomParserException Text (Contract' ParsedOp)
contract = do
  ParsecT CustomParserException Text Identity ()
mSpace
  [ContractBlock ParsedOp]
result <- Parser [ContractBlock ParsedOp] -> Parser [ContractBlock ParsedOp]
forall a. Parser a -> Parser a
braces Parser [ContractBlock ParsedOp]
contractTuple Parser [ContractBlock ParsedOp]
-> Parser [ContractBlock ParsedOp]
-> Parser [ContractBlock ParsedOp]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [ContractBlock ParsedOp]
contractTuple
  (NonEmpty ContractBlockError
 -> Parsec CustomParserException Text (Contract' ParsedOp))
-> (Contract' ParsedOp
    -> Parsec CustomParserException Text (Contract' ParsedOp))
-> Either (NonEmpty ContractBlockError) (Contract' ParsedOp)
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parsec CustomParserException Text (Contract' ParsedOp)
forall a. String -> ParsecT CustomParserException Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parsec CustomParserException Text (Contract' ParsedOp))
-> (NonEmpty ContractBlockError -> String)
-> NonEmpty ContractBlockError
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty (Doc -> String)
-> (NonEmpty ContractBlockError -> Doc)
-> NonEmpty ContractBlockError
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Contract parsing error" (Doc -> Doc)
-> (NonEmpty ContractBlockError -> Doc)
-> NonEmpty ContractBlockError
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ContractBlockError -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF) Contract' ParsedOp
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall a. a -> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty ContractBlockError) (Contract' ParsedOp)
 -> Parsec CustomParserException Text (Contract' ParsedOp))
-> Either (NonEmpty ContractBlockError) (Contract' ParsedOp)
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall a b. (a -> b) -> a -> b
$
    [ContractBlock ParsedOp]
-> Either (NonEmpty ContractBlockError) (Contract' ParsedOp)
forall op.
[ContractBlock op]
-> Either (NonEmpty ContractBlockError) (Contract' op)
orderContractBlock [ContractBlock ParsedOp]
result
  where
    -- @ensureNotDuplicate@ provides a better message and point to the correct line
    -- when the parser fails.
    contractTuple :: Parser [ContractBlock ParsedOp]
contractTuple = ([ContractBlock ParsedOp] -> [ContractBlock ParsedOp])
-> Parser [ContractBlock ParsedOp]
-> Parser [ContractBlock ParsedOp]
forall a b.
(a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ContractBlock ParsedOp] -> [ContractBlock ParsedOp]
forall a. [a] -> [a]
reverse (Parser [ContractBlock ParsedOp]
 -> Parser [ContractBlock ParsedOp])
-> (StateT
      [ContractBlock ParsedOp]
      (ParsecT CustomParserException Text Identity)
      [()]
    -> Parser [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     [()]
-> Parser [ContractBlock ParsedOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ContractBlock ParsedOp]
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     [()]
-> Parser [ContractBlock ParsedOp]
forall (f :: * -> *) s a. Functor f => s -> StateT s f a -> f s
executingStateT [] (StateT
   [ContractBlock ParsedOp]
   (ParsecT CustomParserException Text Identity)
   [()]
 -> Parser [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     [()]
-> Parser [ContractBlock ParsedOp]
forall a b. (a -> b) -> a -> b
$ do
      (StateT
  [ContractBlock ParsedOp]
  (ParsecT CustomParserException Text Identity)
  ()
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     [()]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` ParsecT CustomParserException Text Identity ()
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [ContractBlock ParsedOp] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomParserException Text Identity ()
semicolon) (StateT
   [ContractBlock ParsedOp]
   (ParsecT CustomParserException Text Identity)
   ()
 -> StateT
      [ContractBlock ParsedOp]
      (ParsecT CustomParserException Text Identity)
      [()])
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     [()]
forall a b. (a -> b) -> a -> b
$ do
        ContractBlock ParsedOp
r <- Parser (ContractBlock ParsedOp)
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     (ContractBlock ParsedOp)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [ContractBlock ParsedOp] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser (ContractBlock ParsedOp)
contractBlock
        StateT
  [ContractBlock ParsedOp]
  (ParsecT CustomParserException Text Identity)
  [ContractBlock ParsedOp]
forall s (m :: * -> *). MonadState s m => m s
get StateT
  [ContractBlock ParsedOp]
  (ParsecT CustomParserException Text Identity)
  [ContractBlock ParsedOp]
-> ([ContractBlock ParsedOp]
    -> StateT
         [ContractBlock ParsedOp]
         (ParsecT CustomParserException Text Identity)
         ())
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
forall a b.
StateT
  [ContractBlock ParsedOp]
  (ParsecT CustomParserException Text Identity)
  a
-> (a
    -> StateT
         [ContractBlock ParsedOp]
         (ParsecT CustomParserException Text Identity)
         b)
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[ContractBlock ParsedOp]
prev -> ParsecT CustomParserException Text Identity ()
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [ContractBlock ParsedOp] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomParserException Text Identity ()
 -> StateT
      [ContractBlock ParsedOp]
      (ParsecT CustomParserException Text Identity)
      ())
-> ParsecT CustomParserException Text Identity ()
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
forall a b. (a -> b) -> a -> b
$ [ContractBlock ParsedOp]
-> ContractBlock ParsedOp
-> ParsecT CustomParserException Text Identity ()
ensureNotDuplicate [ContractBlock ParsedOp]
prev ContractBlock ParsedOp
r
        ([ContractBlock ParsedOp] -> [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ParsecT CustomParserException Text Identity)
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ContractBlock ParsedOp
r ContractBlock ParsedOp
-> [ContractBlock ParsedOp] -> [ContractBlock ParsedOp]
forall a. a -> [a] -> [a]
:)

-- Value
------------------

value :: Parser ParsedValue
value :: Parser ParsedValue
value = Parser (ParsedSeq ParsedOp) -> Parser ParsedValue
value' Parser (ParsedSeq ParsedOp)
ops

-- | Parse untyped value from text which comes from something that is
-- not a file (which is often the case). So we assume it does not need
-- any parsing environment.
--
-- >>> parseValue MSUnspecified "{PUSH int aaa}" & either (putStrLn . displayException) (const $ pure ())
-- 1:11:
--   |
-- 1 | {PUSH int aaa}
--   |           ^^^^
-- unexpected "aaa}"
-- expecting value
-- <BLANKLINE>
parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue
parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue
parseValue = (ParseErrorBundle Text CustomParserException -> ParserException)
-> Either (ParseErrorBundle Text CustomParserException) ParsedValue
-> Either ParserException ParsedValue
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text CustomParserException -> ParserException
ParserException (Either (ParseErrorBundle Text CustomParserException) ParsedValue
 -> Either ParserException ParsedValue)
-> (MichelsonSource
    -> Text
    -> Either
         (ParseErrorBundle Text CustomParserException) ParsedValue)
-> MichelsonSource
-> Text
-> Either ParserException ParsedValue
forall a b c. SuperComposition a b c => a -> b -> c
... Parser ParsedValue
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) ParsedValue
forall a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser ParsedValue
value

parseType :: MichelsonSource -> Text -> Either ParserException Ty
parseType :: MichelsonSource -> Text -> Either ParserException Ty
parseType = (ParseErrorBundle Text CustomParserException -> ParserException)
-> Either (ParseErrorBundle Text CustomParserException) Ty
-> Either ParserException Ty
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text CustomParserException -> ParserException
ParserException (Either (ParseErrorBundle Text CustomParserException) Ty
 -> Either ParserException Ty)
-> (MichelsonSource
    -> Text -> Either (ParseErrorBundle Text CustomParserException) Ty)
-> MichelsonSource
-> Text
-> Either ParserException Ty
forall a b c. SuperComposition a b c => a -> b -> c
... Parser Ty
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) Ty
forall a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser Ty
type_

-- | Like 'parseValue', but also expands macros.
parseExpandValue :: MichelsonSource -> Text -> Either ParserException U.Value
parseExpandValue :: MichelsonSource -> Text -> Either ParserException Value
parseExpandValue = (ParsedValue -> Value)
-> Either ParserException ParsedValue
-> Either ParserException Value
forall a b.
(a -> b) -> Either ParserException a -> Either ParserException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedValue -> Value
expandValue (Either ParserException ParsedValue
 -> Either ParserException Value)
-> (MichelsonSource -> Text -> Either ParserException ParsedValue)
-> MichelsonSource
-> Text
-> Either ParserException Value
forall a b c. SuperComposition a b c => a -> b -> c
... MichelsonSource -> Text -> Either ParserException ParsedValue
parseValue

-- Primitive instruction
------------------

prim :: Parser ParsedInstr
prim :: Parser ParsedInstr
prim = Parsec CustomParserException Text (Contract' ParsedOp)
-> Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
primInstr Parsec CustomParserException Text (Contract' ParsedOp)
contract Parser (ParsedSeq ParsedOp)
ops

-- Parsed operations (primitive instructions, macros, extras, etc.)
------------------

-- | Parses code block after "code" keyword of a contract, or code in a view
-- block.
codeEntry :: Parser ParsedOp
codeEntry :: Parser ParsedOp
codeEntry = ([ParsedOp] -> SrcPos -> ParsedOp)
-> SrcPos -> [ParsedOp] -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ParsedOp] -> SrcPos -> ParsedOp
Seq (SrcPos -> [ParsedOp] -> ParsedOp)
-> ParsecT CustomParserException Text Identity SrcPos
-> ParsecT
     CustomParserException Text Identity ([ParsedOp] -> ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity SrcPos
getSrcPos ParsecT
  CustomParserException Text Identity ([ParsedOp] -> ParsedOp)
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> Parser ParsedOp
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomParserException Text Identity [ParsedOp]
bracewrappedOps Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp
parsedOp

bracewrappedOps :: Parser [ParsedOp]
bracewrappedOps :: ParsecT CustomParserException Text Identity [ParsedOp]
bracewrappedOps = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Text
Tokens Text
"{" ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall a.
Parser a -> ParsecT CustomParserException Text Identity [ParsedOp]
rawOpsSequence (Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Text
Tokens Text
"}")

{-| Michelson sequence of instructions, separated with a semicolon. Last
semicolon is optional, semicolon after @}@ is optional.

The first argument is the sequence terminator, that is to say, usually @}@. This
might look mysterious, until one considers the alternatives. For example:

>>> let fmt = either (putStrLn . displayException . ParserException) (const $ pure ())
>>> parseNoEnv (braces (sepEndBy parsedOp semicolon)) "" "{ DIIIP CMPEQ }" & fmt
...
1 | { DIIIP CMPEQ }
  |   ^
unexpected 'D'
expecting '}'
...
>>> parseNoEnv (symbol "{" *> rawOpsSequence (symbol "}")) "" "{ DIIIP CMPEQ }" & fmt
...
1 | { DIIIP CMPEQ }
  |         ^
unexpected 'C'
...

This happens because @braces . sepEndBy@ backtracks a bit too far.

Note that @braces . sepEndBy@ doesn't match Michelson syntax exactly, it's used
as an example only.
-}
rawOpsSequence :: Parser a -> Parser [ParsedOp]
rawOpsSequence :: forall a.
Parser a -> ParsecT CustomParserException Text Identity [ParsedOp]
rawOpsSequence Parser a
endP = ParsecT CustomParserException Text Identity [ParsedOp]
inner ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomParserException Text Identity [ParsedOp]
end
  where
    end :: ParsecT CustomParserException Text Identity [ParsedOp]
end = [] [ParsedOp]
-> Parser a
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall a b.
a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser a
endP
    inner :: ParsecT CustomParserException Text Identity [ParsedOp]
inner = do
      ParsedOp
op <- Parser ParsedOp
parsedOp
      let sep :: ParsecT CustomParserException Text Identity ()
sep = case ParsedOp
op of
            Seq{} -> ParsecT CustomParserException Text Identity (Maybe ())
-> ParsecT CustomParserException Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT CustomParserException Text Identity (Maybe ())
 -> ParsecT CustomParserException Text Identity ())
-> ParsecT CustomParserException Text Identity (Maybe ())
-> ParsecT CustomParserException Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT CustomParserException Text Identity ()
semicolon -- semicolon optional after }
            ParsedOp
_ -> ParsecT CustomParserException Text Identity ()
semicolon
      (ParsedOp
op ParsedOp -> [ParsedOp] -> [ParsedOp]
forall a. a -> [a] -> [a]
:) ([ParsedOp] -> [ParsedOp])
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ParsecT CustomParserException Text Identity ()
sep ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a -> ParsecT CustomParserException Text Identity [ParsedOp]
forall a.
Parser a -> ParsecT CustomParserException Text Identity [ParsedOp]
rawOpsSequence Parser a
endP) ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity [ParsedOp]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomParserException Text Identity [ParsedOp]
end)

{- |
>>> let fmt = either (putStrLn . displayException . ParserException) (const $ pure ())
>>> parseNoEnv parsedOp "" "{a}" & fmt
1:2:
  |
1 | {a}
  |  ^^
unexpected "a}"
expecting '{', '}', macro, or primitive instruction
<BLANKLINE>

>>> parseNoEnv parsedOp "" "{ UNIT; DIIIP CMPEQ }" & fmt
1:15:
  |
1 | { UNIT; DIIIP CMPEQ }
  |               ^
unexpected 'C'
<BLANKLINE>
-}
parsedOp :: Parser ParsedOp
parsedOp :: Parser ParsedOp
parsedOp = do
  SrcPos
pos <- ParsecT CustomParserException Text Identity SrcPos
getSrcPos
  [Parser ParsedOp] -> Parser ParsedOp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
pos (ParsedInstr -> ParsedOp) -> Parser ParsedInstr -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedInstr
prim
    , (Macro -> SrcPos -> ParsedOp) -> SrcPos -> Macro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Macro -> SrcPos -> ParsedOp
Mac SrcPos
pos (Macro -> ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
macro Parser (ParsedSeq ParsedOp)
ops
    , Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden Parser ParsedOp
primOrMac
    , ([ParsedOp] -> SrcPos -> ParsedOp)
-> SrcPos -> [ParsedOp] -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ParsedOp] -> SrcPos -> ParsedOp
Seq SrcPos
pos ([ParsedOp] -> ParsedOp)
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity [ParsedOp]
bracewrappedOps
    ]

getSrcPos :: Parser SrcPos
getSrcPos :: ParsecT CustomParserException Text Identity SrcPos
getSrcPos = do
  SourcePos
sp <- ParsecT CustomParserException Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  let l :: Int
l = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
sp
  let c :: Int
c = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
sp
  -- reindexing starting from 0
  SrcPos -> ParsecT CustomParserException Text Identity SrcPos
forall a. a -> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcPos -> ParsecT CustomParserException Text Identity SrcPos)
-> (Either Text SrcPos -> SrcPos)
-> Either Text SrcPos
-> ParsecT CustomParserException Text Identity SrcPos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text SrcPos -> SrcPos
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text SrcPos
 -> ParsecT CustomParserException Text Identity SrcPos)
-> Either Text SrcPos
-> ParsecT CustomParserException Text Identity SrcPos
forall a b. (a -> b) -> a -> b
$ Pos -> Pos -> SrcPos
SrcPos (Pos -> Pos -> SrcPos)
-> Either Text Pos -> Either Text (Pos -> SrcPos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Either Text Pos
mkPos (Int -> Either Text Pos) -> Int -> Either Text Pos
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Either Text (Pos -> SrcPos)
-> Either Text Pos -> Either Text SrcPos
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Either Text Pos
mkPos (Int -> Either Text Pos) -> Int -> Either Text Pos
forall a b. (a -> b) -> a -> b
$ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

primWithPos :: Parser ParsedInstr -> Parser ParsedOp
primWithPos :: Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
act = do
  SrcPos
srcPos <- ParsecT CustomParserException Text Identity SrcPos
getSrcPos
  (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
srcPos (ParsedInstr -> ParsedOp) -> Parser ParsedInstr -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedInstr
act

macWithPos :: Parser Macro -> Parser ParsedOp
macWithPos :: ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity Macro
act = do
  SrcPos
srcPos <- ParsecT CustomParserException Text Identity SrcPos
getSrcPos
  (Macro -> SrcPos -> ParsedOp) -> SrcPos -> Macro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Macro -> SrcPos -> ParsedOp
Mac SrcPos
srcPos (Macro -> ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity Macro
act

ops :: Parser (ParsedSeq ParsedOp)
ops :: Parser (ParsedSeq ParsedOp)
ops = do
  SrcPos
pos <- ParsecT CustomParserException Text Identity SrcPos
getSrcPos
  [Parser (ParsedSeq ParsedOp)] -> Parser (ParsedSeq ParsedOp)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ [ParsedOp] -> ParsedSeq ParsedOp
forall op. [op] -> ParsedSeq op
PSSequence ([ParsedOp] -> ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity [ParsedOp]
-> Parser (ParsedSeq ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity [ParsedOp]
bracewrappedOps
    , SrcPos -> Macro -> ParsedSeq ParsedOp
forall op. SrcPos -> Macro -> ParsedSeq op
PSSingleMacro SrcPos
pos (Macro -> ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
-> Parser (ParsedSeq ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( ParsecT CustomParserException Text Identity Macro
-> ParsecT CustomParserException Text Identity Macro
forall a. Parser a -> Parser a
parens (Parser (ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
allMacros Parser (ParsedSeq ParsedOp)
ops) ParsecT CustomParserException Text Identity Macro
-> ParsecT CustomParserException Text Identity Macro
-> ParsecT CustomParserException Text Identity Macro
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomParserException Text Identity Macro
allSingleTokenMacros )
    ]

-------------------------------------------------------------------------------
-- Mixed parsers
-- These are needed for better error messages
-------------------------------------------------------------------------------

ifOrIfX :: Parser ParsedOp
ifOrIfX :: Parser ParsedOp
ifOrIfX = do
  SrcPos
pos <- ParsecT CustomParserException Text Identity SrcPos
getSrcPos
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Text
Tokens Text
"IF"
  Either ParsedInstr (ParsedSeq ParsedOp)
a <- Parser ParsedInstr
-> Parser (ParsedSeq ParsedOp)
-> ParsecT
     CustomParserException
     Text
     Identity
     (Either ParsedInstr (ParsedSeq ParsedOp))
forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
eitherP (Parser ParsedInstr -> Parser ParsedInstr
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ParsedInstr -> Parser ParsedInstr)
-> Parser ParsedInstr -> Parser ParsedInstr
forall a b. (a -> b) -> a -> b
$ Parser VarAnn -> Parser ParsedInstr
cmpOp (Parser VarAnn -> Parser ParsedInstr)
-> Parser VarAnn -> Parser ParsedInstr
forall a b. (a -> b) -> a -> b
$ VarAnn -> Parser VarAnn
forall a. a -> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VarAnn
forall a. Default a => a
def) Parser (ParsedSeq ParsedOp)
ops
  case Either ParsedInstr (ParsedSeq ParsedOp)
a of
    Left ParsedInstr
cmp -> (Macro -> SrcPos -> ParsedOp) -> SrcPos -> Macro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Macro -> SrcPos -> ParsedOp
Mac SrcPos
pos (Macro -> ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro
IFX ParsedInstr
cmp (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (ParsedSeq ParsedOp)
ops ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops)
    Right ParsedSeq ParsedOp
op -> (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
pos (ParsedInstr -> ParsedOp)
-> (ParsedSeq ParsedOp -> ParsedInstr)
-> ParsedSeq ParsedOp
-> ParsedOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> ParsedInstr
forall (f :: * -> *) op. f op -> f op -> InstrAbstract f op
IF ParsedSeq ParsedOp
op (ParsedSeq ParsedOp -> ParsedOp)
-> Parser (ParsedSeq ParsedOp) -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (ParsedSeq ParsedOp)
ops

-- Some of the operations and macros have the same prefixes in their names
-- So this case should be handled separately
primOrMac :: Parser ParsedOp
primOrMac :: Parser ParsedOp
primOrMac = [Parser ParsedOp] -> Parser ParsedOp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos (Parser (ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
ifCmpMac Parser (ParsedSeq ParsedOp)
ops), Parser ParsedOp
ifOrIfX
  , ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos (Parser (ParsedSeq ParsedOp)
-> ParsecT CustomParserException Text Identity Macro
mapCadrMac Parser (ParsedSeq ParsedOp)
ops), Parser ParsedInstr -> Parser ParsedOp
primWithPos (Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
mapOp Parser (ParsedSeq ParsedOp)
ops)
  , Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
pairOp), Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
pairNOp), ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity Macro
pairMac
  , Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity Macro
duupMac), Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
dupOp
  , Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos (ParsecT CustomParserException Text Identity [ParsedOp]
-> ParsecT CustomParserException Text Identity Macro
diipMac ParsecT CustomParserException Text Identity [ParsedOp]
bracewrappedOps)), Parser ParsedInstr -> Parser ParsedOp
primWithPos (Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
dipOp Parser (ParsedSeq ParsedOp)
ops)
  , Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity Macro
carnMac), Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity Macro
cdrnMac), Parser ParsedOp -> Parser ParsedOp
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity Macro
cadrMac)
  , Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
carOp
  , Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
cdrOp
  ]

-------------------------------------------------------------------------------
-- Safe construction of Haskell values
-------------------------------------------------------------------------------

parserToQuasiQuoter :: Parser (TH.Q TH.Exp) -> TH.QuasiQuoter
parserToQuasiQuoter :: Parser (Q Exp) -> QuasiQuoter
parserToQuasiQuoter Parser (Q Exp)
parser = TH.QuasiQuoter
  { quoteExp :: String -> Q Exp
TH.quoteExp = \String
s ->
      case Parser (Q Exp)
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) (Q Exp)
forall a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv (ParsecT CustomParserException Text Identity ()
mSpace ParsecT CustomParserException Text Identity ()
-> Parser (Q Exp) -> Parser (Q Exp)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Q Exp)
parser) MichelsonSource
"quasi-quoter" (String -> Text
forall a. ToText a => a -> Text
toText String
s) of
        Left ParseErrorBundle Text CustomParserException
err -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
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
        Right Q Exp
qexp -> Q Exp
qexp
  , quotePat :: String -> Q Pat
TH.quotePat = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot be used as pattern"
  , quoteType :: String -> Q Type
TH.quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot be used as type"
  , quoteDec :: String -> Q [Dec]
TH.quoteDec = \String
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot be used as declaration"
  }

-- | Creates 'U.Ty' by its Morley representation.
--
-- >>> [utypeQ| or (int :a) (nat :b) |]
-- Ty (TOr (UnsafeAnnotation @FieldTag "") (UnsafeAnnotation @FieldTag "") (Ty TInt (UnsafeAnnotation @TypeTag "a")) (Ty TNat (UnsafeAnnotation @TypeTag "b"))) (UnsafeAnnotation @TypeTag "")
--
-- >>> [utypeQ|a|]
-- <BLANKLINE>
-- ...
--   |
-- 1 | a
--   | ^
-- unexpected 'a'
-- expecting type
-- ...
utypeQ :: TH.QuasiQuoter
utypeQ :: QuasiQuoter
utypeQ = Parser (Q Exp) -> QuasiQuoter
parserToQuasiQuoter (Ty -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Ty -> m Exp
TH.lift (Ty -> Q Exp) -> Parser Ty -> Parser (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Ty
type_)

-- | Creates 'U.ParameterType' by its Morley representation.
uparamTypeQ :: TH.QuasiQuoter
uparamTypeQ :: QuasiQuoter
uparamTypeQ = Parser (Q Exp) -> QuasiQuoter
parserToQuasiQuoter (ParameterType -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => ParameterType -> m Exp
TH.lift (ParameterType -> Q Exp) -> Parser ParameterType -> Parser (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParameterType
cbParameterBare)

-- | Parses and typechecks a 'Morley.Michelson.Typed.Notes'.
--
-- >>> [notes|int :ty|]
-- NTInt (UnsafeAnnotation @TypeTag "ty")
notes :: TH.QuasiQuoter
notes :: QuasiQuoter
notes =
  Parser (Q Exp) -> QuasiQuoter
parserToQuasiQuoter do
    Ty
t <- Parser Ty
type_
    pure $ Ty -> (forall (t :: T). SingI t => Notes t -> Q Exp) -> Q Exp
forall r. Ty -> (forall (t :: T). SingI t => Notes t -> r) -> r
withUType Ty
t Notes t -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (t :: T). SingI t => Notes t -> Q Exp
forall (m :: * -> *). Quote m => Notes t -> m Exp
TH.lift