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

-- Parsers for UPLC terms

-- | A parsable UPLC term.
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"

-- | Parser for all UPLC terms.
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
    ]

-- | Parser for UPLC programs.
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

-- | Parse a UPLC term. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
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

-- | Parse a UPLC program. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
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

-- | Parse and rewrite so that names are globally unique, not just unique within
-- their scope.
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)
-- don't require there to be no free variables at this point, we might be parsing an open term
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