-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

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

  -- * Parsers
  , program
  , 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

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import Fmt (pretty)
import qualified Language.Haskell.TH.Lift as TH
import qualified Language.Haskell.TH.Quote 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(..), unsafeMkPos)
import Morley.Michelson.Macro
  (LetMacro, 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.Untyped
import qualified Morley.Michelson.Untyped as U

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

-- | Parse with empty environment
parseNoEnv ::
     Parser a
  -> MichelsonSource
  -> Text
  -> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv :: Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser 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 a -> LetEnv -> Parsec CustomParserException Text a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Parser a
p LetEnv
noLetEnv 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 with let definitions
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program = 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 ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
programInner LetEnv
noLetEnv 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
  where
    programInner :: Parser (Contract' ParsedOp)
    programInner :: ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
programInner = do
      Parser ()
mSpace
      LetEnv
env <- LetEnv -> Maybe LetEnv -> LetEnv
forall a. a -> Maybe a -> a
fromMaybe LetEnv
noLetEnv (Maybe LetEnv -> LetEnv)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Maybe LetEnv)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderT LetEnv (Parsec CustomParserException Text) LetEnv
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Maybe LetEnv)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) LetEnv
letBlock Parser ParsedOp
parsedOp))
      (LetEnv -> LetEnv)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (LetEnv -> LetEnv -> LetEnv
forall a b. a -> b -> a
const LetEnv
env) ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract

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

cbParameterBare :: Parser ParameterType
cbParameterBare :: Parser ParameterType
cbParameterBare = do
  Maybe FieldAnn
prefixRootAnn <- ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Maybe FieldAnn)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
noteF
  (FieldAnn
inTypeRootAnn, Ty
t) <- Parser (FieldAnn, Ty)
field
  FieldAnn
rootAnn <- case (Maybe FieldAnn
prefixRootAnn, FieldAnn
inTypeRootAnn) of
    -- TODO: [#310] Handle cases where there are 2 empty root annotations.
    -- For example: root % (unit %) which should throw the error.
    (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 LetEnv (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 LetEnv (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
a
    (Maybe FieldAnn
Nothing, FieldAnn
b) -> FieldAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
b
    (Just FieldAnn
_, FieldAnn
_) -> CustomParserException
-> ReaderT LetEnv (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 Ty
cbStorage :: Parser Ty
cbStorage = Tokens Text -> Parser ()
symbol Tokens Text
"storage" Parser () -> Parser Ty -> Parser Ty
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Ty
type_

cbCode :: Parser [ParsedOp]
cbCode :: Parser [ParsedOp]
cbCode = Tokens Text -> Parser ()
symbol Tokens Text
"code" Parser () -> Parser [ParsedOp] -> Parser [ParsedOp]
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 -> Parser ()
symbol Tokens Text
"view"
  ViewName
viewName <- Parser ViewName
viewName_
  Ty
viewArgument <- Parser Ty
type_
  Ty
viewReturn <- Parser Ty
type_
  [ParsedOp]
viewCode <- Parser [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 (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 -> Parser ()
ensureNotDuplicate [ContractBlock ParsedOp]
blocks ContractBlock ParsedOp
result =
  let
    failDuplicateField :: String -> m a
failDuplicateField String
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
$ String
"Duplicate contract field: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a
  in
    case (ContractBlock ParsedOp
result, [ContractBlock ParsedOp]
blocks) of
      (CBParam ParameterType
_, CBParam ParameterType
_ : [ContractBlock ParsedOp]
_) -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
failDuplicateField String
"parameter"
      (CBStorage Ty
_, CBStorage Ty
_: [ContractBlock ParsedOp]
_) -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
failDuplicateField String
"storage"
      (CBCode [ParsedOp]
_, CBCode [ParsedOp]
_: [ContractBlock ParsedOp]
_) -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
failDuplicateField String
"code"
      (CBView View' ParsedOp
_, [ContractBlock ParsedOp]
_) -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (ContractBlock ParsedOp
_, ContractBlock ParsedOp
_:[ContractBlock ParsedOp]
xs) -> [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate [ContractBlock ParsedOp]
xs ContractBlock ParsedOp
result
      (ContractBlock ParsedOp
_, []) -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Michelson contract
contract :: Parser (Contract' ParsedOp)
contract :: ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract = do
  Parser ()
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [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
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall (m :: * -> *) a. Monad m => a -> m a
return Contract' ParsedOp
contract'
    Maybe (Contract' ParsedOp)
Nothing ->
      String
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> ReaderT
      LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp))
-> String
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (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 b a. (Show a, IsString b) => a -> b
show [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 (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]
      (ReaderT LetEnv (Parsec CustomParserException Text))
      [()]
    -> Parser [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     [()]
-> Parser [ContractBlock ParsedOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ContractBlock ParsedOp]
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     [()]
-> Parser [ContractBlock ParsedOp]
forall (f :: * -> *) s a. Functor f => s -> StateT s f a -> f s
executingStateT [] (StateT
   [ContractBlock ParsedOp]
   (ReaderT LetEnv (Parsec CustomParserException Text))
   [()]
 -> Parser [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     [()]
-> Parser [ContractBlock ParsedOp]
forall a b. (a -> b) -> a -> b
$ do
      (StateT
  [ContractBlock ParsedOp]
  (ReaderT LetEnv (Parsec CustomParserException Text))
  ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     [()]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` Parser ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser ()
semicolon) (StateT
   [ContractBlock ParsedOp]
   (ReaderT LetEnv (Parsec CustomParserException Text))
   ()
 -> StateT
      [ContractBlock ParsedOp]
      (ReaderT LetEnv (Parsec CustomParserException Text))
      [()])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     [()]
forall a b. (a -> b) -> a -> b
$ do
        ContractBlock ParsedOp
r <- Parser (ContractBlock ParsedOp)
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     (ContractBlock ParsedOp)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser (ContractBlock ParsedOp)
contractBlock
        StateT
  [ContractBlock ParsedOp]
  (ReaderT LetEnv (Parsec CustomParserException Text))
  [ContractBlock ParsedOp]
forall s (m :: * -> *). MonadState s m => m s
get StateT
  [ContractBlock ParsedOp]
  (ReaderT LetEnv (Parsec CustomParserException Text))
  [ContractBlock ParsedOp]
-> ([ContractBlock ParsedOp]
    -> StateT
         [ContractBlock ParsedOp]
         (ReaderT LetEnv (Parsec CustomParserException Text))
         ())
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[ContractBlock ParsedOp]
prev -> Parser ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser ()
 -> StateT
      [ContractBlock ParsedOp]
      (ReaderT LetEnv (Parsec CustomParserException Text))
      ())
-> Parser ()
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ()
forall a b. (a -> b) -> a -> b
$ [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate [ContractBlock ParsedOp]
prev ContractBlock ParsedOp
r
        ([ContractBlock ParsedOp] -> [ContractBlock ParsedOp])
-> StateT
     [ContractBlock ParsedOp]
     (ReaderT LetEnv (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 ParsedValue
value :: Parser ParsedValue
value = Parser ParsedOp -> Parser ParsedValue
value' Parser 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}"
-- Left 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 a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser 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 ParsedInstr
prim :: Parser ParsedInstr
prim = ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
-> Parser ParsedOp -> Parser ParsedInstr
primInstr ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract Parser 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 [ParsedOp]
codeEntry :: Parser [ParsedOp]
codeEntry = Parser [ParsedOp]
bracewrappedOps

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

-- |
-- >>> first ParserException $ parseNoEnv parsedOp "" "{a}"
-- Left 1:2:
--   |
-- 1 | {a}
--   |  ^
-- unexpected 'a'
-- expecting '{', '}', macro, morley instruction, or primitive instruction
-- <BLANKLINE>
parsedOp :: Parser ParsedOp
parsedOp :: Parser ParsedOp
parsedOp = do
  Map Text LetMacro
lms <- (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
pos <- Parser 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
<$> (ExtInstrAbstract ParsedOp -> ParsedInstr
forall op. ExtInstrAbstract op -> InstrAbstract op
EXT (ExtInstrAbstract ParsedOp -> ParsedInstr)
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
-> Parser ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
extInstr Parser [ParsedOp]
ops)
    , Parser LetMacro -> Parser ParsedOp
lmacWithPos (Map Text LetMacro -> Parser LetMacro
mkLetMac Map Text LetMacro
lms)
    , (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)
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
macro Parser ParsedOp
parsedOp
    , 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) -> Parser [ParsedOp] -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
bracewrappedOps
    ]
  where
    lmacWithPos :: Parser LetMacro -> Parser ParsedOp
    lmacWithPos :: Parser LetMacro -> Parser ParsedOp
lmacWithPos Parser LetMacro
act = do
      SrcPos
srcPos <- Parser 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 LetMacro -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LetMacro
act

getSrcPos :: Parser SrcPos
getSrcPos :: Parser SrcPos
getSrcPos = do
  SourcePos
sp <- ReaderT LetEnv (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 SrcPos
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcPos -> Parser SrcPos) -> SrcPos -> Parser SrcPos
forall a b. (a -> b) -> a -> b
$ Pos -> Pos -> SrcPos
SrcPos (Int -> Pos
unsafeMkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Pos
unsafeMkPos (Int -> Pos) -> Int -> 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 <- Parser 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 :: ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
act = do
  SrcPos
srcPos <- Parser 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 LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Macro
act

ops :: Parser [ParsedOp]
ops :: Parser [ParsedOp]
ops = Parser ParsedOp -> Parser [ParsedOp]
ops' Parser ParsedOp
parsedOp

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

ifOrIfX :: Parser ParsedOp
ifOrIfX :: Parser ParsedOp
ifOrIfX = do
  SrcPos
pos <- Parser SrcPos
getSrcPos
  Text -> Parser ()
symbol' Text
"IF"
  Either ParsedInstr [ParsedOp]
a <- Parser ParsedInstr
-> Parser [ParsedOp]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (Either ParsedInstr [ParsedOp])
forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
eitherP Parser ParsedInstr
cmpOp Parser [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 LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsedInstr -> [ParsedOp] -> [ParsedOp] -> Macro
IFX ParsedInstr
cmp ([ParsedOp] -> [ParsedOp] -> Macro)
-> Parser [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
ops ReaderT
  LetEnv (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
-> Parser [ParsedOp]
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [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) -> Parser ParsedInstr -> Parser 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)
-> Parser [ParsedOp] -> Parser ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [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 e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden
   (Parser ParsedOp -> Parser ParsedOp)
-> Parser ParsedOp -> Parser ParsedOp
forall a b. (a -> b) -> a -> b
$  (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos (Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
ifCmpMac Parser ParsedOp
parsedOp) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp
ifOrIfX)
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos (Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
mapCadrMac Parser ParsedOp
parsedOp) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedInstr -> Parser ParsedOp
primWithPos (Parser ParsedOp -> Parser ParsedInstr
mapOp Parser ParsedOp
parsedOp))
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ParsedOp -> Parser ParsedOp
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 -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
pairNOp) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
pairMac)
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
duupMac) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
dupOp)
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
carnMac) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
cdrnMac) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
cadrMac) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
carOp Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
cdrOp)

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

parserToQuasiQuoter :: TH.Lift a => Parser a -> TH.QuasiQuoter
parserToQuasiQuoter :: Parser a -> QuasiQuoter
parserToQuasiQuoter Parser a
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 a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
forall a.
Parser a
-> MichelsonSource
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv (Parser ()
mSpace Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
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 a
res -> [e| res |]
  , 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| (int :a | nat :b) |]
-- Ty (TOr % % (Ty TInt :a) (Ty TNat :b)) :
--
-- >>> [utypeQ|a|]
-- <BLANKLINE>
-- ...
--   |
-- 1 | a
--   | ^
-- unexpected 'a'
-- expecting type
-- ...
utypeQ :: TH.QuasiQuoter
utypeQ :: QuasiQuoter
utypeQ = Parser Ty -> QuasiQuoter
forall a. Lift a => Parser a -> QuasiQuoter
parserToQuasiQuoter Parser Ty
type_

-- | Creates 'U.ParameterType' by its Morley representation.
uparamTypeQ :: TH.QuasiQuoter
uparamTypeQ :: QuasiQuoter
uparamTypeQ = Parser ParameterType -> QuasiQuoter
forall a. Lift a => Parser a -> QuasiQuoter
parserToQuasiQuoter Parser ParameterType
cbParameterBare