From 92bb6d5dc792c8d87fd7ba26da9a69f70155b6d9 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Wed, 22 Sep 2021 18:28:32 +0200 Subject: [PATCH] Re #384: Haskell/OCaml printer: complete patterns also for coercion lists We make the lowest precedence the catch-all. --- source/CHANGELOG.md | 3 +- .../src/BNFC/Backend/Haskell/CFtoPrinter.hs | 40 +++++++++++-------- .../BNFC/Backend/OCaml/CFtoOCamlPrinter.hs | 32 +++++++++------ .../#100_coercion_lists/test.cf | 4 +- 4 files changed, 48 insertions(+), 31 deletions(-) diff --git a/source/CHANGELOG.md b/source/CHANGELOG.md index 79fd07bb8..cc97f8fcf 100644 --- a/source/CHANGELOG.md +++ b/source/CHANGELOG.md @@ -1,12 +1,13 @@ # 2.9.3 -Andreas Abel +Andreas Abel 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 ` [#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 diff --git a/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs b/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs index 3fb48d26e..44be12fad 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoPrinter.hs +++ b/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: diff --git a/source/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs b/source/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs index 02bc1ffb4..7a751c128 100644 --- a/source/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs +++ b/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)) ++ "])" diff --git a/testing/regression-tests/#100_coercion_lists/test.cf b/testing/regression-tests/#100_coercion_lists/test.cf index d755bcffa..6802d9061 100644 --- a/testing/regression-tests/#100_coercion_lists/test.cf +++ b/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 ;