WIP add program and term parsers in plc parser.

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)
 

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)

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.

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

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)