{-# LANGUAGE OverloadedStrings #-}
module UntypedPlutusCore.Parser
( parse
, parseQuoted
, term
, program
, parseTerm
, parseProgram
, parseScoped
, Parser
, SourcePos
) where
import Prelude hiding (fail)
import Control.Monad.Except ((<=<))
import PlutusCore qualified as PLC
import PlutusPrelude (through)
import Text.Megaparsec hiding (ParseError, State, parse)
import UntypedPlutusCore.Check.Uniques (checkProgram)
import UntypedPlutusCore.Core.Type qualified as UPLC
import UntypedPlutusCore.Rename (Rename (rename))
import Data.ByteString.Lazy (ByteString)
import Data.Text qualified as T
import PlutusCore.Parser.ParserCommon
type PTerm = UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos
conTerm :: Parser PTerm
conTerm :: Parser PTerm
conTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inParens (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> Some (ValueOf DefaultUni) -> PTerm
forall name (uni :: * -> *) fun ann.
ann -> Some (ValueOf uni) -> Term name uni fun ann
UPLC.Constant (SourcePos -> Some (ValueOf DefaultUni) -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError
Text
(StateT ParserState Quote)
(Some (ValueOf DefaultUni) -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"con" ParsecT
ParseError
Text
(StateT ParserState Quote)
(Some (ValueOf DefaultUni) -> PTerm)
-> ParsecT
ParseError
Text
(StateT ParserState Quote)
(Some (ValueOf DefaultUni))
-> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT
ParseError
Text
(StateT ParserState Quote)
(Some (ValueOf DefaultUni))
constant
builtinTerm :: Parser PTerm
builtinTerm :: Parser PTerm
builtinTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inParens (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> DefaultFun -> PTerm
forall name (uni :: * -> *) fun ann.
ann -> fun -> Term name uni fun ann
UPLC.Builtin (SourcePos -> DefaultFun -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError Text (StateT ParserState Quote) (DefaultFun -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"builtin" ParsecT
ParseError Text (StateT ParserState Quote) (DefaultFun -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) DefaultFun
-> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ParseError Text (StateT ParserState Quote) DefaultFun
builtinFunction
varTerm :: Parser PTerm
varTerm :: Parser PTerm
varTerm = SourcePos -> Name -> PTerm
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var (SourcePos -> Name -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError Text (StateT ParserState Quote) (Name -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos ParsecT ParseError Text (StateT ParserState Quote) (Name -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) Name
-> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ParseError Text (StateT ParserState Quote) Name
name
lamTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
lamTerm :: Parser PTerm
lamTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inParens (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> Name -> PTerm -> PTerm
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs (SourcePos -> Name -> PTerm -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError Text (StateT ParserState Quote) (Name -> PTerm -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"lam" ParsecT
ParseError Text (StateT ParserState Quote) (Name -> PTerm -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) Name
-> ParsecT
ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ParseError Text (StateT ParserState Quote) Name
name ParsecT ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
-> Parser PTerm -> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PTerm
term
appTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
appTerm :: Parser PTerm
appTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inBrackets (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> PTerm -> PTerm -> PTerm
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UPLC.Apply (SourcePos -> PTerm -> PTerm -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError
Text
(StateT ParserState Quote)
(PTerm -> PTerm -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos ParsecT
ParseError
Text
(StateT ParserState Quote)
(PTerm -> PTerm -> PTerm)
-> Parser PTerm
-> ParsecT
ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PTerm
term ParsecT ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
-> Parser PTerm -> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PTerm
term
delayTerm :: Parser PTerm
delayTerm :: Parser PTerm
delayTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inParens (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> PTerm -> PTerm
forall name (uni :: * -> *) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Delay (SourcePos -> PTerm -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"delay" ParsecT ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
-> Parser PTerm -> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PTerm
term
forceTerm :: Parser PTerm
forceTerm :: Parser PTerm
forceTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inParens (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> PTerm -> PTerm
forall name (uni :: * -> *) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Force (SourcePos -> PTerm -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"force" ParsecT ParseError Text (StateT ParserState Quote) (PTerm -> PTerm)
-> Parser PTerm -> Parser PTerm
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PTerm
term
errorTerm
:: Parser PTerm
errorTerm :: Parser PTerm
errorTerm = Parser PTerm -> Parser PTerm
forall a. Parser a -> Parser a
inParens (Parser PTerm -> Parser PTerm) -> Parser PTerm -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ SourcePos -> PTerm
forall name (uni :: * -> *) fun ann. ann -> Term name uni fun ann
UPLC.Error (SourcePos -> PTerm)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> Parser PTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"error"
term :: Parser PTerm
term :: Parser PTerm
term = [Parser PTerm] -> Parser PTerm
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser PTerm] -> Parser PTerm) -> [Parser PTerm] -> Parser PTerm
forall a b. (a -> b) -> a -> b
$ (Parser PTerm -> Parser PTerm) -> [Parser PTerm] -> [Parser PTerm]
forall a b. (a -> b) -> [a] -> [b]
map Parser PTerm -> Parser PTerm
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try [
Parser PTerm
conTerm
, Parser PTerm
builtinTerm
, Parser PTerm
varTerm
, Parser PTerm
lamTerm
, Parser PTerm
appTerm
, Parser PTerm
delayTerm
, Parser PTerm
forceTerm
, Parser PTerm
errorTerm
]
program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
program :: Parser (Program Name DefaultUni DefaultFun SourcePos)
program = Parser ()
whitespace Parser ()
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
Program Name DefaultUni DefaultFun SourcePos
prog <- Parser (Program Name DefaultUni DefaultFun SourcePos)
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
forall a. Parser a -> Parser a
inParens (Parser (Program Name DefaultUni DefaultFun SourcePos)
-> Parser (Program Name DefaultUni DefaultFun SourcePos))
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
forall a b. (a -> b) -> a -> b
$ SourcePos
-> Version SourcePos
-> PTerm
-> Program Name DefaultUni DefaultFun SourcePos
forall name (uni :: * -> *) fun ann.
ann
-> Version ann -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program (SourcePos
-> Version SourcePos
-> PTerm
-> Program Name DefaultUni DefaultFun SourcePos)
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
-> ParsecT
ParseError
Text
(StateT ParserState Quote)
(Version SourcePos
-> PTerm -> Program Name DefaultUni DefaultFun SourcePos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT ParseError Text (StateT ParserState Quote) SourcePos
wordPos Text
"program" ParsecT
ParseError
Text
(StateT ParserState Quote)
(Version SourcePos
-> PTerm -> Program Name DefaultUni DefaultFun SourcePos)
-> ParsecT
ParseError Text (StateT ParserState Quote) (Version SourcePos)
-> ParsecT
ParseError
Text
(StateT ParserState Quote)
(PTerm -> Program Name DefaultUni DefaultFun SourcePos)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT
ParseError Text (StateT ParserState Quote) (Version SourcePos)
version ParsecT
ParseError
Text
(StateT ParserState Quote)
(PTerm -> Program Name DefaultUni DefaultFun SourcePos)
-> Parser PTerm
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PTerm
term
ParsecT ParseError Text (StateT ParserState Quote) Char
-> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT ParseError Text (StateT ParserState Quote) Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
Program Name DefaultUni DefaultFun SourcePos
-> Parser (Program Name DefaultUni DefaultFun SourcePos)
forall (m :: * -> *) a. Monad m => a -> m a
return Program Name DefaultUni DefaultFun SourcePos
prog
parseTerm :: ByteString ->
Either (ParseErrorBundle T.Text PLC.ParseError) PTerm
parseTerm :: ByteString -> Either (ParseErrorBundle Text ParseError) PTerm
parseTerm = Parser PTerm
-> ByteString -> Either (ParseErrorBundle Text ParseError) PTerm
forall a.
Parser a
-> ByteString -> Either (ParseErrorBundle Text ParseError) a
parseGen Parser PTerm
term
parseProgram :: ByteString ->
Either (ParseErrorBundle T.Text PLC.ParseError) (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
parseProgram :: ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
parseProgram = Parser (Program Name DefaultUni DefaultFun SourcePos)
-> ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
forall a.
Parser a
-> ByteString -> Either (ParseErrorBundle Text ParseError) a
parseGen Parser (Program Name DefaultUni DefaultFun SourcePos)
program
parseScoped ::
(PLC.MonadQuote (Either (ParseErrorBundle T.Text PLC.ParseError)),
PLC.AsUniqueError (ParseErrorBundle T.Text PLC.ParseError) SourcePos)
=> ByteString
-> Either (ParseErrorBundle T.Text PLC.ParseError) (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
parseScoped :: ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
parseScoped = (Program Name DefaultUni DefaultFun SourcePos
-> Either (ParseErrorBundle Text ParseError) ())
-> Program Name DefaultUni DefaultFun SourcePos
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through ((UniqueError SourcePos -> Bool)
-> Program Name DefaultUni DefaultFun SourcePos
-> Either (ParseErrorBundle Text ParseError) ()
forall ann name e (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique, AsUniqueError e ann,
MonadError e m) =>
(UniqueError ann -> Bool) -> Program name uni fun ann -> m ()
checkProgram (Bool -> UniqueError SourcePos -> Bool
forall a b. a -> b -> a
const Bool
True)) (Program Name DefaultUni DefaultFun SourcePos
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos))
-> (ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos))
-> ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Program Name DefaultUni DefaultFun SourcePos
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
forall a (m :: * -> *). (Rename a, MonadQuote m) => a -> m a
rename (Program Name DefaultUni DefaultFun SourcePos
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos))
-> (ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos))
-> ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString
-> Either
(ParseErrorBundle Text ParseError)
(Program Name DefaultUni DefaultFun SourcePos)
parseProgram