Re #399: More uniform layout error reporter.

BNFC · Feb 8, 2022 · d517995 · d517995
1 parent 1915160
commit d517995
Show file tree

Hide file tree

Showing 2 changed files with 46 additions and 12 deletions.
diff --git 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
@@ -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`.