Re #384: Haskell/OCaml printer: complete patterns also for coercion l…

…ists

We make the lowest precedence the catch-all.

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,9 +68,9 @@ prologue tokenText useGadt name absMod cf = map text $ concat
     , "#endif"
     ]
   , [ ""
-    -- Needed for precedence category lists, e.g. @[Exp2]@:
-    , "{-# 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"
@@ -318,9 +318,13 @@ case_fun absMod functor cf cat rules =
             -- 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 rules
+      , 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.
@@ -379,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

@@ -191,39 +191,47 @@ ifList cf cat
             -- 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 r, not (isEmpty d) ]
+      , [ 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)) ++ "])"

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 ;