From 8c1b0c6f057b823018e679e9db48e35803548ccb Mon Sep 17 00:00:00 2001 From: Marty Stumpf Date: Mon, 10 Jan 2022 11:25:15 -0800 Subject: [PATCH] Fix con unit and integer parser. Partially fix conChar and tyInst. --- .../plutus-core/src/PlutusCore/Error.hs | 6 +-- .../plutus-core/src/PlutusCore/Parser.hs | 38 ++++++++++++++++--- .../src/PlutusCore/Parser/ParserCommon.hs | 16 ++++++-- plutus-core/plutus-core/test/Spec.hs | 2 +- plutus-errors/src/Errors.hs | 1 - 5 files changed, 47 insertions(+), 16 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Error.hs b/plutus-core/plutus-core/src/PlutusCore/Error.hs index 5de9286989b..0f47414557f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Error.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Error.hs @@ -42,7 +42,6 @@ import Control.Monad.Except import Data.Text qualified as T import ErrorCode import Prettyprinter (hardline, indent, squotes, (<+>)) -import Prettyprinter.Internal (Doc (Text)) import Text.Megaparsec.Error (ShowErrorComponent, showErrorComponent) import Text.Megaparsec.Pos (SourcePos, sourcePosPretty) import Universe (Closed (Everywhere), GEq, GShow) @@ -55,8 +54,7 @@ throwingEither r e = case e of -- | An error encountered during parsing. data ParseError - = LexErr String - | UnknownBuiltinType T.Text SourcePos + = UnknownBuiltinType T.Text SourcePos | BuiltinTypeNotAStar T.Text SourcePos | UnknownBuiltinFunction T.Text SourcePos | InvalidBuiltinConstant T.Text T.Text SourcePos @@ -127,7 +125,6 @@ instance Pretty SourcePos where pretty = pretty . sourcePosPretty instance Pretty ParseError where - pretty (LexErr s) = "Lexical error:" <+> Text (length s) (T.pack s) pretty (UnknownBuiltinType s loc) = "Unknown built-in type" <+> squotes (pretty s) <+> "at" <+> pretty loc pretty (BuiltinTypeNotAStar ty loc) = "Expected a type of kind star (to later parse a constant), but got:" <+> squotes (pretty ty) <+> "at" <+> pretty loc pretty (UnknownBuiltinFunction s loc) = "Unknown built-in function" <+> squotes (pretty s) <+> "at" <+> pretty loc @@ -198,7 +195,6 @@ instance HasErrorCode ParseError where errorCode UnknownBuiltinFunction {} = ErrorCode 9 errorCode UnknownBuiltinType {} = ErrorCode 8 errorCode BuiltinTypeNotAStar {} = ErrorCode 51 - errorCode LexErr {} = ErrorCode 6 instance HasErrorCode (UniqueError _a) where errorCode FreeVariable {} = ErrorCode 21 diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser.hs b/plutus-core/plutus-core/src/PlutusCore/Parser.hs index 3cd960793ed..c733673ed2a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module PlutusCore.Parser @@ -11,7 +12,7 @@ module PlutusCore.Parser import Data.ByteString.Lazy (ByteString) import Data.Text qualified as T import PlutusCore.Core (Program (..), Term (..), Type) -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default import PlutusCore.Error (ParseError (..)) import PlutusCore.Name (Name, TyName) import PlutusCore.Parser.ParserCommon @@ -40,7 +41,7 @@ appTerm = inBrackets $ do pure $ app pos tm tms app :: SourcePos -> PTerm -> [PTerm] -> PTerm -app _ _t [] = error "appTerm, app: An application without the argument." +app _ _t [] = error "appTerm, app: An application without an argument." app loc t [t'] = Apply loc t t' app loc t (t' : ts) = Apply loc (app loc t (t':init ts)) (last ts) @@ -62,15 +63,42 @@ appTerms = choice conTerm :: Parser PTerm conTerm = inParens $ do p <- wordPos "con" - _conTy <- defaultUniType -- TODO: do case of for each ty? - con <- constant + conTy <- defaultUniType -- TODO: do case of for each ty? + con <- + case conTy of + SomeTypeIn DefaultUniInteger -> conInt + SomeTypeIn DefaultUniByteString -> conChar + SomeTypeIn DefaultUniString -> conText + SomeTypeIn DefaultUniUnit -> conUnit + SomeTypeIn DefaultUniBool -> conBool pure $ Constant p con builtinTerm :: Parser PTerm builtinTerm = inParens $ Builtin <$> wordPos "builtin" <*> builtinFunction tyInstTerm :: Parser PTerm -tyInstTerm = inBraces $ TyInst <$> getSourcePos <*> term <*> pType +tyInstTerm = inBraces $ do + pos <- getSourcePos + tm <- term + tys <- appTypes + pure $ tyInst pos tm tys + +appTypes :: Parser [PType] +appTypes = choice + [ try types + , do + ty <- pType + pure [ty] + ] + where types = do + ty <- pType + tys <- appTypes + pure $ ty : tys + +tyInst :: SourcePos -> PTerm -> [PType] -> PTerm +tyInst _ _t [] = error "tyInst: A type instantiation without an argument." +tyInst loc t [ty] = TyInst loc t ty +tyInst loc t (ty : tys) = TyInst loc (tyInst loc t (ty : init tys)) (last tys) unwrapTerm :: Parser PTerm unwrapTerm = inParens $ Unwrap <$> wordPos "unwrap" <*> term diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs index 353c354ccd6..11bd638f304 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs @@ -104,6 +104,11 @@ appType = do args <- some pType pure $ foldl' (TyApp pos) fn args +tyApps :: SourcePos -> PType -> [PType] -> PType +tyApps _ _t [] = error "tyApps: A type application without an argument." +tyApps loc ty [ty'] = TyApp loc ty ty' +tyApps loc ty (ty' : tys) = TyApp loc (tyApps loc ty (ty':init tys)) (last tys) + kind :: Parser (Kind SourcePos) kind = inParens (typeKind <|> funKind) where @@ -124,7 +129,7 @@ pType = choice ] defaultUniType :: Parser (SomeTypeIn DefaultUni) -defaultUniType = choice +defaultUniType = choice $ map try [ inParens defaultUniType , SomeTypeIn DefaultUniInteger <$ symbol "integer" , SomeTypeIn DefaultUniByteString <$ symbol "bytestring" @@ -243,16 +248,19 @@ enforce p = do guard . not $ T.null input pure x +signedInteger :: ParsecT ParseError T.Text (StateT ParserState Quote) Integer +signedInteger = Lex.signed whitespace (lexeme Lex.decimal) + -- | Parser for integer constants. conInt :: Parser (Some (ValueOf DefaultUni)) conInt = do - con::Integer <- lexeme Lex.decimal + con::Integer <- signedInteger pure $ someValue con -- | Parser for single quoted char. conChar :: Parser (Some (ValueOf DefaultUni)) conChar = do - con <- between (char '\'') (char '\'') Lex.charLiteral + con <- Lex.charLiteral pure $ someValue $ singleton con -- | Parser for double quoted string. @@ -263,7 +271,7 @@ conText = do -- | Parser for unit. conUnit :: Parser (Some (ValueOf DefaultUni)) -conUnit = someValue () <$ symbol "unit" +conUnit = someValue () <$ symbol "()" -- | Parser for bool. conBool :: Parser (Some (ValueOf DefaultUni)) diff --git a/plutus-core/plutus-core/test/Spec.hs b/plutus-core/plutus-core/test/Spec.hs index e83c130fb0d..2a836374bf0 100644 --- a/plutus-core/plutus-core/test/Spec.hs +++ b/plutus-core/plutus-core/test/Spec.hs @@ -191,9 +191,9 @@ tests :: TestTree tests = testCase "example programs" $ fold [ fmt "(program 0.1.0 [(builtin addInteger) x y])" @?= Right "(program 0.1.0 [ [ (builtin addInteger) x ] y ])" , fmt "(program 0.1.0 doesn't)" @?= Right "(program 0.1.0 doesn't)" - , fmt "{- program " @?= Left (LexErr "Error in nested comment at line 1, column 12") ] where + fmt :: BSL.ByteString -> Either ParseError T.Text fmt = format cfg cfg = defPrettyConfigPlcClassic defPrettyConfigPlcOptions diff --git a/plutus-errors/src/Errors.hs b/plutus-errors/src/Errors.hs index ac9fbdfe7d6..d41da73bec8 100644 --- a/plutus-errors/src/Errors.hs +++ b/plutus-errors/src/Errors.hs @@ -35,7 +35,6 @@ allErrors = , 'PIR.MalformedDataConstrResType , 'PIR.CompilationError , 'PIR.UnsupportedError - , 'PLC.LexErr , 'PLC.Unexpected , 'PLC.UnknownBuiltinType , 'PLC.BuiltinTypeNotAStar