Re #399: do not pop top layout block when encountering layout stop

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

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,29 +130,33 @@ 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)"
+    , "    "
+    , "      -- 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"
     , "           -- Exit the current block and all implicit blocks"
     , "           -- 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 +225,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"

testing/regression-tests/399_TopLayoutStop/good01.in

@@ -0,0 +1,2 @@
+let {} 
+in x

testing/regression-tests/399_TopLayoutStop/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 "let"                               ;
+layout stop "in"                           ;
+
+comment "--"                               ;
+comment "{-" "-}"                          ;
+
+-- Input for #399: `let {}\n in x`.