Skip to content

Commit d833dc6

Browse files
UnisayUnisay
committed
Improve parser error handling with Megaparsec best practices
Remove redundant try wrappers: - symbol is auto-backtracking since Megaparsec 4.4.0 - Removed 10 redundant try wrappers from keyword and delimiter parsing - Fixed duplicate "constr" entry bug Add strategic labels for better error messages: - Use <?> operator for two-level labeling (delimiters + keywords) - Replace explicit fail with <?> in type parser (more idiomatic) - Labels provide clearer context in parse errors Refactor to use between combinator: - Cleaner, more declarative code structure - Standard Megaparsec pattern for delimited parsing - Eliminates intermediate bindings Expand test coverage: - Add 6 new error message tests covering common error scenarios - Extract testParseError helper to reduce duplication - Organize error tests into dedicated test group - Verify labels appear correctly in error messages All 2,973 tests pass (781 UPLC + 1,864 PLC + 328 PlutusIR)
1 parent 5799445 commit d833dc6

File tree

3 files changed

+149
-87
lines changed
  • plutus-core

3 files changed

+149
-87
lines changed

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

Lines changed: 23 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -135,29 +135,29 @@ i.e. parse into @Tree Text@ and do the kind checking afterwards, but given that
135135
to do the kind checking of builtins regardless (even for UPLC), we don't win much by deferring
136136
doing it. -}
137137
defaultUni :: Parser (SomeTypeIn (Kinded DefaultUni))
138-
defaultUni = do
139-
choice $
140-
map
141-
try
142-
[ trailingWhitespace (inParens defaultUniApplication)
143-
, someType @_ @Integer <$ symbol "integer"
144-
, someType @_ @ByteString <$ symbol "bytestring"
145-
, someType @_ @Text <$ symbol "string"
146-
, someType @_ @() <$ symbol "unit"
147-
, someType @_ @Bool <$ symbol "bool"
148-
, someType @_ @[] <$ symbol "list"
149-
, someType @_ @Strict.Vector <$ symbol "array"
150-
, someType @_ @(,) <$ symbol "pair"
151-
, someType @_ @Data <$ symbol "data"
152-
, someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element"
153-
, someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element"
154-
, someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult"
155-
, someType @_ @Value <$ symbol "value"
156-
, -- We include an explicit failure case here to produce clearer error messages.
157-
-- Without this, using `choice` with `symbol` results in error messages that cover the longest possible SrcSpan,
158-
-- which in this context would be 20 characters spanning the entire "bls12_381_G2_element" token.
159-
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"
160-
]
138+
defaultUni =
139+
( choice $
140+
map
141+
try
142+
[ trailingWhitespace (inParens defaultUniApplication)
143+
, someType @_ @Integer <$ symbol "integer"
144+
, someType @_ @ByteString <$ symbol "bytestring"
145+
, someType @_ @Text <$ symbol "string"
146+
, someType @_ @() <$ symbol "unit"
147+
, someType @_ @Bool <$ symbol "bool"
148+
, someType @_ @[] <$ symbol "list"
149+
, someType @_ @Strict.Vector <$ symbol "array"
150+
, someType @_ @(,) <$ symbol "pair"
151+
, someType @_ @Data <$ symbol "data"
152+
, someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element"
153+
, someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element"
154+
, someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult"
155+
, someType @_ @Value <$ symbol "value"
156+
]
157+
)
158+
<?> "type name (integer, bytestring, string, unit, bool, list, array, pair,\
159+
\ data, value, bls12_381_G1_element, bls12_381_G2_element,\
160+
\ bls12_381_mlresult, or type application)"
161161

162162
tyName :: Parser TyName
163163
tyName = TyName <$> name

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

Lines changed: 22 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -100,31 +100,31 @@ term =
100100
]
101101
where
102102
tryAppTerm :: Parser PTerm
103-
tryAppTerm = do
104-
withSpan $ \sp -> do
105-
_ <- try (symbol "[")
106-
t <- appTerm sp
107-
_ <- char ']'
108-
return t
103+
tryAppTerm =
104+
withSpan $ \sp ->
105+
between
106+
(symbol "[" <?> "opening bracket '['")
107+
(char ']' <?> "closing bracket ']'")
108+
(appTerm sp)
109109

110110
tryTermInParens :: Parser PTerm
111111
tryTermInParens =
112-
withSpan $ \sp -> do
113-
_ <- try (symbol "(")
114-
t <-
115-
choice
116-
[ try (symbol "builtin") *> builtinTerm sp
117-
, try (symbol "lam") *> lamTerm sp
118-
, try (symbol "constr") *> constrTerm sp -- "constr" must come before "con"
119-
, try (symbol "con") *> conTerm sp
120-
, try (symbol "delay") *> delayTerm sp
121-
, try (symbol "force") *> forceTerm sp
122-
, try (symbol "error") *> errorTerm sp
123-
, try (symbol "constr") *> constrTerm sp
124-
, try (symbol "case") *> caseTerm sp
125-
]
126-
_ <- char ')'
127-
return t
112+
withSpan $ \sp ->
113+
between
114+
(symbol "(" <?> "opening parenthesis '('")
115+
(char ')' <?> "closing parenthesis ')'")
116+
( choice
117+
[ symbol "builtin" *> builtinTerm sp
118+
, symbol "lam" *> lamTerm sp
119+
, symbol "constr" *> constrTerm sp -- "constr" must come before "con"
120+
, symbol "con" *> conTerm sp
121+
, symbol "delay" *> delayTerm sp
122+
, symbol "force" *> forceTerm sp
123+
, symbol "error" *> errorTerm sp
124+
, symbol "case" *> caseTerm sp
125+
]
126+
<?> "term keyword (builtin, lam, constr, con, delay, force, error, case)"
127+
)
128128

129129
-- | Parser for UPLC programs.
130130
program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan)

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

Lines changed: 104 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,34 @@ import UntypedPlutusCore.Core.Type (progTerm, termAnn)
3535
import UntypedPlutusCore.Generators.Hedgehog.AST (genProgram, regenConstantsUntil)
3636
import UntypedPlutusCore.Parser (parseProgram, parseTerm)
3737

38+
--------------------------------------------------------------------------------
39+
-- Main Test Group -------------------------------------------------------------
40+
41+
test_parsing :: TestTree
42+
test_parsing =
43+
testGroup
44+
"Parsing"
45+
[ propFlat
46+
, propParser
47+
, propTermSrcSpan
48+
, propUnit
49+
, propDefaultUni
50+
, testGroup
51+
"Error Messages"
52+
[ propListElementErrorLocation
53+
, propTypeNameTypoErrorLocation
54+
, propMissingClosingParen
55+
, propMissingClosingBracket
56+
, propMissingBuiltinOperand
57+
, propMissingConOperands
58+
, propInvalidKeyword
59+
, propBracketMismatch
60+
]
61+
]
62+
63+
--------------------------------------------------------------------------------
64+
-- Test Definitions ------------------------------------------------------------
65+
3866
propFlat :: TestTree
3967
propFlat = testPropertyNamed "Flat" "Flat" $ property $ do
4068
prog <-
@@ -137,40 +165,87 @@ propDefaultUni =
137165
This uses the exact example from the issue report. -}
138166
propListElementErrorLocation :: TestTree
139167
propListElementErrorLocation =
140-
testCase "List element error location" $ do
141-
let code =
142-
T.unlines
143-
[ "(program 1.1.0 "
144-
, "["
145-
, " (force (builtin mkCons)) (con integer 4) (con (list integer) [true]) ]"
146-
, ")"
147-
]
148-
expectedErrorParts = ["unexpected 't'", "expecting '+', '-', ']', or integer"]
149-
case runQuoteT (parseProgram code) of
150-
Right _ -> error "Expected parse error, but parsing succeeded"
151-
Left (ParseErrorB errBundle) -> do
152-
let errMsg = T.pack $ errorBundlePretty errBundle
153-
let hasAllParts = all (`T.isInfixOf` errMsg) expectedErrorParts
154-
unless hasAllParts $
155-
error $
156-
"Error message does not match expected format.\n"
157-
<> "Expected to contain: "
158-
<> show expectedErrorParts
159-
<> "\nGot error message:\n"
160-
<> T.unpack errMsg
168+
testParseError
169+
"List element error location"
170+
( T.unlines
171+
[ "(program 1.1.0 "
172+
, "["
173+
, " (force (builtin mkCons)) (con integer 4) (con (list integer) [true]) ]"
174+
, ")"
175+
]
176+
)
177+
["unexpected 't'", "expecting '+', '-', ']', or integer"]
161178

162179
{-| Test that parser errors for typos in type names point to the correct location.
163180
This tests the case where "boot" is used instead of "bool". -}
164181
propTypeNameTypoErrorLocation :: TestTree
165182
propTypeNameTypoErrorLocation =
166-
testCase "Type name typo error location" $ do
167-
let code =
168-
T.unlines
169-
[ "(program 1.1.0"
170-
, "[ (builtin integerToByteString) (con boot True) (con integer 0) (con integer 712372356934756347862573452345342345) ]"
171-
, ")"
172-
]
173-
expectedErrorParts = ["Unknown type", "expected", "bool"]
183+
testParseError
184+
"Type name typo error location"
185+
( T.unlines
186+
[ "(program 1.1.0"
187+
, "[ (builtin integerToByteString) (con boot True) (con integer 0) (con integer 712372356934756347862573452345342345) ]"
188+
, ")"
189+
]
190+
)
191+
["type name", "bool"]
192+
193+
-- | Test that parser errors for missing closing parenthesis are clear.
194+
propMissingClosingParen :: TestTree
195+
propMissingClosingParen =
196+
testParseError
197+
"Missing closing parenthesis error"
198+
"(program 1.1.0 (lam x (var x))"
199+
["unexpected", "expecting", "term keyword"]
200+
201+
-- | Test that parser errors for missing closing bracket are clear.
202+
propMissingClosingBracket :: TestTree
203+
propMissingClosingBracket =
204+
testParseError
205+
"Missing closing bracket error"
206+
"(program 1.1.0 [(builtin addInteger) (con integer 1) (con integer 2))"
207+
["expecting", "closing bracket ']'"]
208+
209+
-- | Test that parser errors for missing builtin operand are clear.
210+
propMissingBuiltinOperand :: TestTree
211+
propMissingBuiltinOperand =
212+
testParseError
213+
"Missing builtin function name error"
214+
"(program 1.1.0 (builtin))"
215+
["Unknown built-in function"]
216+
217+
-- | Test that parser errors for missing con operands are clear.
218+
propMissingConOperands :: TestTree
219+
propMissingConOperands =
220+
testParseError
221+
"Missing con operands error"
222+
"(program 1.1.0 (con))"
223+
["unexpected", "expecting"]
224+
225+
-- | Test that parser errors for invalid keywords are clear.
226+
propInvalidKeyword :: TestTree
227+
propInvalidKeyword =
228+
testParseError
229+
"Invalid keyword error"
230+
"(program 1.1.0 (foo x))"
231+
["unexpected", "term keyword"]
232+
233+
-- | Test that parser errors for bracket mismatches are clear.
234+
propBracketMismatch :: TestTree
235+
propBracketMismatch =
236+
testParseError
237+
"Bracket type mismatch error"
238+
"(program 1.1.0 [(var x))"
239+
["unexpected", "expecting", "term keyword"]
240+
241+
--------------------------------------------------------------------------------
242+
-- Helper Functions ------------------------------------------------------------
243+
244+
{-| Helper function to test parser error messages.
245+
Tests that parsing fails with an error message containing all expected parts. -}
246+
testParseError :: String -> T.Text -> [T.Text] -> TestTree
247+
testParseError testName code expectedErrorParts =
248+
testCase testName $ do
174249
case runQuoteT (parseProgram code) of
175250
Right _ -> error "Expected parse error, but parsing succeeded"
176251
Left (ParseErrorB errBundle) -> do
@@ -183,16 +258,3 @@ propTypeNameTypoErrorLocation =
183258
<> show expectedErrorParts
184259
<> "\nGot error message:\n"
185260
<> T.unpack errMsg
186-
187-
test_parsing :: TestTree
188-
test_parsing =
189-
testGroup
190-
"Parsing"
191-
[ propFlat
192-
, propParser
193-
, propTermSrcSpan
194-
, propUnit
195-
, propDefaultUni
196-
, propListElementErrorLocation
197-
, propTypeNameTypoErrorLocation
198-
]

0 commit comments

Comments
 (0)