diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 1b2872d92a9..e1b4bdfc916 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -202,6 +202,7 @@ library PlutusCore.Generators.Internal.TypeEvalCheck PlutusCore.Generators.Internal.TypedBuiltinGen PlutusCore.Generators.Internal.Utils + PlutusCore.Lexer.Lexer PlutusCore.Lexer.Type PlutusCore.Parsable PlutusCore.Parser.Internal diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser/Lexer.hs b/plutus-core/plutus-core/src/PlutusCore/Lexer/Lexer.hs similarity index 52% rename from plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser/Lexer.hs rename to plutus-core/plutus-core/src/PlutusCore/Lexer/Lexer.hs index c102baab83a..20fe3799b0f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser/Lexer.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Lexer/Lexer.hs @@ -1,15 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module UntypedPlutusCore.Lexer where +module PlutusCore.Lexer.Lexer where -import PlutusCore.Lexer +import PlutusCore.Lexer (AlexPosn) import PlutusCore.Lexer.Type as L (Token) import PlutusPrelude (NonEmpty ((:|)), Pretty (pretty), Render (render)) import qualified Data.List as DL import qualified Data.List.NonEmpty as NE import Data.Proxy (Proxy (..)) +import qualified Data.Set as Set +import Data.Void (Void) import Text.Megaparsec data WithPos a = WithPos @@ -19,54 +21,60 @@ data WithPos a = WithPos , tokenVal :: a } deriving (Eq, Ord, Show) -data MyStream = MyStream - { myStreamInput :: String -- for showing offending lines - , unMyStream :: [WithPos (L.Token AlexPosn)] +data TkStream = TkStream + { tkStreamInput :: String -- for showing offending lines + , unTkStream :: [WithPos (L.Token AlexPosn)] } -instance Stream MyStream where - type Token MyStream = WithPos (L.Token AlexPosn) - type Tokens MyStream = [WithPos (L.Token AlexPosn)] + +-- data KwStream = KwStream +-- { kwStreamInput :: String +-- , unKwStream :: [WithPos Keyword ] +-- } + +instance Stream TkStream where + type Token TkStream = WithPos (L.Token AlexPosn) + type Tokens TkStream = [WithPos (L.Token AlexPosn)] tokenToChunk Proxy x = [x] tokensToChunk Proxy xs = xs chunkToTokens Proxy = id chunkLength Proxy = length chunkEmpty Proxy = null - take1_ (MyStream _ []) = Nothing - take1_ (MyStream str (t:ts)) = Just + take1_ (TkStream _ []) = Nothing + take1_ (TkStream str (t:ts)) = Just ( t - , MyStream (drop (tokensLength pxy (t:|[])) str) ts + , TkStream (drop (tokensLength pxy (t:|[])) str) ts ) - takeN_ n (MyStream str s) - | n <= 0 = Just ([], MyStream str s) + takeN_ n (TkStream str s) + | n <= 0 = Just ([], TkStream str s) | null s = Nothing | otherwise = let (x, s') = splitAt n s in case NE.nonEmpty x of - Nothing -> Just (x, MyStream str s') - Just nex -> Just (x, MyStream (drop (tokensLength pxy nex) str) s') - takeWhile_ f (MyStream str s) = + Nothing -> Just (x, TkStream str s') + Just nex -> Just (x, TkStream (drop (tokensLength pxy nex) str) s') + takeWhile_ f (TkStream str s) = let (x, s') = DL.span f s in case NE.nonEmpty x of - Nothing -> (x, MyStream str s') - Just nex -> (x, MyStream (drop (tokensLength pxy nex) str) s') + Nothing -> (x, TkStream str s') + Just nex -> (x, TkStream (drop (tokensLength pxy nex) str) s') showToken :: L.Token AlexPosn -> String showToken = render . pretty -instance VisualStream MyStream where +instance VisualStream TkStream where showTokens Proxy = unwords . NE.toList . fmap (showToken . tokenVal) tokensLength Proxy xs = sum (tokenLength <$> xs) -instance TraversableStream MyStream where +instance TraversableStream TkStream where reachOffset o PosState {..} = ( Just (prefix ++ restOfLine) , PosState - { pstateInput = MyStream - { myStreamInput = postStr - , unMyStream = post + { pstateInput = TkStream + { tkStreamInput = postStr + , unTkStream = post } , pstateOffset = max pstateOffset o , pstateSourcePos = newSourcePos @@ -84,13 +92,29 @@ instance TraversableStream MyStream where case post of [] -> pstateSourcePos (x:_) -> startPos x - (pre, post) = splitAt (o - pstateOffset) (unMyStream pstateInput) - (preStr, postStr) = splitAt tokensConsumed (myStreamInput pstateInput) + (pre, post) = splitAt (o - pstateOffset) (unTkStream pstateInput) + (preStr, postStr) = splitAt tokensConsumed (tkStreamInput pstateInput) tokensConsumed = case NE.nonEmpty pre of Nothing -> 0 Just nePre -> tokensLength pxy nePre restOfLine = takeWhile (/= '\n') postStr -pxy :: Proxy MyStream +pxy :: Proxy TkStream pxy = Proxy + +type Parser = Parsec Void TkStream + +liftToken :: L.Token AlexPosn -> WithPos (L.Token AlexPosn) +liftToken = WithPos pos pos 0 + where + pos = initialPos "" + +pToken :: L.Token AlexPosn -> Parser (L.Token AlexPosn) +pToken c = token test (Set.singleton . Tokens . nes . liftToken $ c) + where + test (WithPos _ _ _ x) = + if x == c + then Just x + else Nothing + nes x = x :| [] diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser/NewParser.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser/NewParser.hs deleted file mode 100644 index 4e86f29fe07..00000000000 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser/NewParser.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Parser for untyped Plutus Core using megaparsec, as in Plutus IR. --- Will replace UntypedPlutusCore.Parser.hs. --- Parser.y and Lexer.x, which currently generate Parser.hs, will be removed. - -module UntypedPlutusCore.NewParser - ( topSourcePos - , parse - , parseQuoted - , term - , program - , parseTerm - , parseProgram - , parseScoped - , Parser - , SourcePos - ) where - -import Prelude hiding (fail) - -import Control.Monad.Except ((<=<)) -import Control.Monad.State (StateT) - -import qualified NewUntypedPlutusCore as UPLC -import qualified PlutusCore as PLC -import qualified PlutusCore.Parsable as PLC -import PlutusPrelude (Pretty, through) -import Text.Megaparsec hiding (ParseError, State, parse) -import UntypedPlutusCore.Check.Uniques (checkProgram) -import UntypedPlutusCore.Rename (Rename (rename)) - -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy.Internal (unpackChars) -import qualified Data.Text as T -import PlutusCore.ParserCommon - --- Parsers for UPLC terms - -conTerm - :: (PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable, PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))) - => Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -conTerm = inParens $ UPLC.Constant <$> wordPos "con" <*> constant - -builtinTerm :: (Bounded fun, Enum fun, Pretty fun) - => Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -builtinTerm = inParens $ UPLC.Builtin <$> wordPos "builtin" <*> builtinFunction - -varTerm :: Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -varTerm = UPLC.Var <$> getSourcePos <*> name - -lamTerm :: ParsecT (PLC.ParseError SourcePos) - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -lamTerm tm = inParens $ UPLC.LamAbs <$> wordPos "lam" <*> name <*> tm - -appTerm :: ParsecT (PLC.ParseError SourcePos) - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -appTerm tm = inBrackets $ UPLC.Apply <$> getSourcePos <*> tm <*> tm - -delayTerm :: ParsecT (PLC.ParseError SourcePos) - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -delayTerm tm = inParens $ UPLC.Delay <$> wordPos "abs" <*> tm - -forceTerm :: ParsecT (PLC.ParseError SourcePos) - T.Text - (StateT ParserState PLC.Quote) - (UPLC.Term PLC.Name uni fun SourcePos) - -> Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -forceTerm tm = inBraces $ UPLC.Force <$> getSourcePos <*> tm - -errorTerm - :: Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -errorTerm = inParens $ UPLC.Error <$> wordPos "error" - --- | Parser for all UPLC terms. -term - :: ( PLC.Parsable (PLC.Some uni), PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable - , Bounded fun, Enum fun, Pretty fun, PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))) - => Parser SourcePos (UPLC.Term PLC.Name uni fun SourcePos) -term = conTerm - <|> builtinTerm - <|> varTerm - <|> lamTerm self - <|> appTerm self - <|> delayTerm self - <|> forceTerm self - <|> errorTerm - where self = term - --- | Parser for UPLC programs. -program - :: ( PLC.Parsable (PLC.Some uni), PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable - , Bounded fun, Enum fun, Pretty fun, PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))) - => Parser SourcePos (UPLC.Program PLC.Name uni fun SourcePos) -program = whitespace >> do - prog <- inParens $ UPLC.Program <$> wordPos "program" <*> version <*> term - notFollowedBy anySingle - return prog - --- | Generic parser function. -parseGen :: Parser SourcePos a -> ByteString -> Either (ParseErrorBundle T.Text (PLC.ParseError SourcePos)) 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 --- of handling any parse errors. -parseTerm :: - (PLC.Parsable (PLC.Some uni), PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable - , Bounded fun, Enum fun, Pretty fun, PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))) => - ByteString -> - Either (ParseErrorBundle T.Text (PLC.ParseError SourcePos)) (UPLC.Term PLC.Name uni fun SourcePos) -parseTerm = parseGen term - --- | Parse a PLC program. The resulting program will have fresh names. The underlying monad must be capable --- of handling any parse errors. -parseProgram :: (PLC.Parsable (PLC.Some uni), PLC.Closed uni, uni `PLC.Everywhere` PLC.Parsable - , Bounded fun, Enum fun, Pretty fun, PLC.Parsable (PLC.SomeTypeIn (PLC.Kinded uni))) => ByteString -> Either (ParseErrorBundle T.Text (PLC.ParseError SourcePos)) (UPLC.Program PLC.Name uni fun SourcePos) -parseProgram = parseGen 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 SourcePos))) - , PLC.AsUniqueError (ParseErrorBundle T.Text (PLC.ParseError SourcePos)) SourcePos - , PLC.Parsable (PLC.Some PLC.DefaultUni)) - => ByteString - -> Either (ParseErrorBundle T.Text (PLC.ParseError SourcePos)) (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 = through (checkProgram (const True)) <=< rename <=< parseProgram