wip

Author: zeme-wana

plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs

@@ -25,7 +25,8 @@ import Data.Text qualified as T
 import Data.Text.Internal.Read (hexDigitToInt)
 import Data.Vector.Strict (Vector)
 import Data.Vector.Strict qualified as Vector
-import Text.Megaparsec (customFailure, getSourcePos, takeWhileP)
+import Debug.Trace
+import Text.Megaparsec (customFailure, getSourcePos, label, takeWhileP)
 import Text.Megaparsec.Char (char, hexDigitChar, string)
 import Text.Megaparsec.Char.Lexer qualified as Lex
 
@@ -185,12 +186,15 @@ constantOf expectParens uni =
 constant :: Parser (Some (ValueOf DefaultUni))
 constant = do
   -- Parse the type tag.
+  -- Provide a clearer error message when the type name is invalid.
+  -- After 'con', a type name is expected (e.g., 'bool', 'integer', 'bytestring').
   SomeTypeIn (Kinded uni) <- defaultUni
   -- Check it's of kind @*@, because a constant that we're about to parse can only be of type of
   -- kind @*@.
   Refl <- reoption $ checkStar uni
   -- Parse the constant of the type represented by the type tag.
-  someValueOf uni <$> constantOf ExpectParensYes uni
+  x <- someValueOf uni <$> constantOf ExpectParensYes uni
+  return x
 
 data ExpectParens
   = ExpectParensYes

plutus-core/plutus-core/src/PlutusCore/Parser/Type.hs

@@ -24,7 +24,10 @@ import Control.Monad
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Vector.Strict qualified as Strict
+import Debug.Trace
+import Text.Megaparsec (getOffset, getSourcePos, registerFancyFailure)
 import Text.Megaparsec hiding (ParseError, State, many, parse, some)
+import Text.Megaparsec.Error (ErrorFancy (ErrorFail), ErrorItem (Tokens))
 
 {-| A PLC @Type@ to be parsed. ATM the parser only works
 for types in the @DefaultUni@ with @DefaultFun@. -}
@@ -135,25 +138,24 @@ i.e. parse into @Tree Text@ and do the kind checking afterwards, but given that
 to do the kind checking of builtins regardless (even for UPLC), we don't win much by deferring
 doing it. -}
 defaultUni :: Parser (SomeTypeIn (Kinded DefaultUni))
-defaultUni =
-  choice $
-    map
-      try
-      [ trailingWhitespace (inParens defaultUniApplication)
-      , someType @_ @Integer <$ symbol "integer"
-      , someType @_ @ByteString <$ symbol "bytestring"
-      , someType @_ @Text <$ symbol "string"
-      , someType @_ @() <$ symbol "unit"
-      , someType @_ @Bool <$ symbol "bool"
-      , someType @_ @[] <$ symbol "list"
-      , someType @_ @Strict.Vector <$ symbol "array"
-      , someType @_ @(,) <$ symbol "pair"
-      , someType @_ @Data <$ symbol "data"
-      , someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element"
-      , someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element"
-      , someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult"
-      , someType @_ @Value <$ symbol "value"
-      ]
+defaultUni = do
+  choice
+    [ try $ trailingWhitespace (inParens defaultUniApplication)
+    , try $ someType @_ @Integer <$ symbol "integer"
+    , try $ someType @_ @ByteString <$ symbol "bytestring"
+    , try $ someType @_ @Text <$ symbol "string"
+    , try $ someType @_ @() <$ symbol "unit"
+    , try $ someType @_ @Bool <$ symbol "bool"
+    , try $ someType @_ @[] <$ symbol "list"
+    , try $ someType @_ @Strict.Vector <$ symbol "array"
+    , try $ someType @_ @(,) <$ symbol "pair"
+    , try $ someType @_ @Data <$ symbol "data"
+    , try $ someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element"
+    , try $ someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element"
+    , try $ someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult"
+    , try $ someType @_ @Value <$ symbol "value"
+    , fail "Unknown type, expected one of: bool, integer, bytestring, string, unit, list, array, pair, data, value, bls12_381_G1_element, bls12_381_G2_element, bls12_381_mlresult, or a type application in parens"
+    ]
 
 tyName :: Parser TyName
 tyName = TyName <$> name

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs

@@ -42,50 +42,50 @@ import PlutusCore.Version
 -- | A parsable UPLC term.
 type PTerm = UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan
 
-conTerm :: Parser PTerm
-conTerm = withSpan $ \sp ->
+conTerm :: SrcSpan -> Parser PTerm
+conTerm sp =
   UPLC.Constant sp <$> constant
 
-builtinTerm :: Parser PTerm
-builtinTerm = withSpan $ \sp ->
+builtinTerm :: SrcSpan -> Parser PTerm
+builtinTerm sp =
   UPLC.Builtin sp <$> builtinFunction
 
 varTerm :: Parser PTerm
-varTerm = withSpan $ \sp ->
-  UPLC.Var sp <$> name
+varTerm =
+  withSpan $ \sp -> UPLC.Var sp <$> name
 
-lamTerm :: Parser PTerm
-lamTerm = withSpan $ \sp ->
+lamTerm :: SrcSpan -> Parser PTerm
+lamTerm sp =
   UPLC.LamAbs sp <$> (trailingWhitespace name) <*> term
 
-appTerm :: Parser PTerm
-appTerm = withSpan $ \sp ->
+appTerm :: SrcSpan -> Parser PTerm
+appTerm sp =
   -- TODO: should not use the same `sp` for all arguments.
   mkIterApp <$> term <*> (fmap (sp,) <$> some term)
 
-delayTerm :: Parser PTerm
-delayTerm = withSpan $ \sp ->
+delayTerm :: SrcSpan -> Parser PTerm
+delayTerm sp =
   UPLC.Delay sp <$> term
 
-forceTerm :: Parser PTerm
-forceTerm = withSpan $ \sp ->
+forceTerm :: SrcSpan -> Parser PTerm
+forceTerm sp =
   UPLC.Force sp <$> term
 
-errorTerm :: Parser PTerm
-errorTerm = withSpan $ \sp ->
+errorTerm :: SrcSpan -> Parser PTerm
+errorTerm sp =
   return (UPLC.Error sp)
 
-constrTerm :: Parser PTerm
-constrTerm = withSpan $ \sp -> do
+constrTerm :: SrcSpan -> Parser PTerm
+constrTerm sp = do
   let maxTag = fromIntegral (maxBound :: Word64)
   tag :: Integer <- lexeme Lex.decimal
   args <- many term
   whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0"
   when (tag > maxTag) $ fail "constr tag too large: must be a legal Word64 value"
   pure $ UPLC.Constr sp (fromIntegral tag) args
 
-caseTerm :: Parser PTerm
-caseTerm = withSpan $ \sp -> do
+caseTerm :: SrcSpan -> Parser PTerm
+caseTerm sp = do
   res <- UPLC.Case sp <$> term <*> (V.fromList <$> many term)
   whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0"
   pure res
@@ -102,28 +102,30 @@ term =
   where
     tryAppTerm :: Parser PTerm
     tryAppTerm = do
-      _ <- try (symbol "[")
-      t <- appTerm
-      _ <- char ']'
-      return t
+      withSpan $ \sp -> do
+        _ <- try (symbol "[")
+        t <- appTerm sp
+        _ <- symbol "]"
+        return t
 
     tryTermInParens :: Parser PTerm
-    tryTermInParens = do
-      _ <- try (symbol "(")
-      t <-
-        choice
-          [ try (symbol "builtin") *> builtinTerm
-          , try (symbol "lam") *> lamTerm
-          , try (symbol "constr") *> constrTerm -- "constr" must come before "con"
-          , try (symbol "con") *> conTerm
-          , try (symbol "delay") *> delayTerm
-          , try (symbol "force") *> forceTerm
-          , try (symbol "error") *> errorTerm
-          , try (symbol "constr") *> constrTerm
-          , try (symbol "case") *> caseTerm
-          ]
-      _ <- char ')'
-      return t
+    tryTermInParens =
+      withSpan $ \sp -> do
+        _ <- try (symbol "(")
+        t <-
+          choice
+            [ try (symbol "builtin") *> builtinTerm sp
+            , try (symbol "lam") *> lamTerm sp
+            , try (symbol "constr") *> constrTerm sp -- "constr" must come before "con"
+            , try (symbol "con") *> conTerm sp
+            , try (symbol "delay") *> delayTerm sp
+            , try (symbol "force") *> forceTerm sp
+            , try (symbol "error") *> errorTerm sp
+            , try (symbol "constr") *> constrTerm sp
+            , try (symbol "case") *> caseTerm sp
+            ]
+        _ <- symbol ")"
+        return t
 
 -- | Parser for UPLC programs.
 program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan)

plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs

@@ -11,7 +11,8 @@ import Control.Lens (view)
 import Control.Monad (unless)
 import Data.Text (Text)
 import Data.Text qualified as T
-import Hedgehog (annotate, annotateShow, failure, property, tripping, (===))
+import Debug.Trace
+import Hedgehog (Gen, Property, annotate, annotateShow, failure, property, tripping, (===))
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Range qualified as Range
 import PlutusCore (Name)
@@ -58,20 +59,39 @@ propTermSrcSpan = testPropertyNamed
   "propTermSrcSpan"
   . property
   $ do
-    code <-
+    code <- genRandomCode
+    annotateShow code
+    let (endingLine, endingCol) = getCodeEndingLineAndCol code
+    result <- parseTermWithTrailingSpace code
+    case result of
+      Right term -> do
+        let (endingLine', endingCol') = getTermEndingLineAndCol term
+        annotateShow (endingLine', endingCol', "asdasdasdasdasdasdasdasdasdasdasd")
+        (endingLine', endingCol') === (endingLine, endingCol + 1)
+      Left err ->
+        handleParseError err
+  where
+    genRandomCode =
       display
         <$> forAllPretty
           ( view progTerm
               <$> runAstGen (regenConstantsUntil isSerialisable =<< genProgram @DefaultFun)
           )
-    annotateShow code
-    let (endingLine, endingCol) = length &&& T.length . last $ T.lines code
-    trailingSpaces <- forAllPretty $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n'])
-    case runQuoteT . parseTerm $ code <> trailingSpaces of
-      Right parsed ->
-        let sp = termAnn parsed
-         in (srcSpanELine sp, srcSpanECol sp) === (endingLine, endingCol)
-      Left err -> annotate (display err) >> failure
+
+    getCodeEndingLineAndCol code = (length &&& T.length . last) (T.lines code)
+
+    parseTermWithTrailingSpace code = do
+      trailingSpaces <- genTrailingSpaces
+      return $ runQuoteT $ parseTerm (code <> trailingSpaces)
+
+    genTrailingSpaces = forAllPretty $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n'])
+
+    getTermEndingLineAndCol term = do
+      let sp = termAnn term
+      let x = (srcSpanELine sp, srcSpanECol sp)
+      traceShow (term, sp, x) $ x
+
+    handleParseError err = annotate (display err) >> failure
 
 propUnit :: TestTree
 propUnit =
@@ -153,7 +173,7 @@ propTypeNameTypoErrorLocation =
             , "[ (builtin integerToByteString) (con boot True) (con integer 0) (con integer 712372356934756347862573452345342345) ]"
             , ")"
             ]
-        expectedErrorParts = ["unexpected", "expecting", "bool"]
+        expectedErrorParts = ["Unknown type", "expected", "bool"]
     case runQuoteT (parseProgram code) of
       Right _ -> error "Expected parse error, but parsing succeeded"
       Left (ParseErrorB errBundle) -> do