Fix #384: Haskell/OCaml printer: nil case also for nonempty lists

source/CHANGELOG.md

@@ -1,12 +1,13 @@
 # 2.9.3
 
-Andreas Abel <[email protected]>
+Andreas Abel <[email protected]>  September 2021
 
 * BNFC now uniformly signs generated files with its version number [#373]
 * C/C++: include `stdio.h` in parser header files [#381]
 * C++: fixed parser regression in 2.9.2: missing `#include <algorithm>` [#377]
 * Ocaml: lex CR as whitespace [see also #376]
 * Ocaml: correct position in parse errors [#380]
+* Ocaml/Haskell: make printer for lists categories total [#383]
 
 # 2.9.2
 

source/src/BNFC/Backend/Haskell/CFtoPrinter.hs

@@ -68,8 +68,9 @@ prologue tokenText useGadt name absMod cf = map text $ concat
     , "#endif"
     ]
   , [ ""
-    , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
-    , ""
+    -- -- WAS: Needed for precedence category lists, e.g. @[Exp2]@:
+    -- , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
+    -- , ""
     , "-- | Pretty-printer for " ++ takeWhile ('.' /=) name ++ "."
     , ""
     , "module " ++ name +++ "where"
@@ -292,7 +293,7 @@ case_fun absMod functor cf cat rules =
 
       -- Special printing of lists (precedence changes concrete syntax!)
       if isList cat then
-        map mkPrtListCase $ List.sortBy compareRules $ rulesForNormalizedCat cf cat
+        listCases $ List.sortBy compareRules $ rulesForNormalizedCat cf cat
 
       -- Ordinary category
       else
@@ -310,6 +311,20 @@ case_fun absMod functor cf cat rules =
       ListCat c    -> "[" <> type' c <> "]"
       c@TokenCat{} -> text (qualifiedCat absMod c)
       c            -> text (qualifiedCat absMod c) <> "' a"
+    listCases [] = []
+    listCases rules = concat
+      [ [ "prt _ [] = concatD []" | not $ any isNilFun rules ]
+            -- Andreas, 2021-09-22, issue #386
+            -- If the list is @nonempty@ according to the grammar, still add a nil case.
+            -- In the AST it is simply a list, and the AST could be created
+            -- by other means than by parsing.
+      , map (mkPrtListCase minPrec) rules
+      ]
+      where
+      -- Andreas, 2021-09-22, issue #384:
+      -- The minimum precedence of a rule lhs category in the rules set.
+      -- This is considered the default precedence; used to make the printing function total.
+      minPrec = minimum $ map precRule rules
 
 -- | When writing the Print instance for a category (in case_fun), we have
 -- a different case for each constructor for this category.
@@ -368,34 +383,38 @@ mkPrintCase absMod functor (Rule f cat rhs _internal) =
 
 -- | Pattern match on the list constructor and the coercion level
 --
--- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
+-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
 -- prt _ [] = concatD []
 --
--- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")] Parsable)
+-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")] Parsable)
 -- prt _ [x] = concatD [prt 0 x]
 --
--- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
+-- >>> mkPrtListCase 0 (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
 -- prt _ (x:xs) = concatD [prt 0 x, prt 0 xs]
 --
--- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
+-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
 -- prt 2 [] = concatD []
 --
--- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
+-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
 -- prt 2 [x] = concatD [prt 2 x]
 --
--- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
--- prt 2 (x:xs) = concatD [prt 2 x, prt 2 xs]
+-- >>> mkPrtListCase 2 (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
+-- prt _ (x:xs) = concatD [prt 2 x, prt 2 xs]
 --
-mkPrtListCase :: Rule -> Doc
-mkPrtListCase (Rule f (WithPosition _ (ListCat c)) rhs _internal)
+mkPrtListCase
+  :: Integer -- ^ The lowest precedence of a lhs in a list rule.  Default: 0.
+  -> Rule    -- ^ The list rule.
+  -> Doc
+mkPrtListCase minPrec (Rule f (WithPosition _ (ListCat c)) rhs _internal)
   | isNilFun f = "prt" <+> precPattern <+> "[]" <+> "=" <+> body
   | isOneFun f = "prt" <+> precPattern <+> "[x]" <+> "=" <+> body
   | isConsFun f = "prt" <+> precPattern <+> "(x:xs)" <+> "=" <+> body
   | otherwise = empty -- (++) constructor
   where
-    precPattern = case precCat c of 0 -> "_" ; p -> integer p
+    precPattern = if p <= minPrec then "_" else integer p
+    p = precCat c
     body = mkRhs ["x", "xs"] rhs
-mkPrtListCase _ = error "mkPrtListCase undefined for non-list categories"
+mkPrtListCase _ _ = error "mkPrtListCase undefined for non-list categories"
 
 
 -- | Define an ordering on lists' rules with the following properties:

source/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs

@@ -174,49 +174,64 @@ case_fun absMod cat xs = unlines [
 --   mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs
 
 ifList :: CF -> Cat -> String
-ifList cf cat = render $
-  case cases of
-    []         -> empty
+ifList cf cat
+  | null rules = ""
+  | otherwise  = render $ case cases of
+    []         -> empty  -- IMPOSSIBLE CASE when (rules /= [])
     first:rest -> vcat
         [ "and prt" <> text (fixTypeUpper cat)  <> "ListBNFC i es : doc = match (i, es) with"
         , nest 4 first
         , nest 2 $ vcat (map ("|" <+>) rest)
         ]
   where
     rules = sortBy compareRules $ rulesForNormalizedCat cf (ListCat cat)
-    cases = [ d | r <- rules, let d = mkPrtListCase r, not (isEmpty d) ]
-
+    cases = concat
+      [ [ "(_,[]) -> (concatD [])" | not $ any isNilFun rules ]
+            -- Andreas, 2021-09-22, issue #386
+            -- If the list is @nonempty@ according to the grammar, still add a nil case.
+            -- In the AST it is simply a list, and the AST could be created
+            -- by other means than by parsing.
+      , [ d | r <- rules, let d = mkPrtListCase minPrec r, not (isEmpty d) ]
+      ]
+    -- Andreas, 2021-09-22, issue #384:
+    -- The minimum precedence of a rule lhs category in the rules set.
+    -- This is considered the default precedence; used to make the printing function total.
+    minPrec = minimum $ map precRule rules
 
 -- | Pattern match on the list constructor and the coercion level
 --
--- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
+-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
 -- (_,[]) -> (concatD [])
 --
--- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")] Parsable)
+-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")] Parsable)
 -- (_,[x]) -> (concatD [prtFoo 0 x])
 --
--- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
+-- >>> mkPrtListCase 0 (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
 -- (_,x::xs) -> (concatD [prtFoo 0 x ; prtFooListBNFC 0 xs])
 --
--- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
+-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
 -- (2,[]) -> (concatD [])
 --
--- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
+-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
 -- (2,[x]) -> (concatD [prtFoo 2 x])
 --
--- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
--- (2,x::xs) -> (concatD [prtFoo 2 x ; prtFooListBNFC 2 xs])
+-- >>> mkPrtListCase 2 (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
+-- (_,x::xs) -> (concatD [prtFoo 2 x ; prtFooListBNFC 2 xs])
 --
-mkPrtListCase :: Rule -> Doc
-mkPrtListCase (Rule f (WithPosition _ (ListCat c)) rhs _)
+mkPrtListCase
+  :: Integer -- ^ The lowest precedence of a lhs in a list rule.  Default: 0.
+  -> Rule    -- ^ The list rule.
+  -> Doc
+mkPrtListCase minPrec (Rule f (WithPosition _ (ListCat c)) rhs _)
   | isNilFun f  = parens (precPattern <> "," <> "[]") <+> "->" <+> body
   | isOneFun f  = parens (precPattern <> "," <> "[x]") <+> "->" <+> body
   | isConsFun f = parens (precPattern <> "," <>"x::xs") <+> "->" <+> body
   | otherwise = empty -- (++) constructor
   where
-    precPattern = case precCat c of 0 -> "_" ; p -> integer p
+    precPattern = if p <= minPrec then "_" else integer p
+    p = precCat c
     body = text $ mkRhs ["x", "xs"] rhs
-mkPrtListCase _ = error "mkPrtListCase undefined for non-list categories"
+mkPrtListCase _ _ = error "mkPrtListCase undefined for non-list categories"
 
 mkRhs args its =
   "(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])"

source/src/BNFC/Lex.x

@@ -1,6 +1,5 @@
--- File generated by the BNF Converter (bnfc 2.9.3).
+-- -*- haskell -*- File generated by the BNF Converter (bnfc 2.9.3).
 
--- -*- haskell -*-
 -- Lexer definition for use with Alex 3
 {
 {-# OPTIONS -fno-warn-incomplete-patterns #-}

source/src/BNFC/Par.y

@@ -1,4 +1,4 @@
--- File generated by the BNF Converter (bnfc 2.9.3).
+-- -*- haskell -*- File generated by the BNF Converter (bnfc 2.9.3).
 
 -- Parser definition for use with Happy
 {

testing/regression-tests/#100_coercion_lists/test.cf

@@ -1,9 +1,9 @@
 SExp. S  ::= "exp" Exp ;
 SExp2. S ::= "exp2" Exp2 ;
-SFoo. S  ::= "foo" [Exp] ;
+SFoo. S  ::= "foo" [Exp1] ;
 SBar. S  ::= "bar" [Exp2] ;
 
-separator Exp "," ;
+separator Exp1 ",";
 separator Exp2 ".";
 
 EInt. Exp2 ::= Integer ;