-- 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

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

  -- * Quoters
  , utypeQ
  , uparamTypeQ
  , notes

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

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, 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.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

----------------------------------------------------------------------------
-- 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 (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, FromBuilder 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 (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 (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 Tokens Text
"parameter" ParsecT CustomParserException Text Identity ()
-> 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 = (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 Tokens Text
"storage" ParsecT CustomParserException Text Identity ()
-> 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 -> ParsecT CustomParserException Text Identity ()
symbol Tokens Text
"code" ParsecT CustomParserException Text Identity ()
-> 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 -> ParsecT CustomParserException Text Identity ()
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
-> ParsecT CustomParserException Text Identity ()
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
-> 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 (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 (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
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall (m :: * -> *) a. Monad m => a -> m a
return Contract' ParsedOp
contract'
    Maybe (Contract' ParsedOp)
Nothing ->
      String -> Parsec CustomParserException Text (Contract' ParsedOp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parsec CustomParserException Text (Contract' ParsedOp))
-> String -> 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 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 [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]
      (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 (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 (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 (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 (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 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}" & 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 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 (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 (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 ParsedOp -> Parser ParsedInstr
primInstr 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 = ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Tokens Text
"{") ParsecT CustomParserException Text Identity ()
-> Parser [ParsedOp] -> Parser [ParsedOp]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [ParsedOp]
ops

-- |
-- >>> parseNoEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())
-- 1:2:
--   |
-- 1 | {a}
--   |  ^
-- unexpected 'a'
-- expecting '{', '}', macro, or primitive instruction
-- <BLANKLINE>
parsedOp :: Parser ParsedOp
parsedOp :: Parser ParsedOp
parsedOp = do
  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
<$> 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 ParsedOp
-> ParsecT CustomParserException Text Identity 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
    ]

getSrcPos :: Parser SrcPos
getSrcPos :: Parser 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 -> Parser SrcPos
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcPos -> Parser SrcPos)
-> (Either Text SrcPos -> SrcPos)
-> Either Text SrcPos
-> Parser 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 SrcPos)
-> Either Text SrcPos -> Parser 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 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 :: ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity 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)
-> 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 [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
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Tokens Text
"IF"
  Either ParsedInstr [ParsedOp]
a <- Parser ParsedInstr
-> Parser [ParsedOp]
-> ParsecT
     CustomParserException Text Identity (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)
-> ParsecT CustomParserException Text Identity 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]
-> ParsecT
     CustomParserException Text Identity ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
ops ParsecT CustomParserException Text Identity ([ParsedOp] -> Macro)
-> Parser [ParsedOp]
-> ParsecT CustomParserException Text Identity 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
$  (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos (Parser ParsedOp
-> ParsecT CustomParserException Text Identity 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
<|> (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos (Parser ParsedOp
-> ParsecT CustomParserException Text Identity 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
<|> ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity 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 (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity 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 (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity 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 (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity 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 (ParsecT CustomParserException Text Identity Macro
-> Parser ParsedOp
macWithPos ParsecT CustomParserException Text Identity 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 :: 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 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 (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 (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 (m :: * -> *). (Lift t, Quote m) => t -> 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
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 forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (t :: T). SingI t => Notes t -> Q Exp
TH.lift