diff --git a/plutus-core/plutus-core/src/PlutusCore.hs b/plutus-core/plutus-core/src/PlutusCore.hs index 9e36950a420..7dff6f94883 100644 --- a/plutus-core/plutus-core/src/PlutusCore.hs +++ b/plutus-core/plutus-core/src/PlutusCore.hs @@ -163,7 +163,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts import Control.Monad.Except import Data.ByteString.Lazy qualified as BSL import Data.Text qualified as T -import Text.Megaparsec (SourcePos, initialPos) +import Text.Megaparsec (ParseErrorBundle, SourcePos, initialPos) topSourcePos :: SourcePos @@ -188,11 +188,8 @@ fileTypeCfg cfg = fmap (either prettyErr id . printType) . BSL.readFile -- | Print the type of a program contained in a 'ByteString' printType - :: (AsUniqueError e SourcePos, - AsTypeError e (Term TyName Name DefaultUni DefaultFun ()) DefaultUni DefaultFun SourcePos, - MonadError e m) - => BSL.ByteString - -> m T.Text + :: BSL.ByteString + -> Either (ParseErrorBundle T.Text ParseError) T.Text printType bs = runQuoteT $ T.pack . show . pretty <$> do scoped <- parseScoped bs config <- getDefTypeCheckConfig topSourcePos @@ -201,23 +198,16 @@ printType bs = runQuoteT $ T.pack . show . pretty <$> do -- | Parse and rewrite so that names are globally unique, not just unique within -- their scope. parseScoped - :: (AsUniqueError e SourcePos, - MonadError e m, - MonadQuote m) - => BSL.ByteString - -> m (Program TyName Name DefaultUni DefaultFun SourcePos) + :: BSL.ByteString + -> Either (ParseErrorBundle T.Text ParseError) (Program TyName Name DefaultUni DefaultFun SourcePos) -- don't require there to be no free variables at this point, we might be parsing an open term parseScoped = through (Uniques.checkProgram (const True)) <=< rename <=< parseProgram -- | Parse a program and typecheck it. parseTypecheck - :: (AsUniqueError e SourcePos, - AsTypeError e (Term TyName Name DefaultUni DefaultFun ()) DefaultUni DefaultFun SourcePos, - MonadError e m, - MonadQuote m) - => TypeCheckConfig DefaultUni DefaultFun + :: TypeCheckConfig DefaultUni DefaultFun -> BSL.ByteString - -> m (Normalized (Type TyName DefaultUni ())) + -> Either (ParseErrorBundle T.Text ParseError) (Normalized (Type TyName DefaultUni ())) parseTypecheck cfg = typecheckPipeline cfg <=< parseScoped -- | Typecheck a program. @@ -231,17 +221,17 @@ typecheckPipeline typecheckPipeline = inferTypeOfProgram parseProgramDef - :: (MonadError e m, MonadQuote m) - => BSL.ByteString -> m (Program TyName Name DefaultUni DefaultFun SourcePos) + :: BSL.ByteString -> Either (ParseErrorBundle T.Text ParseError) (Program TyName Name DefaultUni DefaultFun SourcePos) parseProgramDef = parseProgram -formatDoc :: (MonadError e m) => PrettyConfigPlc -> BSL.ByteString -> m (Doc a) +formatDoc :: + PrettyConfigPlc -> BSL.ByteString -> + Either (ParseErrorBundle T.Text ParseError) (Doc a) -- don't use parseScoped since we don't bother running sanity checks when we format formatDoc cfg = runQuoteT . fmap (prettyBy cfg) . (rename <=< parseProgramDef) format - :: (MonadError e m) - => PrettyConfigPlc -> BSL.ByteString -> m T.Text + :: PrettyConfigPlc -> BSL.ByteString -> m T.Text -- don't use parseScoped since we don't bother running sanity checks when we format format cfg = runQuoteT . fmap (displayBy cfg) . (rename <=< parseProgramDef) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs index c4852942410..27b36802c45 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs @@ -38,7 +38,6 @@ import PlutusCore.Evaluation.Result import Control.Applicative import Data.ByteString qualified as BS -import Data.Foldable import Data.Proxy import Data.Text qualified as Text import GHC.Exts (inline, oneShot) diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser.hs b/plutus-core/plutus-core/src/PlutusCore/Parser.hs index c5b228596a5..241364387f6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser.hs @@ -1,8 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} module PlutusCore.Parser ( parseProgram @@ -11,54 +8,85 @@ module PlutusCore.Parser , ParseError(..) ) where -import PlutusCore.Constant.Typed -import PlutusCore.Core -import PlutusCore.Core.Type -import PlutusCore.Default -import PlutusCore.Error -import PlutusCore.Mark -import PlutusCore.MkPlc (mkConstant, mkTyBuiltin) -import PlutusCore.Name -import PlutusCore.Quote -import PlutusPrelude -import Universe - -import Control.Monad.Except -import Control.Monad.State import Data.ByteString.Lazy (ByteString) -import Data.List.NonEmpty qualified as NE -import Data.Map qualified -import Data.Proxy import Data.Text qualified as T -import PlutusCore.Parser.ParserCommon (Parser, pType, parse) -import Text.Megaparsec (SourcePos, runParserT') +import PlutusCore.Core (Program (..), Term (..), Type) +import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Error (ParseError (..)) +import PlutusCore.Name (Name, TyName) +import PlutusCore.Parser.ParserCommon +import PlutusPrelude +import Text.Megaparsec (MonadParsec (notFollowedBy), SourcePos, anySingle, getSourcePos) import Text.Megaparsec.Error (ParseErrorBundle) -tyInst :: a -> Term tyname name uni fun a -> NonEmpty (Type tyname uni a) -> Term tyname name uni fun a -tyInst loc t (ty :| []) = TyInst loc t ty -tyInst loc t (ty :| tys) = TyInst loc (tyInst loc t (ty:|init tys)) (last tys) +-- Parsers for PLC terms + +-- | A parsable PLC term. +type PTerm = Term TyName Name DefaultUni DefaultFun SourcePos + +varTerm :: Parser PTerm +varTerm = Var <$> getSourcePos <*> name + +tyAbsTerm :: Parser PTerm +tyAbsTerm = TyAbs <$> wordPos "abs" <*> tyName <*> kind <*> term + +lamTerm :: Parser PTerm +lamTerm = inParens $ LamAbs <$> wordPos "lam" <*> name <*> pType <*> term + +appTerm :: Parser PTerm +appTerm = inBrackets $ Apply <$> getSourcePos <*> term <*> term -tyApps :: a -> Type tyname uni a -> NonEmpty (Type tyname uni a) -> Type tyname uni a -tyApps loc ty (ty' :| []) = TyApp loc ty ty' -tyApps loc ty (ty' :| tys) = TyApp loc (tyApps loc ty (ty':|init tys)) (last tys) +conTerm :: Parser PTerm +conTerm = inParens $ Constant <$> wordPos "con" <*> constant -app :: a -> Term tyname name uni fun a -> NonEmpty (Term tyname name uni fun a) -> Term tyname name uni fun a -app loc t (t' :| []) = Apply loc t t' -app loc t (t' :| ts) = Apply loc (app loc t (t':|init ts)) (last ts) +builtinTerm :: Parser PTerm +builtinTerm = inParens $ Builtin <$> wordPos "builtin" <*> builtinFunction + +tyInstTerm :: Parser PTerm +tyInstTerm = inBraces $ TyInst <$> getSourcePos <*> term <*> pType + +unwrapTerm :: Parser PTerm +unwrapTerm = inParens $ Unwrap <$> wordPos "unwrap" <*> term + +iwrapTerm :: Parser PTerm +iwrapTerm = inParens $ IWrap <$> wordPos "iwrap" <*> pType <*> pType <*> term + +errorTerm + :: Parser PTerm +errorTerm = inParens $ Error <$> wordPos "error" <*> pType + +-- | Parser for all PLC terms. +term :: Parser PTerm +term = varTerm + <|> tyAbsTerm + <|> lamTerm + <|> appTerm + <|> conTerm + <|> builtinTerm + <|> tyInstTerm + <|> unwrapTerm + <|> iwrapTerm + <|> errorTerm -- | Parse a PLC program. The resulting program will have fresh names. The underlying monad must be capable -- of handling any parse errors. parseProgram :: - String -> T.Text -> - Either (ParseErrorBundle T.Text ParseError) (Program TyName Name DefaultUni DefaultFun SourcePos) -parseProgram = parse pProgram + ByteString -> Either (ParseErrorBundle T.Text ParseError) (Program TyName Name DefaultUni DefaultFun SourcePos) +parseProgram = parseGen program + +-- | Parser for PLC programs. +program :: Parser (Program TyName Name DefaultUni DefaultFun SourcePos) +program = whitespace >> do + prog <- inParens $ Program <$> wordPos "program" <*> version <*> term + notFollowedBy anySingle + return prog -- | Parse a PLC term. The resulting program will have fresh names. The underlying monad must be capable -- of handling any parse errors. parseTerm :: String -> T.Text -> Either (ParseErrorBundle T.Text ParseError) (Term TyName Name DefaultUni DefaultFun SourcePos) -parseTerm = parse pTerm +parseTerm = parse term -- | Parse a PLC type. The resulting program will have fresh names. The underlying monad must be capable -- of handling any parse errors. diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs index a4209d64681..6df2730bc79 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs @@ -20,6 +20,7 @@ import Text.Megaparsec.Char.Lexer qualified as Lex import Control.Monad.State (MonadState (get, put), StateT, evalStateT) +import Data.ByteString.Lazy (ByteString) import PlutusCore.Core.Type qualified as PLC import PlutusCore.Default qualified as PLC import PlutusCore.Error qualified as PLC @@ -56,6 +57,10 @@ intern n = do parse :: Parser a -> String -> T.Text -> Either (ParseErrorBundle T.Text PLC.ParseError) a parse p file str = PLC.runQuote $ parseQuoted p file str +-- | Generic parser function. +parseGen :: Parser a -> ByteString -> Either (ParseErrorBundle T.Text PLC.ParseError) a +parseGen stuff bs = parse stuff "test" $ (T.pack . unpackChars) bs + parseQuoted :: Parser a -> String -> T.Text -> PLC.Quote (Either (ParseErrorBundle T.Text PLC.ParseError) a) parseQuoted p file str = flip evalStateT initial $ runParserT p file str diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs index 5c36e4cb716..a1c0ee60ed4 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs @@ -24,7 +24,6 @@ module UntypedPlutusCore.Parser import Prelude hiding (fail) import Control.Monad.Except ((<=<)) -import Control.Monad.State (StateT) import PlutusCore qualified as PLC import PlutusPrelude (through) @@ -34,64 +33,49 @@ import UntypedPlutusCore.Check.Uniques (checkProgram) import UntypedPlutusCore.Rename (Rename (rename)) import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy.Internal (unpackChars) import Data.Text qualified as T import PlutusCore.Parser.ParserCommon -- Parsers for UPLC terms -conTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) +-- | A parsable UPLC term. +type PTerm = UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos + +conTerm :: Parser PTerm conTerm = inParens $ UPLC.Constant <$> wordPos "con" <*> constant -builtinTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) +builtinTerm :: Parser PTerm builtinTerm = inParens $ UPLC.Builtin <$> wordPos "builtin" <*> builtinFunction -varTerm :: Parser (UPLC.Term PLC.Name uni fun SourcePos) +varTerm :: Parser PTerm varTerm = UPLC.Var <$> getSourcePos <*> name -lamTerm :: ParsecT PLC.ParseError - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser (UPLC.Term PLC.Name uni fun SourcePos) -lamTerm tm = inParens $ UPLC.LamAbs <$> wordPos "lam" <*> name <*> tm - -appTerm :: ParsecT PLC.ParseError - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser (UPLC.Term PLC.Name uni fun SourcePos) -appTerm tm = inBrackets $ UPLC.Apply <$> getSourcePos <*> tm <*> tm - -delayTerm :: ParsecT PLC.ParseError - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser (UPLC.Term PLC.Name uni fun SourcePos) -delayTerm tm = inParens $ UPLC.Delay <$> wordPos "abs" <*> tm - -forceTerm :: ParsecT PLC.ParseError - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser (UPLC.Term PLC.Name uni fun SourcePos) -forceTerm tm = inBraces $ UPLC.Force <$> getSourcePos <*> tm +lamTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) +lamTerm = inParens $ UPLC.LamAbs <$> wordPos "lam" <*> name <*> term + +appTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) +appTerm = inBrackets $ UPLC.Apply <$> getSourcePos <*> term <*> term + +delayTerm :: Parser PTerm +delayTerm = inParens $ UPLC.Delay <$> wordPos "abs" <*> term + +forceTerm :: Parser PTerm +forceTerm = inBraces $ UPLC.Force <$> getSourcePos <*> term errorTerm - :: Parser (UPLC.Term PLC.Name uni fun SourcePos) + :: Parser PTerm errorTerm = inParens $ UPLC.Error <$> wordPos "error" -- | Parser for all UPLC terms. -term :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) +term :: Parser PTerm term = conTerm <|> builtinTerm <|> varTerm - <|> lamTerm self - <|> appTerm self - <|> delayTerm self - <|> forceTerm self + <|> lamTerm + <|> appTerm + <|> delayTerm + <|> forceTerm <|> errorTerm - where self = term -- | Parser for UPLC programs. program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) @@ -100,17 +84,13 @@ program = whitespace >> do notFollowedBy anySingle return prog --- | Generic parser function. -parseGen :: Parser a -> ByteString -> Either (ParseErrorBundle T.Text PLC.ParseError) a -parseGen stuff bs = parse stuff "test" $ (T.pack . unpackChars) bs - --- | Parse a PLC term. The resulting program will have fresh names. The underlying monad must be capable +-- | 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) (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos) + Either (ParseErrorBundle T.Text PLC.ParseError) PTerm parseTerm = parseGen term --- | Parse a PLC program. The resulting program will have fresh names. The underlying monad must be capable +-- | 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)