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

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations -Wno-redundant-constraints #-}

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

  -- * Parsers
  , program
  , programExt
  , value

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

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

  -- * For tests
  , codeEntry
  , ops
  , type_
  , letInner
  , letType
  , stringLiteral
  , bytesLiteral
  , intLiteral
  , parsedOp
  , printComment

  -- * Quoters
  , utypeQ
  , uparamTypeQ
  , notes

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import Data.Default (Default(..))
import Fmt (pretty, (+|), (|+))
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, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,
  parse, sepEndBy, try)
import Text.Megaparsec.Pos (SourcePos(..), unPos)

import Morley.Michelson.ErrorPos (SrcPos(..), mkPos)
import Morley.Michelson.Macro (Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue)
import Morley.Michelson.Parser.Annotations (noteF)
import Morley.Michelson.Parser.Common
import Morley.Michelson.Parser.Error
import Morley.Michelson.Parser.Ext
import Morley.Michelson.Parser.Instr
import Morley.Michelson.Parser.Let
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

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

-- | Parse with empty environment
parseNoEnv ::
     Default le
  => Parser' le a
  -> MichelsonSource
  -> Text
  -> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv :: Parser' le a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser' le a
p MichelsonSource
src = Parsec CustomParserException Text 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' le a -> le -> Parsec CustomParserException Text a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Parser' le a
p le
forall a. Default a => a
def Parsec CustomParserException Text a
-> Parsec CustomParserException Text ()
-> Parsec CustomParserException Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec CustomParserException Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) (MichelsonSource -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty MichelsonSource
src)

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

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

-- | Michelson contract
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program = ReaderT () (Parsec CustomParserException Text) (Contract' ParsedOp)
-> () -> Parsec CustomParserException Text (Contract' ParsedOp)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Default () => Parser () (Contract' ParsedOp)
forall env. Default env => Parser env (Contract' ParsedOp)
programInner @()) ()
forall a. Default a => a
def Parsec CustomParserException Text (Contract' ParsedOp)
-> Parsec CustomParserException Text ()
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec CustomParserException Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

programInner
  :: forall env. (Default env)
  => Parser env (Contract' ParsedOp)
programInner :: Parser' env (Contract' ParsedOp)
programInner = do
  Parser' env ()
forall le. Parser le ()
mSpace
  env
env <- env -> Maybe env -> env
forall a. a -> Maybe a -> a
fromMaybe env
forall a. Default a => a
def (Maybe env -> env)
-> ReaderT env (Parsec CustomParserException Text) (Maybe env)
-> ReaderT env (Parsec CustomParserException Text) env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderT env (Parsec CustomParserException Text) env
-> ReaderT env (Parsec CustomParserException Text) (Maybe env)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser' env ParsedOp -> Parser env env
forall le. Parser' le ParsedOp -> Parser le le
letBlock Parser' env ParsedOp
forall le. Parser le ParsedOp
parsedOp))
  (env -> env)
-> Parser' env (Contract' ParsedOp)
-> Parser' env (Contract' ParsedOp)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (env -> env -> env
forall a b. a -> b -> a
const env
env) Parser' env (Contract' ParsedOp)
forall le. Parser le (Contract' ParsedOp)
contract

-- TODO [#712]: Remove this next major release
-- | Michelson contract with let definitions
programExt :: Parsec CustomParserException Text (Contract' ParsedOp)
programExt :: Parsec CustomParserException Text (Contract' ParsedOp)
programExt = ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
-> LetEnv -> Parsec CustomParserException Text (Contract' ParsedOp)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Default LetEnv => Parser LetEnv (Contract' ParsedOp)
forall env. Default env => Parser env (Contract' ParsedOp)
programInner @LetEnv) LetEnv
forall a. Default a => a
def Parsec CustomParserException Text (Contract' ParsedOp)
-> Parsec CustomParserException Text ()
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec CustomParserException Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

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

cbParameterBare :: Parser le ParameterType
cbParameterBare :: Parser' le ParameterType
cbParameterBare = do
  Maybe FieldAnn
prefixRootAnn <- ReaderT le (Parsec CustomParserException Text) FieldAnn
-> ReaderT le (Parsec CustomParserException Text) (Maybe FieldAnn)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ReaderT le (Parsec CustomParserException Text) FieldAnn
forall le. Parser le FieldAnn
noteF
  (FieldAnn
inTypeRootAnn, Ty
t) <- Parser' le (FieldAnn, Ty)
forall le. Parser le (FieldAnn, Ty)
field
  FieldAnn
rootAnn <- case (Maybe FieldAnn
prefixRootAnn, FieldAnn
inTypeRootAnn) of
    (Just FieldAnn
a, FieldAnn
b) | FieldAnn
a FieldAnn -> FieldAnn -> Bool
forall a. Eq a => a -> a -> Bool
== FieldAnn
forall k (a :: k). Annotation a
noAnn Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& FieldAnn
b FieldAnn -> FieldAnn -> Bool
forall a. Eq a => a -> a -> Bool
== FieldAnn
forall k (a :: k). Annotation a
noAnn -> FieldAnn -> ReaderT le (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
forall k (a :: k). Annotation a
noAnn
    (Just FieldAnn
a, FieldAnn
b) | FieldAnn
b FieldAnn -> FieldAnn -> Bool
forall a. Eq a => a -> a -> Bool
== FieldAnn
forall k (a :: k). Annotation a
noAnn -> FieldAnn -> ReaderT le (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
a
    (Maybe FieldAnn
Nothing, FieldAnn
b) -> FieldAnn -> ReaderT le (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
b
    (Just FieldAnn
_, FieldAnn
_) -> CustomParserException
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure CustomParserException
MultiRootAnnotationException
  pure $ Ty -> FieldAnn -> ParameterType
ParameterType Ty
t FieldAnn
rootAnn

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

cbCode :: Parser le [ParsedOp]
cbCode :: Parser' le [ParsedOp]
cbCode = Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"code" Parser' le () -> Parser' le [ParsedOp] -> Parser' le [ParsedOp]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser' le [ParsedOp]
forall le. Parser le [ParsedOp]
codeEntry

cbView :: Parser le (View' ParsedOp)
cbView :: Parser' le (View' ParsedOp)
cbView = do
  Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"view"
  ViewName
viewName <- Parser' le ViewName
forall le. Parser le ViewName
viewName_
  Ty
viewArgument <- Parser' le Ty
forall le. Parser le Ty
type_
  Ty
viewReturn <- Parser' le Ty
forall le. Parser le Ty
type_
  [ParsedOp]
viewCode <- Parser' le [ParsedOp]
forall le. Parser le [ParsedOp]
ops
  return View :: forall op. ViewName -> Ty -> Ty -> [op] -> View' op
View{[ParsedOp]
Ty
ViewName
viewCode :: [ParsedOp]
viewReturn :: Ty
viewArgument :: Ty
viewName :: ViewName
viewCode :: [ParsedOp]
viewReturn :: Ty
viewArgument :: Ty
viewName :: ViewName
..}

contractBlock :: Parser le (ContractBlock ParsedOp)
contractBlock :: Parser' le (ContractBlock ParsedOp)
contractBlock = [Parser' le (ContractBlock ParsedOp)]
-> Parser' le (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)
-> ReaderT le (Parsec CustomParserException Text) ParameterType
-> Parser' le (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) ParameterType
forall le. Parser le ParameterType
cbParameter)
  , (Ty -> ContractBlock ParsedOp
forall op. Ty -> ContractBlock op
CBStorage (Ty -> ContractBlock ParsedOp)
-> ReaderT le (Parsec CustomParserException Text) Ty
-> Parser' le (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) Ty
forall le. Parser le Ty
cbStorage)
  , ([ParsedOp] -> ContractBlock ParsedOp
forall op. [op] -> ContractBlock op
CBCode ([ParsedOp] -> ContractBlock ParsedOp)
-> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
-> Parser' le (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
forall le. Parser le [ParsedOp]
cbCode)
  , (View' ParsedOp -> ContractBlock ParsedOp
forall op. View' op -> ContractBlock op
CBView (View' ParsedOp -> ContractBlock ParsedOp)
-> ReaderT le (Parsec CustomParserException Text) (View' ParsedOp)
-> Parser' le (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) (View' ParsedOp)
forall le. Parser le (View' ParsedOp)
cbView)
  ]

-- | This ensures that the error message will point to the correct line.
ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le ()
ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le ()
ensureNotDuplicate [ContractBlock ParsedOp]
blocks ContractBlock ParsedOp
result =
  let
    failDuplicateField :: a -> m a
failDuplicateField a
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
$ Builder
"Duplicate contract field: " Builder -> Builder -> String
forall b. FromBuilder b => Builder -> Builder -> b
+| a
a a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  in
    case (ContractBlock ParsedOp
result, [ContractBlock ParsedOp]
blocks) of
      (CBParam ParameterType
_, CBParam ParameterType
_ : [ContractBlock ParsedOp]
_) -> ContractBlock ParsedOp -> Parser' le ()
forall (m :: * -> *) a a. (MonadFail m, Buildable a) => a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (CBStorage Ty
_, CBStorage Ty
_: [ContractBlock ParsedOp]
_) -> ContractBlock ParsedOp -> Parser' le ()
forall (m :: * -> *) a a. (MonadFail m, Buildable a) => a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (CBCode [ParsedOp]
_, CBCode [ParsedOp]
_: [ContractBlock ParsedOp]
_) -> ContractBlock ParsedOp -> Parser' le ()
forall (m :: * -> *) a a. (MonadFail m, Buildable a) => a -> m a
failDuplicateField ContractBlock ParsedOp
result
      (CBView View' ParsedOp
_, [ContractBlock ParsedOp]
_) -> () -> Parser' le ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (ContractBlock ParsedOp
_, ContractBlock ParsedOp
_:[ContractBlock ParsedOp]
xs) -> [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le ()
forall le.
[ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le ()
ensureNotDuplicate [ContractBlock ParsedOp]
xs ContractBlock ParsedOp
result
      (ContractBlock ParsedOp
_, []) -> () -> Parser' le ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Michelson contract
contract :: Parser le (Contract' ParsedOp)
contract :: Parser' le (Contract' ParsedOp)
contract = do
  Parser' le ()
forall le. Parser le ()
mSpace
  [ContractBlock ParsedOp]
result <- Parser le [ContractBlock ParsedOp]
-> Parser le [ContractBlock ParsedOp]
forall le a. Parser le a -> Parser le a
braces Parser' le [ContractBlock ParsedOp]
Parser le [ContractBlock ParsedOp]
contractTuple Parser' le [ContractBlock ParsedOp]
-> Parser' le [ContractBlock ParsedOp]
-> Parser' le [ContractBlock ParsedOp]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le [ContractBlock ParsedOp]
contractTuple
  case [ContractBlock ParsedOp] -> Maybe (Contract' ParsedOp)
forall op. [ContractBlock op] -> Maybe (Contract' op)
orderContractBlock [ContractBlock ParsedOp]
result of
    Just Contract' ParsedOp
contract' ->
      Contract' ParsedOp -> Parser' le (Contract' ParsedOp)
forall (m :: * -> *) a. Monad m => a -> m a
return Contract' ParsedOp
contract'
    Maybe (Contract' ParsedOp)
Nothing ->
      String -> Parser' le (Contract' ParsedOp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser' le (Contract' ParsedOp))
-> String -> Parser' le (Contract' ParsedOp)
forall a b. (a -> b) -> a -> b
$ String
"Duplicate contract field: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ContractBlock ParsedOp] -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty [ContractBlock ParsedOp]
result
  where
    -- | @ensureNotDuplicate@ provides a better message and point to the correct line
    -- when the parser fails.
    contractTuple :: Parser' le [ContractBlock ParsedOp]
contractTuple = ([ContractBlock ParsedOp] -> [ContractBlock ParsedOp])
-> Parser' le [ContractBlock ParsedOp]
-> Parser' le [ContractBlock ParsedOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ContractBlock ParsedOp] -> [ContractBlock ParsedOp]
forall a. [a] -> [a]
reverse (Parser' le [ContractBlock ParsedOp]
 -> Parser' le [ContractBlock ParsedOp])
-> (StateT
      [ContractBlock ParsedOp]
      (ReaderT le (Parsec CustomParserException Text))
      [()]
    -> Parser' le [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     [()]
-> Parser' le [ContractBlock ParsedOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ContractBlock ParsedOp]
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     [()]
-> Parser' le [ContractBlock ParsedOp]
forall (f :: * -> *) s a. Functor f => s -> StateT s f a -> f s
executingStateT [] (StateT
   [ContractBlock ParsedOp]
   (ReaderT le (Parsec CustomParserException Text))
   [()]
 -> Parser' le [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     [()]
-> Parser' le [ContractBlock ParsedOp]
forall a b. (a -> b) -> a -> b
$ do
      (StateT
  [ContractBlock ParsedOp]
  (ReaderT le (Parsec CustomParserException Text))
  ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     [()]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` Parser' le ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser' le ()
forall le. Parser le ()
semicolon) (StateT
   [ContractBlock ParsedOp]
   (ReaderT le (Parsec CustomParserException Text))
   ()
 -> StateT
      [ContractBlock ParsedOp]
      (ReaderT le (Parsec CustomParserException Text))
      [()])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     [()]
forall a b. (a -> b) -> a -> b
$ do
        ContractBlock ParsedOp
r <- ReaderT
  le (Parsec CustomParserException Text) (ContractBlock ParsedOp)
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     (ContractBlock ParsedOp)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT
  le (Parsec CustomParserException Text) (ContractBlock ParsedOp)
forall le. Parser le (ContractBlock ParsedOp)
contractBlock
        StateT
  [ContractBlock ParsedOp]
  (ReaderT le (Parsec CustomParserException Text))
  [ContractBlock ParsedOp]
forall s (m :: * -> *). MonadState s m => m s
get StateT
  [ContractBlock ParsedOp]
  (ReaderT le (Parsec CustomParserException Text))
  [ContractBlock ParsedOp]
-> ([ContractBlock ParsedOp]
    -> StateT
         [ContractBlock ParsedOp]
         (ReaderT le (Parsec CustomParserException Text))
         ())
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[ContractBlock ParsedOp]
prev -> Parser' le ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser' le ()
 -> StateT
      [ContractBlock ParsedOp]
      (ReaderT le (Parsec CustomParserException Text))
      ())
-> Parser' le ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
forall a b. (a -> b) -> a -> b
$ [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le ()
forall le.
[ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser le ()
ensureNotDuplicate [ContractBlock ParsedOp]
prev ContractBlock ParsedOp
r
        ([ContractBlock ParsedOp] -> [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT le (Parsec CustomParserException Text))
     ()
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 le ParsedValue
value :: Parser' le ParsedValue
value = Parser le ParsedOp -> Parser le ParsedValue
forall le. Parser le ParsedOp -> Parser le ParsedValue
value' Parser le ParsedOp
forall le. Parser le ParsedOp
parsedOp

-- | 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 (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 le a.
Default le =>
Parser' le a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv @()) Parser' () ParsedValue
forall le. Parser le ParsedValue
value

-- | 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 (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 le ParsedInstr
prim :: Parser' le ParsedInstr
prim = Parser' le (Contract' ParsedOp)
-> Parser' le ParsedOp -> Parser le ParsedInstr
forall le.
Parser' le (Contract' ParsedOp)
-> Parser' le ParsedOp -> Parser le ParsedInstr
primInstr Parser' le (Contract' ParsedOp)
forall le. Parser le (Contract' ParsedOp)
contract Parser' le ParsedOp
forall le. Parser le ParsedOp
parsedOp

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

-- | Parses code block after "code" keyword of a contract.
--
-- This function is part of the module API, its semantics should not change.
codeEntry :: Parser le [ParsedOp]
codeEntry :: Parser' le [ParsedOp]
codeEntry = Parser' le [ParsedOp]
forall le. Parser le [ParsedOp]
bracewrappedOps

bracewrappedOps :: Parser le [ParsedOp]
bracewrappedOps :: Parser' le [ParsedOp]
bracewrappedOps = ReaderT le (Parsec CustomParserException Text) ()
-> ReaderT le (Parsec CustomParserException Text) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"{") ReaderT le (Parsec CustomParserException Text) ()
-> Parser' le [ParsedOp] -> Parser' le [ParsedOp]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser' le [ParsedOp]
forall le. Parser le [ParsedOp]
ops

-- |
-- >>> parseNoEnv @() parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())
-- 1:2:
--   |
-- 1 | {a}
--   |  ^
-- unexpected 'a'
-- expecting '{', '}', macro, or primitive instruction
-- <BLANKLINE>
-- >>> :m + Morley.Michelson.Parser.Types
-- >>> parseNoEnv @LetEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())
-- ...
-- 1:2:
--   |
-- 1 | {a}
--   |  ^
-- unexpected 'a'
-- expecting '{', '}', macro, morley instruction, or primitive instruction
-- <BLANKLINE>
parsedOp :: Parser le ParsedOp
parsedOp :: Parser' le ParsedOp
parsedOp = do
  SrcPos
pos <- Parser' le SrcPos
forall le. Parser le SrcPos
getSrcPos
  [Parser' le ParsedOp] -> Parser' le ParsedOp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser' LetEnv ParsedOp -> Parser le ParsedOp
forall le a. Parser' LetEnv a -> Parser le a
withLetEnv (Parser' LetEnv ParsedOp -> Parser le ParsedOp)
-> Parser' LetEnv ParsedOp -> Parser le ParsedOp
forall a b. (a -> b) -> a -> b
$ (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)
-> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
-> Parser' LetEnv ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExtInstrAbstract ParsedOp -> ParsedInstr
forall op. ExtInstrAbstract op -> InstrAbstract op
EXT (ExtInstrAbstract ParsedOp -> ParsedInstr)
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
-> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' LetEnv [ParsedOp]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
extInstr Parser' LetEnv [ParsedOp]
forall le. Parser le [ParsedOp]
ops)
    , Parser' LetEnv ParsedOp -> Parser le ParsedOp
forall le a. Parser' LetEnv a -> Parser le a
withLetEnv (Parser' LetEnv ParsedOp -> Parser le ParsedOp)
-> Parser' LetEnv ParsedOp -> Parser le ParsedOp
forall a b. (a -> b) -> a -> b
$ Parser' LetEnv ParsedOp
lmacWithPos
    , (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)
-> ReaderT le (Parsec CustomParserException Text) ParsedInstr
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) ParsedInstr
forall le. Parser le 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)
-> ReaderT le (Parsec CustomParserException Text) Macro
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' le ParsedOp -> Parser le Macro
forall le. Parser' le ParsedOp -> Parser le Macro
macro Parser' le ParsedOp
forall le. Parser le ParsedOp
parsedOp
    , Parser' le ParsedOp
forall le. Parser le 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)
-> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
forall le. Parser le [ParsedOp]
bracewrappedOps
    ]
  where
    lmacWithPos :: Parser' LetEnv ParsedOp
    lmacWithPos :: Parser' LetEnv ParsedOp
lmacWithPos = do
      Parser' LetEnv LetMacro
act <- Map Text LetMacro -> Parser' LetEnv LetMacro
mkLetMac (Map Text LetMacro -> Parser' LetEnv LetMacro)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Map Text LetMacro)
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (Parser' LetEnv LetMacro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetEnv -> Map Text LetMacro)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Map Text LetMacro)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LetEnv -> Map Text LetMacro
letMacros
      SrcPos
srcPos <- Parser' LetEnv SrcPos
forall le. Parser le SrcPos
getSrcPos
      (LetMacro -> SrcPos -> ParsedOp) -> SrcPos -> LetMacro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip LetMacro -> SrcPos -> ParsedOp
LMac SrcPos
srcPos (LetMacro -> ParsedOp)
-> Parser' LetEnv LetMacro -> Parser' LetEnv ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' LetEnv LetMacro
act

getSrcPos :: Parser le SrcPos
getSrcPos :: Parser' le SrcPos
getSrcPos = do
  SourcePos
sp <- ReaderT le (Parsec CustomParserException Text) 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 -> Parser' le SrcPos
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcPos -> Parser' le SrcPos)
-> (Either Text SrcPos -> SrcPos)
-> Either Text SrcPos
-> Parser' le 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 -> Parser' le SrcPos)
-> Either Text SrcPos -> Parser' le 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 (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 le ParsedInstr -> Parser le ParsedOp
primWithPos :: Parser le ParsedInstr -> Parser le ParsedOp
primWithPos Parser le ParsedInstr
act = do
  SrcPos
srcPos <- Parser' le SrcPos
forall le. Parser le 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)
-> ReaderT le (Parsec CustomParserException Text) ParsedInstr
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) ParsedInstr
Parser le ParsedInstr
act

macWithPos :: Parser le Macro -> Parser le ParsedOp
macWithPos :: Parser le Macro -> Parser le ParsedOp
macWithPos Parser le Macro
act = do
  SrcPos
srcPos <- Parser' le SrcPos
forall le. Parser le 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)
-> ReaderT le (Parsec CustomParserException Text) Macro
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) Macro
Parser le Macro
act

ops :: Parser le [ParsedOp]
ops :: Parser' le [ParsedOp]
ops = Parser' le ParsedOp -> Parser le [ParsedOp]
forall le. Parser' le ParsedOp -> Parser le [ParsedOp]
ops' Parser' le ParsedOp
forall le. Parser le ParsedOp
parsedOp

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

ifOrIfX :: Parser le ParsedOp
ifOrIfX :: Parser' le ParsedOp
ifOrIfX = do
  SrcPos
pos <- Parser' le SrcPos
forall le. Parser le SrcPos
getSrcPos
  Text -> Parser le ()
forall le. Text -> Parser le ()
symbol' Text
"IF"
  Either ParsedInstr [ParsedOp]
a <- ReaderT le (Parsec CustomParserException Text) ParsedInstr
-> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT
     le
     (Parsec CustomParserException Text)
     (Either ParsedInstr [ParsedOp])
forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
eitherP ReaderT le (Parsec CustomParserException Text) ParsedInstr
forall le. Parser le ParsedInstr
cmpOp ReaderT le (Parsec CustomParserException Text) [ParsedOp]
forall le. Parser le [ParsedOp]
ops
  case Either ParsedInstr [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)
-> ReaderT le (Parsec CustomParserException Text) Macro
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsedInstr -> [ParsedOp] -> [ParsedOp] -> Macro
IFX ParsedInstr
cmp ([ParsedOp] -> [ParsedOp] -> Macro)
-> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT
     le (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
forall le. Parser le [ParsedOp]
ops ReaderT
  le (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
-> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT le (Parsec CustomParserException Text) Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
forall le. Parser le [ParsedOp]
ops)
    Right [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)
-> ReaderT le (Parsec CustomParserException Text) ParsedInstr
-> Parser' le ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ParsedOp] -> [ParsedOp] -> ParsedInstr
forall op. [op] -> [op] -> InstrAbstract op
IF [ParsedOp]
op ([ParsedOp] -> ParsedInstr)
-> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT le (Parsec CustomParserException Text) ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT le (Parsec CustomParserException Text) [ParsedOp]
forall le. Parser le [ParsedOp]
ops)

-- Some of the operations and macros have the same prefixes in their names
-- So this case should be handled separately
primOrMac :: Parser le ParsedOp
primOrMac :: Parser' le ParsedOp
primOrMac = Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden
   (Parser' le ParsedOp -> Parser' le ParsedOp)
-> Parser' le ParsedOp -> Parser' le ParsedOp
forall a b. (a -> b) -> a -> b
$  (Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos (Parser le ParsedOp -> Parser le Macro
forall le. Parser le ParsedOp -> Parser le Macro
ifCmpMac Parser le ParsedOp
forall le. Parser le ParsedOp
parsedOp) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le ParsedOp
forall le. Parser le ParsedOp
ifOrIfX)
  Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos (Parser le ParsedOp -> Parser le Macro
forall le. Parser le ParsedOp -> Parser le Macro
mapCadrMac Parser le ParsedOp
forall le. Parser le ParsedOp
parsedOp) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser le ParsedInstr -> Parser le ParsedOp
forall le. Parser le ParsedInstr -> Parser le ParsedOp
primWithPos (Parser' le ParsedOp -> Parser le ParsedInstr
forall le. Parser' le ParsedOp -> Parser le ParsedInstr
mapOp Parser' le ParsedOp
forall le. Parser le ParsedOp
parsedOp))
  Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser le ParsedInstr -> Parser le ParsedOp
forall le. Parser le ParsedInstr -> Parser le ParsedOp
primWithPos Parser le ParsedInstr
forall le. Parser le ParsedInstr
pairOp) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser le ParsedInstr -> Parser le ParsedOp
forall le. Parser le ParsedInstr -> Parser le ParsedOp
primWithPos Parser le ParsedInstr
forall le. Parser le ParsedInstr
pairNOp) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos Parser le Macro
forall le. Parser le Macro
pairMac)
  Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos Parser le Macro
forall le. Parser le Macro
duupMac) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser le ParsedInstr -> Parser le ParsedOp
forall le. Parser le ParsedInstr -> Parser le ParsedOp
primWithPos Parser le ParsedInstr
forall le. Parser le ParsedInstr
dupOp)
  Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos Parser le Macro
forall le. Parser le Macro
carnMac) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos Parser le Macro
forall le. Parser le Macro
cdrnMac) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le ParsedOp -> Parser' le ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser le Macro -> Parser le ParsedOp
forall le. Parser le Macro -> Parser le ParsedOp
macWithPos Parser le Macro
forall le. Parser le Macro
cadrMac) Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser le ParsedInstr -> Parser le ParsedOp
forall le. Parser le ParsedInstr -> Parser le ParsedOp
primWithPos Parser le ParsedInstr
forall le. Parser le ParsedInstr
carOp Parser' le ParsedOp -> Parser' le ParsedOp -> Parser' le ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser le ParsedInstr -> Parser le ParsedOp
forall le. Parser le ParsedInstr -> Parser le ParsedOp
primWithPos Parser le ParsedInstr
forall le. Parser le 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 = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
  { quoteExp :: String -> Q Exp
TH.quoteExp = \String
s ->
      case Parser' () (Q Exp)
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) (Q Exp)
forall le a.
Default le =>
Parser' le a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv (Parser' () ()
forall le. Parser le ()
mSpace Parser' () () -> Parser' () (Q Exp) -> Parser' () (Q Exp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser' () (Q Exp)
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 (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 (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 (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 (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. Lift t => t -> Q Exp
TH.lift (Ty -> Q Exp)
-> ReaderT () (Parsec CustomParserException Text) Ty
-> Parser' () (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT () (Parsec CustomParserException Text) Ty
forall le. Parser le 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. Lift t => t -> Q Exp
TH.lift (ParameterType -> Q Exp)
-> ReaderT () (Parsec CustomParserException Text) ParameterType
-> Parser' () (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT () (Parsec CustomParserException Text) ParameterType
forall le. Parser le 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 <- ReaderT () (Parsec CustomParserException Text) Ty
forall le. Parser le 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 forall t. Lift t => t -> Q Exp
forall (t :: T). SingI t => Notes t -> Q Exp
TH.lift