From d517995e2a7f2b3b6a4104a1bd0c77cf5200d1fe Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Tue, 8 Feb 2022 16:55:12 +0100 Subject: [PATCH 1/2] Re #399: More uniform layout error reporter. --- source/src/BNFC/Backend/Haskell/CFtoLayout.hs | 42 +++++++++++++------ .../399_TopLayoutBrace/test.cf | 16 +++++++ 2 files changed, 46 insertions(+), 12 deletions(-) create mode 100644 testing/regression-tests/399_TopLayoutBrace/test.cf diff --git a/source/src/BNFC/Backend/Haskell/CFtoLayout.hs b/source/src/BNFC/Backend/Haskell/CFtoLayout.hs index a90557ac..e6620f60 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoLayout.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoLayout.hs @@ -73,9 +73,27 @@ cf2Layout layName lexName cf = unlines $ concat , render $ prettyList 2 "parenOpen =" "[" "]" "," $ map (text . show) parenOpen , render $ prettyList 2 "parenClose =" "[" "]" "," $ map (text . show) parenClose , "" + , "-- | Report an error during layout resolution." + , "layoutError" + , " :: [Token] -- ^ Remaining tokens." + , " -> String -- ^ Error message." + , " -> a" + , "layoutError ts msg" + , " | null ts = error $ concat [ \"Layout error: \", msg, \".\" ]" + , " | otherwise = error $ unlines" + , " [ concat [ \"Layout error at \", tokenPos ts, \": \", msg, \".\" ]" + , " , unwords $ concat" + , " [ [ \"Remaining tokens:\" ]" + , " , map prToken $ take 10 ts" + , " , [ \"...\" | not $ null $ drop 10 ts ]" + , " ]" + , " ]" + , "" , "-- | Replace layout syntax with explicit layout tokens." - , "resolveLayout :: Bool -- ^ Whether to use top-level layout." - , " -> [Token] -> [Token]" + , "resolveLayout" + , " :: Bool -- ^ Whether to use top-level layout." + , " -> [Token] -- ^ Token stream before layout resolution." + , " -> [Token] -- ^ Token stream after layout resolution." ] , caseMaybe topDelim -- No top-level layout @@ -96,7 +114,7 @@ cf2Layout layName lexName cf = unlines $ concat , " -> [Token] -> [Token]" , "" , " -- The stack should never be empty." - , " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts" + , " res _ [] ts = layoutError ts \"layout stack empty\"" , "" , " -- Handling explicit blocks:" , " res _ st (t0 : ts)" @@ -112,11 +130,11 @@ cf2Layout layName lexName cf = unlines $ concat , " , let (imps, rest) = span isImplicit st" , " , let st' = drop 1 rest" , " = if null st'" - , " then error $ unwords" - , " [ \"Layout error: Found\", prToken t0, \"at\" , tokenPos [t0]" - , " , \"without an explicit layout block.\"" + , " then layoutError ts $ unwords" + , " [ \"found\", prToken t0, \"at\" , tokenPos [t0]" + , " , \"without an explicit layout block\"" , " ]" - , " else map (closingToken (tokenPosn t0)) imps ++ t0 : res (Just t0) st' ts" + , " else map (closingToken ts (tokenPosn t0)) imps ++ t0 : res (Just t0) st' ts" , "" , " -- Ending or confirming implicit layout blocks:" , " res pt (b@(Implicit delim status col) : bs) (t0 : ts)" @@ -127,14 +145,14 @@ cf2Layout layName lexName cf = unlines $ concat , " -- more indented than the current token." , " , let (ebs, st') = span ((column t0 <) . indentation) bs" , " -- Insert block-closers after the previous token." - , " = map (closingToken (afterPrev pt)) (b : ebs) ++ t0 : res (Just t0) st' ts" + , " = map (closingToken ts (afterPrev pt)) (b : ebs) ++ t0 : res (Just t0) st' ts" , "" , " -- End of an implicit layout block by dedentation." , " | newLine pt t0" , " , column t0 < col" , " -- Insert a block closer after the previous token." , " -- Repeat, with the current block removed from the stack." - , " , let c = closingToken (afterPrev pt) b" + , " , let c = closingToken ts (afterPrev pt) b" , " = c : res (Just c) bs (t0 : ts)" , "" , " -- If we are on a newline, confirm the last tentative blocks." @@ -203,10 +221,10 @@ cf2Layout layName lexName cf = unlines $ concat , " -> (sToken (afterPrev pt) sep :)" , " _ -> id" , "" - , " closingToken :: Position -> Block -> Token" - , " closingToken pos = sToken pos . \\case" + , " closingToken :: [Token] -> Position -> Block -> Token" + , " closingToken ts pos = sToken pos . \\case" , " Implicit (LayoutDelimiters _ _ (Just sy)) _ _ -> sy" - , " _ -> error \"Trying to close a top level block.\"" + , " _ -> layoutError ts \"trying to close a top level block\"" , "" , "type Position = Posn" , "type Line = Int" diff --git a/testing/regression-tests/399_TopLayoutBrace/test.cf b/testing/regression-tests/399_TopLayoutBrace/test.cf new file mode 100644 index 00000000..c29bfe5c --- /dev/null +++ b/testing/regression-tests/399_TopLayoutBrace/test.cf @@ -0,0 +1,16 @@ +-- Andreas, 2022-02-08, PR #399 +-- Small reproducer for layout error "trying to close a top level block". + +terminator Exp ";" ; +layout toplevel ; + +Var. Exp ::= Ident; +Let. Exp ::= "let" "{" [Exp] "}" "in" Exp ; + +layout "in" ; +layout stop "let" ; + +comment "--" ; +comment "{-" "-}" ; + +-- Input for #399: `let {} in x`. From 0939190bde8824a5f8247bbed7ac820f0ef0561a Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Tue, 8 Feb 2022 18:25:27 +0100 Subject: [PATCH 2/2] Re #399: do not pop top layout block when encountering layout stop Layout stop words will now do not have any special effect when in the top layout block (column 1). Fixes a problem where they triggered an exception. --- source/CHANGELOG.md | 1 + source/src/BNFC/Backend/Haskell/CFtoLayout.hs | 4 ++++ testing/regression-tests/399_TopLayoutStop/good01.in | 2 ++ .../{399_TopLayoutBrace => 399_TopLayoutStop}/test.cf | 6 +++--- 4 files changed, 10 insertions(+), 3 deletions(-) create mode 100644 testing/regression-tests/399_TopLayoutStop/good01.in rename testing/regression-tests/{399_TopLayoutBrace => 399_TopLayoutStop}/test.cf (73%) diff --git a/source/CHANGELOG.md b/source/CHANGELOG.md index b53e6006..001a5921 100644 --- a/source/CHANGELOG.md +++ b/source/CHANGELOG.md @@ -6,6 +6,7 @@ Unreleased * Agda: support position information via `--functor` [#405] * C/C++: use `size_t` and `-Wsign-conversion` [#391] * C++: repair broken `--line-numbers` [#390], regression in 2.9.2 by [#349] +* Haskell: fix a problem with layout stop words and top-level layout [#399] * Ocaml: non-terminals in generated parser are now type-annotated [#407] Contributors: Michał Radwański diff --git a/source/src/BNFC/Backend/Haskell/CFtoLayout.hs b/source/src/BNFC/Backend/Haskell/CFtoLayout.hs index e6620f60..38322e03 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoLayout.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoLayout.hs @@ -138,6 +138,10 @@ cf2Layout layName lexName cf = unlines $ concat , "" , " -- Ending or confirming implicit layout blocks:" , " res pt (b@(Implicit delim status col) : bs) (t0 : ts)" + , " " + , " -- Do not end top-level layout block by layout stop word." + , " | isStop t0, col <= 1" + , " = t0 : res (Just t0) (b : bs) ts" , "" , " -- End of implicit block by a layout stop word." , " | isStop t0" diff --git a/testing/regression-tests/399_TopLayoutStop/good01.in b/testing/regression-tests/399_TopLayoutStop/good01.in new file mode 100644 index 00000000..fbee7926 --- /dev/null +++ b/testing/regression-tests/399_TopLayoutStop/good01.in @@ -0,0 +1,2 @@ +let {} +in x diff --git a/testing/regression-tests/399_TopLayoutBrace/test.cf b/testing/regression-tests/399_TopLayoutStop/test.cf similarity index 73% rename from testing/regression-tests/399_TopLayoutBrace/test.cf rename to testing/regression-tests/399_TopLayoutStop/test.cf index c29bfe5c..50728fd4 100644 --- a/testing/regression-tests/399_TopLayoutBrace/test.cf +++ b/testing/regression-tests/399_TopLayoutStop/test.cf @@ -7,10 +7,10 @@ layout toplevel ; Var. Exp ::= Ident; Let. Exp ::= "let" "{" [Exp] "}" "in" Exp ; -layout "in" ; -layout stop "let" ; +layout "let" ; +layout stop "in" ; comment "--" ; comment "{-" "-}" ; --- Input for #399: `let {} in x`. +-- Input for #399: `let {}\n in x`.