BNFC 2.9.1.1 → 2.9.2

raw patch · 85 files changed

+5860/−3126 lines, 85 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• BNFC.cabal +41/−53
• CHANGELOG.md +28/−4
• src/BNFC/Abs.hs +30/−5
• src/BNFC/Backend/Agda.hs +41/−35
• src/BNFC/Backend/C.hs +13/−49
• src/BNFC/Backend/C/CFtoBisonC.hs +359/−190
• src/BNFC/Backend/C/CFtoCAbs.hs +322/−41
• src/BNFC/Backend/C/CFtoCPrinter.hs +79/−49
• src/BNFC/Backend/C/CFtoCSkel.hs +16/−15
• src/BNFC/Backend/C/CFtoFlexC.hs +128/−80
• src/BNFC/Backend/C/Common.hs +18/−0
• src/BNFC/Backend/CPP/Common.hs +76/−0
• src/BNFC/Backend/CPP/Makefile.hs +10/−10
• src/BNFC/Backend/CPP/Naming.hs +6/−0
• src/BNFC/Backend/CPP/NoSTL.hs +17/−40
• src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs +0/−226
• src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs +22/−9
• src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs +0/−204
• src/BNFC/Backend/CPP/PrettyPrinter.hs +163/−128
• src/BNFC/Backend/CPP/STL.hs +17/−40
• src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs +0/−378
• src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs +64/−35
• src/BNFC/Backend/Common.hs +40/−12
• src/BNFC/Backend/Common/NamedVariables.hs +4/−3
• src/BNFC/Backend/Common/OOAbstract.hs +20/−16
• src/BNFC/Backend/Haskell.hs +44/−28
• src/BNFC/Backend/Haskell/CFtoAbstract.hs +26/−20
• src/BNFC/Backend/Haskell/CFtoAlex3.hs +344/−261
• src/BNFC/Backend/Haskell/CFtoHappy.hs +31/−22
• src/BNFC/Backend/Haskell/CFtoLayout.hs +335/−274
• src/BNFC/Backend/Haskell/CFtoPrinter.hs +122/−85
• src/BNFC/Backend/Haskell/CFtoTemplate.hs +1/−1
• src/BNFC/Backend/Haskell/Utils.hs +1/−1
• src/BNFC/Backend/HaskellGADT.hs +2/−2
• src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs +25/−15
• src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs +4/−2
• src/BNFC/Backend/Java.hs +35/−43
• src/BNFC/Backend/Java/CFtoAntlr4Parser.hs +2/−6
• src/BNFC/Backend/Java/CFtoCup15.hs +10/−60
• src/BNFC/Backend/Java/CFtoJavaAbs15.hs +93/−20
• src/BNFC/Backend/Java/CFtoJavaPrinter15.hs +126/−75
• src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs +39/−5
• src/BNFC/Backend/OCaml/CFtoOCamlLex.hs +7/−15
• src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs +12/−11
• src/BNFC/Backend/OCaml/CFtoOCamlShow.hs +1/−1
• src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs +3/−3
• src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs +1/−16
• src/BNFC/Backend/OCaml/OCamlUtil.hs +6/−0
• src/BNFC/Backend/Txt2Tag.hs +12/−10
• src/BNFC/Backend/XML.hs +21/−13
• src/BNFC/CF.hs +177/−184
• src/BNFC/GetCF.hs +33/−21
• src/BNFC/Lex.hs +590/−0
• src/BNFC/Lex.x +123/−43
• src/BNFC/Options.hs +8/−4
• src/BNFC/Par.hs +1604/−0
• src/BNFC/Par.y +133/−112
• src/BNFC/PrettyPrint.hs +22/−0
• src/BNFC/Print.hs +107/−74
• src/BNFC/TypeChecker.hs +30/−25
• src/BNFC/Utils.hs +161/−6
• stack-8.10.2.yaml +3/−0
• stack-8.10.3.yaml +3/−0
• stack-8.10.4.yaml +3/−0
• stack-8.10.yaml +0/−3
• stack-8.2.2.yaml +1/−0
• stack-8.2.yaml +0/−1
• stack-8.4.4.yaml +1/−0
• stack-8.4.yaml +0/−1
• stack-8.6.4.yaml +2/−0
• stack-8.6.5.yaml +1/−0
• stack-8.6.yaml +0/−1
• stack-8.8.2.yaml +2/−0
• stack-8.8.3.yaml +2/−0
• stack-8.8.4.yaml +4/−0
• stack-8.8.yaml +0/−3
• stack-9.0.1.yaml +33/−0
• stack-9.0.yaml +0/−3
• stack-9.10.yaml +0/−1
• stack-9.12.yaml +0/−3
• stack-9.2.yaml +0/−3
• stack-9.4.yaml +0/−3
• stack-9.6.yaml +0/−3
• stack-9.8.yaml +0/−6
• test/BNFC/CFSpec.hs +0/−15

@@ -1,5 +1,5 @@ Name: BNFC-Version: 2.9.1.1+Version: 2.9.2 cabal-version: 2.0   -- >=1.24 for the custom-setup section   -- >=2.0  for the build-tools: hspec-discover@@ -27,61 +27,52 @@   a LaTeX file containing a readable specification of the language.  tested-with:-  GHC == 9.12.2-  GHC == 9.10.3-  GHC == 9.8.4-  GHC == 9.6.7-  GHC == 9.4.8-  GHC == 9.2.8-  GHC == 9.0.2-  GHC == 8.10.7-  GHC == 8.8.4-  GHC == 8.6.5-  GHC == 8.4.4-  GHC == 8.2.2+  GHC == 7.10.3   GHC == 8.0.2-  -- GHC == 7.10.3+  GHC == 8.2.2+  GHC == 8.4.4+  GHC == 8.6.5+  GHC == 8.8.4+  GHC == 8.10.4+  GHC == 9.0.1 -Extra-doc-files:+Extra-source-files:   README.md   CHANGELOG.md   -- LICENSE is automatically included--Extra-source-files:   Makefile   src/BNFC.cf   src/Makefile-  stack-9.12.yaml-  stack-9.10.yaml-  stack-9.8.yaml-  stack-9.6.yaml-  stack-9.4.yaml-  stack-9.2.yaml-  stack-9.0.yaml-  stack-8.10.yaml-  stack-8.8.yaml-  stack-8.6.yaml-  stack-8.4.yaml-  stack-8.2.yaml+  stack-9.0.1.yaml+  stack-8.10.4.yaml+  stack-8.10.3.yaml+  stack-8.10.2.yaml+  stack-8.8.4.yaml+  stack-8.8.3.yaml+  stack-8.8.2.yaml+  stack-8.6.5.yaml+  stack-8.6.4.yaml+  stack-8.4.4.yaml+  stack-8.2.2.yaml   stack-8.0.2.yaml   stack-7.10.3.yaml  Source-repository head   type:     git-  location: https://github.com/BNFC/bnfc.git+  location: git://github.com/BNFC/bnfc.git   subdir:   source  Source-repository this   type:     git-  location: https://github.com/BNFC/bnfc.git+  location: git://github.com/BNFC/bnfc.git   subdir:   source-  tag:      v2.9.1.1+  tag:      v2.9.2  -- Setup using https://github.com/haskellari/cabal-doctest custom-setup  setup-depends:-   base >= 4 && < 5,-   Cabal >= 2.0 && < 4,+   base >= 4 && <5,+   Cabal >= 2.0,    cabal-doctest >= 1 && < 1.1  executable bnfc@@ -94,8 +85,6 @@   other-modules:     -- Generated by cabal     Paths_BNFC-  autogen-modules:-    Paths_BNFC   default-extensions:     -- Keep in alphabetical order.     LambdaCase@@ -114,17 +103,18 @@   default-language:     Haskell2010   build-depends:-    base >=4.8 && < 5,-    mtl >= 2.2.1,-    directory,-    array,-    containers,-    pretty >=1.1 && <1.2,-    filepath,-    deepseq,-    string-qq,-    time-  if impl(ghc < 8)+      base        >= 4.8   && < 5+    , array+    , containers+    , deepseq+    , directory+    , filepath+    , mtl         >= 2.2.1+    , pretty      >= 1.1   && < 1.2+    , process+    , string-qq+    , time+  if impl(ghc < 8.0)     build-depends:       semigroups   build-tool-depends:@@ -141,6 +131,7 @@     FlexibleContexts     FlexibleInstances     LambdaCase+    MultiWayIf     NamedFieldPuns     OverloadedStrings     PatternGuards@@ -159,8 +150,6 @@   other-modules:     -- Generated by cabal     Paths_BNFC-  autogen-modules:-    Paths_BNFC   exposed-modules:     -- Generated from LICENSE     BNFC.License@@ -220,6 +209,7 @@      -- C backend     BNFC.Backend.C+    BNFC.Backend.C.Common     BNFC.Backend.C.CFtoCPrinter     BNFC.Backend.C.CFtoCSkel     BNFC.Backend.C.CFtoBisonC@@ -228,17 +218,15 @@     BNFC.Backend.C.RegToFlex      -- C++ backend+    BNFC.Backend.CPP.Common     BNFC.Backend.CPP.PrettyPrinter     BNFC.Backend.CPP.Makefile     BNFC.Backend.CPP.Naming     BNFC.Backend.CPP.NoSTL-    BNFC.Backend.CPP.NoSTL.CFtoFlex-    BNFC.Backend.CPP.NoSTL.CFtoBison     BNFC.Backend.CPP.NoSTL.CFtoCPPAbs      -- C++ STL backend     BNFC.Backend.CPP.STL-    BNFC.Backend.CPP.STL.CFtoBisonSTL     BNFC.Backend.CPP.STL.CFtoSTLAbs     BNFC.Backend.CPP.STL.STLUtils     BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL@@ -294,7 +282,7 @@     deepseq,     string-qq,     time-  if impl(ghc < 8)+  if impl(ghc < 8.0)     build-depends:       semigroups   build-tool-depends:

@@ -1,9 +1,33 @@-# 2.9.1.1+# 2.9.2 -Andreas Abel <andreas.abel@gu.se>  Jan 2026+Andreas Abel <andreas.abel@gu.se>  June 2021 -* Cabal 3.12 compatibility: remove generated `Lex.hs` and `Par.hs` from source tarball-* Build tested with GHC 7.10.3 - 9.12.2+## Major improvements++* Haskell: layout keywords can now be stacked on the same line [#354],+  see https://bnfc.readthedocs.io/en/latest/lbnf.html#stacking-layout-keywords+* C: new methods `free_*` and `clone_*` to deallocate and clone syntax trees [#348]+* C/C++ backends now create reentrant parsers [#349]++## Bug fixes and small improvements++* Haskell-GADT: generated code is warning free [#346]+* Haskell: fixes in layout preprocessor [#343,#344,#345,#352,#353]+* Haskell: print `[Char]` correctly, removed method `prtList` [#359]+* Haskell: added missing import [#368], regression introduced in 2.9.1 by [#331]+* C: fixed a space leak when parsing from a string in memory [#347]+* C: removed errorneous `define`d constructors from `Skeleton.c`+* C++: `define`d constructors now reside in `Absyn` [#287]+* Java: `define`d constructor now reside in `AbsynDef.java` [#287]+* Ocaml: fixed translation of nested `define`d constructors+* C/C++/Java: Pre/post/mixfix lists are now printed correctly [#358]+* all: `define`d constructors involving list expressions work now [#363]+* all: printers render braces on their own line [#366]++## Cosmetical changes++* C/C++: instead of `_SYMB_nnn`, more readable token names in lexer & parser+  # 2.9.1 

@@ -1,14 +1,18 @@ -- Haskell data types for the abstract syntax. -- Generated by the BNF converter. -module BNFC.Abs where+{-# LANGUAGE PatternSynonyms #-} -import Prelude (Char, Double, Int, Integer, String)-import qualified Prelude as C (Eq, Ord, Show, Read)+-- | The abstract syntax of language BNFC. -newtype Identifier = Identifier ((Int, Int), String)-  deriving (C.Eq, C.Ord, C.Show, C.Read)+module BNFC.Abs where +import Prelude (Char, Double, Integer, String)+import qualified Prelude as C+  ( Eq, Ord, Show, Read+  , Int, Maybe(..)+  )+ data Grammar = Grammar [Def]   deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -80,4 +84,25 @@     | RLower     | RAny   deriving (C.Eq, C.Ord, C.Show, C.Read)++newtype Identifier = Identifier ((C.Int, C.Int), String)+  deriving (C.Eq, C.Ord, C.Show, C.Read)++-- | Start position (line, column) of something.++type BNFC'Position = C.Maybe (C.Int, C.Int)++pattern BNFC'NoPosition :: BNFC'Position+pattern BNFC'NoPosition = C.Nothing++pattern BNFC'Position :: C.Int -> C.Int -> BNFC'Position+pattern BNFC'Position line col = C.Just (line, col)++-- | Get the start position of something.++class HasPosition a where+  hasPosition :: a -> BNFC'Position++instance HasPosition Identifier where+  hasPosition (Identifier (p, _)) = C.Just p 

@@ -1,3 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+#endif+ -- | Agda backend. -- -- Generate bindings to Haskell data types for use in Agda.@@ -108,17 +119,6 @@ -- > {-# COMPILE GHC printDef     = \ d -> Data.Text.pack (printTree (d :: CPP.Abs.Def))  #-} -- > {-# COMPILE GHC printProgram = \ p -> Data.Text.pack (printTree (p :: CPP.Abs.Program)) #-} -{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}-#endif- module BNFC.Backend.Agda (makeAgda) where  import Prelude hiding ((<>))@@ -143,8 +143,6 @@ import BNFC.PrettyPrint import BNFC.Utils                  (ModuleName, replace, when, table) -type List1 = List1.NonEmpty- -- | How to print the types of constructors in Agda?  data ConstructorStyle@@ -331,25 +329,32 @@   -> Doc imports numeric layout pos = vcat . map prettyImport . concat $   [ when layout-    [ ("Agda.Builtin.Bool",   [("Bool", boolT)]) ]-  , [ ("Agda.Builtin.Char",   [("Char", charT)]) ]+    [ ("Agda.Builtin.Bool",   [],            [("Bool", boolT)]) ]+  , [ ("Agda.Builtin.Char",   [charT],       []               ) ]   , when (numeric == YesImportNumeric) importNumeric-  , [ ("Agda.Builtin.List",   [("List", listT)]) ]+  , [ ("Agda.Builtin.List",   ["[]", "_∷_"], [("List", listT)]) ]   , when pos-    [ ("Agda.Builtin.Nat",    [("Nat" , natT )]) ]-  , [ ("Agda.Builtin.String", [("String", stringT), ("primStringFromList", stringFromListT) ]) ]+    [ ("Agda.Builtin.Nat",    [],            [("Nat" , natT )]) ]+  , [ ("Agda.Builtin.String", [], [("String", stringT), ("primStringFromList", stringFromListT) ]) ]   ]   where-  importNumeric :: [(String, [(String, Doc)])]+  importNumeric :: [(String, [Doc], [(String, Doc)])]   importNumeric =-    [ ("Agda.Builtin.Float public", [("Float", doubleT)])-    , ("Agda.Builtin.Int   public", [("Int", integerT)])+    [ ("Agda.Builtin.Float public", [], [("Float", doubleT)])+    , ("Agda.Builtin.Int   public", [], [("Int", integerT)])+    , ("Agda.Builtin.Int"         , [], [("pos", "#pos")])     ]-  prettyImport :: (String, [(String, Doc)]) -> Doc-  prettyImport (m, ren) = prettyList 2 pre lparen rparen semi $-    map (\ (x, d) -> hsep [text x, "to", d ]) ren+  prettyImport :: (String, [Doc], [(String, Doc)]) -> Doc+  prettyImport (m, use, ren)+    | null ren  = pre+    | otherwise = prettyList 2 pre lparen rparen semi $+        map (\ (x, d) -> hsep [text x, "to", d ]) ren     where-    pre = hsep [ "open", "import", text m, "using", "()", "renaming" ]+    pre = hsep $ concat+      [ [ "open", "import", text m ]+      , [ "using", parens $ hcat $ punctuate "; " use ]+      , [ "renaming" | not (null ren) ]+      ]  -- | Import Agda AST. --@@ -462,7 +467,7 @@ -- prData :: ModuleName -> ConstructorStyle -> Data -> [Doc] prData amod style (Cat d, cs) = prData' amod style d cs-prData _    _     (c    , _ ) = error $ "prData: unexpected category " ++ show c+prData _    _     (c    , _ ) = error $ "prData: unexpected category " ++ prettyShow c  -- | Pretty-print Agda data types and pragmas. --@@ -649,23 +654,24 @@  -- | Generate Haskell code for the @define@d constructors. definedRules :: CF -> Doc-definedRules cf = vsep [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]+definedRules cf = vsep $ map mkDef $ definitions cf   where-    mkDef f xs e = vcat $ map text $ concat-      [ [ unwords [ mkDefName f, ":", typeToHaskell' "→" $ wpThing t ]+    mkDef (Define f args e t) = vcat $ concat+      [ [ text $ unwords [ mkDefName f, ":", typeToHaskell' "→" $ wpThing t ]         | t <- maybeToList $ sigLookup f cf         ]-      , [ unwords $ concat-          [ [ mkDefName f, "=", "λ" ]-          , map agdaLower xs-          , [ "→", show $ sanitize e ]+      , [ hsep $ concat+          [ [ text (mkDefName f), "=", "λ" ]+          , map (text . agdaLower . fst) args+          , [ "→", pretty $ sanitize e ]           ]         ]       ]     sanitize = \case-      App x es      -> App (agdaLower x) $ map sanitize es+      App "(:)" t es-> App "_∷_" t $ map sanitize es+      App x t es    -> App (agdaLower x) t $ map sanitize es       Var x         -> Var $ agdaLower x-      e@LitInt{}    -> e+      e@LitInt{}    -> App "#pos" dummyType [e]       e@LitDouble{} -> e       e@LitChar{}   -> e       e@LitString{} -> e

@@ -32,9 +32,9 @@     mkfile "Absyn.c" cfile     mkfile "Buffer.h" bufferH     mkfile "Buffer.c" $ bufferC "Buffer.h"-    let (flex, env) = cf2flex prefix cf+    let (flex, env) = cf2flex parserMode cf     mkfile (name ++ ".l") flex-    let bison = cf2Bison (linenumbers opts) prefix cf env+    let bison = cf2Bison (linenumbers opts) parserMode cf env     mkfile (name ++ ".y") bison     let header = mkHeaderFile (linenumbers opts) cf (Map.elems env)     mkfile "Parser.h" header@@ -54,6 +54,8 @@     -- It should be a valid C identifier.     prefix :: String     prefix = snakeCase_ name ++ "_"+    parserMode :: ParserMode+    parserMode = CParser False prefix   makefile :: String -> String -> String -> Doc@@ -86,6 +88,7 @@     , Makefile.mkRule "distclean" ["clean"]       [ "rm -f " ++ unwords         [ "Absyn.h", "Absyn.c"+        , "Bison.h"         , "Buffer.h", "Buffer.c"         , name ++ ".l", "Lexer.c"         , name ++ ".y", "Parser.h", "Parser.c"@@ -104,11 +107,11 @@       [ "${CC} ${CCFLAGS} -c Buffer.c" ]     , Makefile.mkRule "Lexer.c" [ name ++ ".l" ]       [ "${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l" ]-    , Makefile.mkRule "Parser.c" [ name ++ ".y" ]+    , Makefile.mkRule "Parser.c Bison.h" [ name ++ ".y" ]       [ "${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c" ]-    , Makefile.mkRule "Lexer.o" [ "Lexer.c", "Parser.h" ]+    , Makefile.mkRule "Lexer.o" [ "Lexer.c", "Bison.h" ]       [ "${CC} ${CCFLAGS} -c Lexer.c " ]-    , Makefile.mkRule "Parser.o" ["Parser.c", "Absyn.h" ]+    , Makefile.mkRule "Parser.o" ["Parser.c", "Absyn.h", "Bison.h" ]       [ "${CC} ${CCFLAGS} -c Parser.c" ]     , Makefile.mkRule "Printer.o" [ "Printer.c", "Printer.h", "Absyn.h" ]       [ "${CC} ${CCFLAGS} -c Printer.c" ]@@ -187,6 +190,7 @@     "      printf(\"[Linearized Tree]\\n\");",     "      printf(\"%s\\n\\n\", print" ++ dat ++ "(parse_tree));",     "    }",+    "    free_" ++ dat ++ "(parse_tree);",     "    return 0;",     "  }",     "  return 1;",@@ -208,52 +212,15 @@     , ""     , "#include \"Absyn.h\""     , ""-    , "typedef union"-    , "{"     ]-  , map ("  " ++) unionBuiltinTokens-  , concatMap mkPointer $ allParserCatsNorm cf-  , [ "} YYSTYPE;"-    , ""-      -- https://www.gnu.org/software/bison/manual/html_node/Location-Type.html#Location-Type-    , "typedef struct YYLTYPE"-    , "{"-    , "  int first_line;"-    , "  int first_column;"-    , "  int last_line;"-    , "  int last_column;"-    , "} YYLTYPE;"-    , ""-    , "#define _ERROR_ 258"-    , mkDefines (259::Int) env-    , ""-    , "extern YYLTYPE yylloc;"-    , "extern YYSTYPE yylval;"-    , ""-    ]+  -- Andreas, 2021-03-24+  -- Removed stuff that is now generated in Bison.h using the %defines pragma in the .y file.   , concatMap mkFunc $ toList $ allEntryPoints cf   , [ ""     , "#endif"     ]   ]   where-  mkDefines n [] = mkString n-  mkDefines n (s:ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)-  mkString n =  if isUsedCat cf (TokenCat catString)-   then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)-   else mkChar n-  mkChar n =  if isUsedCat cf (TokenCat catChar)-   then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)-   else mkInteger n-  mkInteger n =  if isUsedCat cf (TokenCat catInteger)-   then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)-   else mkDouble n-  mkDouble n =  if isUsedCat cf (TokenCat catDouble)-   then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)-   else mkIdent n-  mkIdent n =  if isUsedCat cf (TokenCat catIdent)-   then ("#define _IDENT_ " ++ show n ++ "\n")-   else ""   -- Andreas, 2019-04-29, issue #210: generate parsers also for coercions   mkFunc c =     [ identCat (normCat c) ++ "  p" ++ identCat c ++ "(FILE *inp);"@@ -381,12 +348,9 @@   , "    /* Make sure the buffer can hold all of s. */"   , "    bufferAllocateChars(buffer, len);"   , ""-  , "    /* Append s at the end of the buffer. */"-  , "    strncpy(buffer->chars + buffer->current, s, len);"-  , ""-  , "    /* Terminate with 0. */"+  , "    /* Append s at the end of the buffer, including terminating 0. */"+  , "    strncpy(buffer->chars + buffer->current, s, len + 1);"   , "    buffer->current += len;"-  , "    buffer->chars[buffer->current] = 0;"   , "  }"   , "}"   , ""

@@ -1,3 +1,9 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+ {-     BNF Converter: C Bison generator     Copyright (C) 2004  Author:  Michael Pellauer@@ -11,29 +17,31 @@     Created       : 6 August, 2003 -} -{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TupleSections #-}- module BNFC.Backend.C.CFtoBisonC   ( cf2Bison-  , mkPointer   , resultName, typeName, varName   , specialToks, startSymbol   , unionBuiltinTokens   )   where -import Data.Char (toLower)-import Data.Foldable (toList)-import Data.List (intercalate, nub)-import Data.Maybe (fromMaybe)+import Prelude hiding ((<>))++import Data.Char       ( toLower, isUpper )+import Data.Foldable   ( toList )+import Data.List       ( intercalate, nub )+import Data.Maybe import qualified Data.Map as Map+import System.FilePath ( (<.>) )  import BNFC.CF import BNFC.Backend.Common.NamedVariables hiding (varName)-import BNFC.Options (RecordPositions(..))-import BNFC.Utils ((+++))+import BNFC.Backend.C.CFtoFlexC (ParserMode(..), cParser, stlParser, parserHExt, parserName, parserPackage)+import BNFC.Backend.CPP.Naming+import BNFC.Backend.CPP.STL.STLUtils+import BNFC.Options (RecordPositions(..), InPackage)+import BNFC.PrettyPrint+import BNFC.Utils ((+++), table, applyWhen, for, unless, when, whenJust)  --This follows the basic structure of CFtoHappy. @@ -44,171 +52,265 @@ type MetaVar     = String  --The environment comes from the CFtoFlex-cf2Bison :: RecordPositions -> String -> CF -> SymMap -> String-cf2Bison rp name cf env = unlines-    [ header name cf-    , union (allParserCatsNorm cf)-    , "%token _ERROR_"-    , tokens (map fst $ tokenPragmas cf) env-    , declarations cf-    , specialToks cf+cf2Bison :: RecordPositions -> ParserMode -> CF -> SymMap -> String+cf2Bison rp mode cf env = unlines+    [ header mode cf+    , render $ union mode $ posCats ++ allParserCatsNorm cf+    , ""+    , unionDependentCode mode+    , unlines $ table " " $ concat+      [ [ ["%token", "_ERROR_" ] ]+      , tokens (map fst $ tokenPragmas cf) env+      , specialToks cf+      ]+    , declarations mode cf     , startSymbol cf     , ""     , "%%"     , ""-    , prRules (rulesForBison rp cf env)+    , prRules $ rulesForBison rp mode cf env     , "%%"     , ""-    , errorHandler name+    , nsStart inPackage+    , entryCode mode cf+    , nsEnd inPackage     ]+  where+  name = parserName mode+  inPackage = parserPackage mode+  posCats+    | stlParser mode = map TokenCat $ positionCats cf+    | otherwise      = [] -header :: String -> CF -> String-header name cf = unlines-    [ "/* This Bison file was machine-generated by BNFC */"+positionCats :: CF -> [String]+positionCats cf = [ wpThing name | TokenReg name True _ <- cfgPragmas cf ]++header :: ParserMode -> CF -> String+header mode cf = unlines $ concat+  [ [ "/* -*- c -*- This Bison file was machine-generated by BNFC */"     , ""+    , "/* Generate header file for lexer. */"+    , "%defines \"" ++ ("Bison" <.> h) ++ "\""+    ]+  , whenJust (parserPackage mode) $ \ ns ->+    [ "%name-prefix = \"" ++ ns ++ "\""+    , "  /* From Bison 2.6: %define api.prefix {" ++ ns ++ "} */"+    ]+  , [ ""+    , "/* Reentrant parser */"+    , "%pure_parser"+    , "  /* From Bison 2.3b (2008): %define api.pure full */"+         -- The flag %pure_parser is deprecated with a warning since Bison 3.4,+         -- but older Bisons like 2.3 (2006, shipped with macOS) don't recognize+         -- %define api.pure full+    , "%lex-param   { yyscan_t scanner }"+    , "%parse-param { yyscan_t scanner }"+    , ""     , concat [ "/* Turn on line/column tracking in the ", name, "lloc structure: */" ]     , "%locations"     , ""+    , "/* Argument to the parser to be filled with the parsed tree. */"+    , "%parse-param { YYSTYPE *result }"+    , ""     , "%{"     , "/* Begin C preamble code */"     , ""     , "#include <stdlib.h>"     , "#include <stdio.h>"     , "#include <string.h>"-    , "#include \"Absyn.h\""+    , "#include \"" ++ ("Absyn" <.> h) ++ "\""     , ""     , "#define YYMAXDEPTH 10000000"  -- default maximum stack size is 10000, but right-recursion needs O(n) stack     , ""-    , "typedef struct " ++ name ++ "_buffer_state *YY_BUFFER_STATE;"-    , "YY_BUFFER_STATE " ++ name ++ "_scan_string(const char *str);"-    , "void " ++ name ++ "_delete_buffer(YY_BUFFER_STATE buf);"-    , "extern int yyparse(void);"-    , "extern int yylex(void);"-    , "extern int " ++ name ++ "_init_lexer(FILE * inp);"-      -- this must be deferred until yylloc is defined-    , "extern void yyerror(const char *str);"+    , "/* The type yyscan_t is defined by flex, but we need it in the parser already. */"+    , "#ifndef YY_TYPEDEF_YY_SCANNER_T"+    , "#define YY_TYPEDEF_YY_SCANNER_T"+    , "typedef void* yyscan_t;"+    , "#endif"     , ""-    , concatMap reverseList $ filter isList $ allParserCatsNorm cf-    , "/* Global variables holding parse results for entrypoints. */"-    , unlines $ map parseResult $ nub $ map normCat eps-    , unlines $ map (parseMethod cf name) eps-    , "/* End C preamble code */"+    -- , "typedef struct " ++ name ++ "_buffer_state *YY_BUFFER_STATE;"+    , "typedef struct yy_buffer_state *YY_BUFFER_STATE;"+    , "extern YY_BUFFER_STATE " ++ name ++ "_scan_string(const char *str, yyscan_t scanner);"+    , "extern void " ++ name ++ "_delete_buffer(YY_BUFFER_STATE buf, yyscan_t scanner);"+    , ""+    , "extern void " ++ name ++ "lex_destroy(yyscan_t scanner);"+    , "extern char* " ++ name ++ "get_text(yyscan_t scanner);"+    , ""+    , "extern yyscan_t " ++ name ++ "_initialize_lexer(FILE * inp);"+    , ""+    ]+  , unless (stlParser mode)+    [ "/* List reversal functions. */"+    , concatMap (reverseList mode) $ filter isList $ allParserCatsNorm cf+    ]+  , [ "/* End C preamble code */"     , "%}"     ]+  ]   where   eps = toList (allEntryPoints cf)      -- Andreas, 2019-04-29, #210: Generate also parsers for CoercCat.      -- WAS:  (allCatsNorm cf)      -- Found old comment:      -- -- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug.+  h = parserHExt mode+  name = parserName mode --- | Generates declaration and initialization of the @YY_RESULT@ for a parser.------   Different parsers (for different precedences of the same category)---   share such a declaration.+-- | Code that needs the @YYSTYPE@ defined by the @%union@ pragma. -----   Expects a normalized category.-parseResult :: Cat -> String-parseResult cat =-  dat +++ resultName dat +++ "= 0;"+unionDependentCode :: ParserMode -> String+unionDependentCode mode = unlines+  [ "%{"+  , errorHandler name+  , "int yyparse(yyscan_t scanner, YYSTYPE *result);"+  , ""+  , "extern int yylex(YYSTYPE *lvalp, YYLTYPE *llocp, yyscan_t scanner);"+  , "%}"+  ]   where-  dat = identCat cat+  name = parserName mode  errorHandler :: String -> String errorHandler name = unlines-  [ "void yyerror(const char *str)"+  [ "void yyerror(YYLTYPE *loc, yyscan_t scanner, YYSTYPE *result, const char *msg)"   , "{"-  , "  extern char *" ++ name ++ "text;"-  , "  fprintf(stderr,\"error: %d,%d: %s at %s\\n\","-  , "  " ++ name ++ "lloc.first_line, " ++ name ++ "lloc.first_column, str, " ++ name ++ "text);"+  , "  fprintf(stderr, \"error: %d,%d: %s at %s\\n\","+  , "    loc->first_line, loc->first_column, msg, " ++ name ++ "get_text(scanner));"   , "}"   ] +-- | Parser entry point code.+--+entryCode :: ParserMode -> CF -> String+entryCode mode cf = unlines $ map (parseMethod mode cf) eps+  where+  eps = toList (allEntryPoints cf)+ --This generates a parser method for each entry point.-parseMethod :: CF -> String -> Cat -> String-parseMethod cf name cat = unlines $-  [ unwords [ "/* Entrypoint: parse", dat, "from file. */" ]-  , dat ++ " p" ++ parser ++ "(FILE *inp)"-  , "{"-  , "  " ++ name ++ "_init_lexer(inp);"-  , "  int result = yyparse();"-  , "  if (result)"-  , "  { /* Failure */"-  , "    return 0;"-  , "  }"-  , "  else"-  , "  { /* Success */"-  , "    return" +++ res ++ ";"-  , "  }"-  , "}"-  , ""-  , unwords [ "/* Entrypoint: parse", dat, "from string. */" ]-  , dat ++ " ps" ++ parser ++ "(const char *str)"-  , "{"-  , "  YY_BUFFER_STATE buf;"-  , "  " ++ name ++ "_init_lexer(0);"-  , "  buf = " ++ name ++ "_scan_string(str);"-  , "  int result = yyparse();"-  , "  " ++ name ++ "_delete_buffer(buf);"-  , "  if (result)"-  , "  { /* Failure */"-  , "    return 0;"-  , "  }"-  , "  else"-  , "  { /* Success */"-  , "    return" +++ res ++ ";"-  , "  }"-  , "}"+parseMethod :: ParserMode -> CF -> Cat -> String+parseMethod mode cf cat = unlines $ concat+  [ [ unwords [ "/* Entrypoint: parse", dat, "from file. */" ]+    , dat ++ " p" ++ parser ++ "(FILE *inp)"+    ]+  , body False+  , [ ""+    , unwords [ "/* Entrypoint: parse", dat, "from string. */" ]+    , dat ++ " ps" ++ parser ++ "(const char *str)"+    ]+  , body True   ]   where-  dat    = identCat (normCat cat)+  name = parserName mode+  body stringParser = concat+    [ [ "{"+      , "  YYSTYPE result;"+      , "  yyscan_t scanner = " ++ name ++ "_initialize_lexer(" ++ file ++ ");"+      , "  if (!scanner) {"+      , "    fprintf(stderr, \"Failed to initialize lexer.\\n\");"+      , "    return 0;"+      , "  }"+      ]+    , [ "  YY_BUFFER_STATE buf = " ++ name ++ "_scan_string(str, scanner);" | stringParser ]+    , [ "  int error = yyparse(scanner, &result);" ]+    , [ "  " ++ name ++ "_delete_buffer(buf, scanner);" | stringParser ]+    , [ "  " ++ name ++ "lex_destroy(scanner);"+      , "  if (error)"+      , "  { /* Failure */"+      , "    return 0;"+      , "  }"+      , "  else"+      , "  { /* Success */"+      ]+    , revOpt+    , [ "    return" +++ res ++ ";"+      , "  }"+      , "}"+      ]+    ]+    where+    file | stringParser = "0"+         | otherwise    = "inp"+  stl    = stlParser mode+  ncat   = normCat cat+  dat0   = identCat ncat+  dat    = if cParser mode then dat0 else dat0 ++ "*"   parser = identCat cat-  res0   = resultName dat-  revRes = "reverse" ++ dat ++ "(" ++ res0 ++ ")"-  res    = if cat `elem` cfgReversibleCats cf then revRes else res0+  res0   = concat [ "result.", varName ncat ]+  -- Reversing the result+  isReversible  = cat `elem` cfgReversibleCats cf+  -- C and NoSTL+  res+    | not stl, isReversible+                = "reverse" ++ dat0 ++ "(" ++ res0 ++ ")"+    | otherwise = res0+  -- STL: Vectors are snoc lists+  revOpt = when (stl && isList cat && not isReversible)+             [ "std::reverse(" ++ res ++ "->begin(), " ++ res ++"->end());" ]  --This method generates list reversal functions for each list type.-reverseList :: Cat -> String-reverseList c = unlines- [-  c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)",-  "{",-  "  " ++ c' +++"prev = 0;",-  "  " ++ c' +++"tmp = 0;",-  "  while (l)",-  "  {",-  "    tmp = l->" ++ v ++ ";",-  "    l->" ++ v +++ "= prev;",-  "    prev = l;",-  "    l = tmp;",-  "  }",-  "  return prev;",-  "}"- ]- where-  c' = identCat (normCat c)-  v = map toLower c' ++ "_"----The union declaration is special to Bison/Yacc and gives the type of yylval.---For efficiency, we may want to only include used categories here.-union :: [Cat] -> String-union cats = unlines $ concat-  [ [ "/* The type of a parse result (yylval). */" ]-  , [ "%union"+reverseList :: ParserMode -> Cat -> String+reverseList mode c0 = unlines+    [ c' ++ " reverse" ++ c ++ "(" ++ c' +++ "l)"     , "{"+    , "  " ++ c' +++"prev = 0;"+    , "  " ++ c' +++"tmp = 0;"+    , "  while (l)"+    , "  {"+    , "    tmp = l->" ++ v ++ ";"+    , "    l->" ++ v +++ "= prev;"+    , "    prev = l;"+    , "    l = tmp;"+    , "  }"+    , "  return prev;"+    , "}"     ]-  , map ("  " ++) unionBuiltinTokens-  , concatMap mkPointer cats-  , [ "}"+  where+  c  = identCat (normCat c0)+  c' = c ++ star+  v = map toLower c ++ "_"+  star = if cParser mode then "" else "*"++-- | The union declaration is special to Bison/Yacc and gives the type of+-- yylval.  For efficiency, we may want to only include used categories here.+--+-- >>> let foo = Cat "Foo"+-- >>> union (CParser True "") [foo, ListCat foo]+-- %union+-- {+--   int    _int;+--   char   _char;+--   double _double;+--   char*  _string;+--   Foo* foo_;+--   ListFoo* listfoo_;+-- }+--+-- If the given list of categories is contains coerced categories, those should+-- be normalized and duplicate removed+-- E.g. if there is both [Foo] and [Foo2] we should only print one pointer:+--    ListFoo* listfoo_;+--+-- >>> let foo2 = CoercCat "Foo" 2+-- >>> union (CppParser Nothing "") [foo, ListCat foo, foo2, ListCat foo2]+-- %union+-- {+--   int    _int;+--   char   _char;+--   double _double;+--   char*  _string;+--   Foo* foo_;+--   ListFoo* listfoo_;+-- }+union :: ParserMode -> [Cat] -> Doc+union mode cats = vcat+    [ "%union"+    , codeblock 2 $ map text unionBuiltinTokens ++ map mkPointer normCats     ]-  ]---This is a little weird because people can make [Exp2] etc.-mkPointer :: Cat -> [String]-mkPointer c-  | identCat c /= show c  --list. add it even if it refers to a coercion.-    || normCat c == c     --normal cat-    = [ "  " ++ identCat (normCat c) +++ varName (normCat c) ++ ";" ]-  | otherwise = []+  where+  normCats = nub (map normCat cats)+  mkPointer s = scope <> text (identCat s) <> star <+> text (varName s) <> ";"+  scope = text $ nsScope $ parserPackage mode+  star = if cParser mode then empty else text "*"  unionBuiltinTokens :: [String] unionBuiltinTokens =@@ -218,23 +320,27 @@   , "char*  _string;"   ] ---declares non-terminal types.-declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (allParserCats cf)- where --don't define internal rules-   typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName (normCat nt) ++ "> " ++ identCat nt ++ "\n"-   typeNT _ _ = ""+-- | @%type@ declarations for non-terminal types.+declarations :: ParserMode -> CF -> String+declarations mode cf = unlines $ map typeNT $+  posCats +++  filter (not . null . rulesForCat cf) (allParserCats cf) -- don't define internal rules+  where+  typeNT nt = "%type <" ++ varName nt ++ "> " ++ identCat nt+  posCats+    | stlParser mode = map TokenCat $ positionCats cf+    | otherwise      = []  --declares terminal types. -- token name "literal" -- "Syntax error messages passed to yyerror from the parser will reference the literal string instead of the token name." -- https://www.gnu.org/software/bison/manual/html_node/Token-Decl.html-tokens :: [UserDef] -> SymMap -> String-tokens user env = unlines $ map declTok $ Map.toList env- where+tokens :: [UserDef] -> SymMap -> [[String]]+tokens user env = map declTok $ Map.toList env+  where   declTok (Keyword   s, r) = tok "" s r   declTok (Tokentype s, r) = tok (if s `elem` user then "<_string>" else "") s r-  tok t s r = "%token" ++ t ++ " " ++ r ++ "    /*   " ++ cStringEscape s ++ "   */"+  tok t s r = [ "%token" ++ t, r, " /* " ++ cStringEscape s ++ " */" ]  -- | Escape characters inside a C string. cStringEscape :: String -> String@@ -244,13 +350,14 @@       | c `elem` ("\"\\" :: String) = '\\':[c]       | otherwise = [c] -specialToks :: CF -> String-specialToks cf = unlines $ concat-  [ ifC catString  "%token<_string> _STRING_"-  , ifC catChar    "%token<_char>   _CHAR_"-  , ifC catInteger "%token<_int>    _INTEGER_"-  , ifC catDouble  "%token<_double> _DOUBLE_"-  , ifC catIdent   "%token<_string> _IDENT_"+-- | Produces a table with the built-in token types.+specialToks :: CF -> [[String]]+specialToks cf = concat+  [ ifC catString  [ "%token<_string>", "_STRING_"  ]+  , ifC catChar    [ "%token<_char>  ", "_CHAR_"    ]+  , ifC catInteger [ "%token<_int>   ", "_INTEGER_" ]+  , ifC catDouble  [ "%token<_double>", "_DOUBLE_"  ]+  , ifC catIdent   [ "%token<_string>", "_IDENT_"   ]   ]   where     ifC cat s = if isUsedCat cf (TokenCat cat) then [s] else []@@ -261,74 +368,136 @@  --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForBison :: RecordPositions -> CF -> SymMap -> Rules-rulesForBison rp cf env = map mkOne $ ruleGroups cf where-  mkOne (cat,rules) = constructRule rp cf env rules cat+rulesForBison :: RecordPositions -> ParserMode -> CF -> SymMap -> Rules+rulesForBison rp mode cf env = map mkOne (ruleGroups cf) ++ posRules+  where+  mkOne (cat,rules) = constructRule rp mode cf env rules cat+  posRules :: Rules+  posRules+    | CppParser inPackage _ <- mode = for (positionCats cf) $ \ n -> (TokenCat n,+      [( Map.findWithDefault n (Tokentype n) env+       , addResult cf (TokenCat n) $ concat+         [ "$$ = new ", nsScope inPackage, n, "($1, @$.first_line);" ]+       )])+    | otherwise = []  -- For every non-terminal, we construct a set of rules. constructRule-  :: RecordPositions -> CF -> SymMap+  :: RecordPositions -> ParserMode -> CF -> SymMap   -> [Rule]                           -- ^ List of alternatives for parsing ...   -> NonTerminal                      -- ^ ... this non-terminal.   -> (NonTerminal,[(Pattern,Action)])-constructRule rp cf env rules nt = (nt,) $-    [ (p,) $ addResult $ generateAction rp (identCat (normCat nt)) (funRule r) b m+constructRule rp mode cf env rules nt = (nt,) $+    [ (p,) $ addResult cf nt $ generateAction rp mode (identCat (normCat nt)) (funRule r) b m     | r0 <- rules     , let (b,r) = if isConsFun (funRule r0) && valCat r0 `elem` cfgReversibleCats cf                   then (True, revSepListRule r0)                   else (False, r0)-    , let (p,m) = generatePatterns cf env r+    , let (p,m) = generatePatterns mode cf env r     ]-  where-    -- Add action if we parse an entrypoint non-terminal:-    -- Set field in result record to current parse.-    addResult a =-      if nt `elem` toList (allEntryPoints cf)-      -- Note: Bison has only a single entrypoint,-      -- but BNFC works around this by adding dedicated parse methods for all entrypoints.-        then a +++ resultName (identCat (normCat nt)) ++ "= $$;"-        else a +-- | Add action if we parse an entrypoint non-terminal:+-- Set field in result record to current parse.+addResult :: CF -> NonTerminal -> Action -> Action+addResult cf nt a =+  if nt `elem` toList (allEntryPoints cf)+  -- Note: Bison has only a single entrypoint,+  -- but BNFC works around this by adding dedicated parse methods for all entrypoints.+  -- Andreas, 2021-03-24: But see #350: bison still uses only the @%start@ non-terminal.+    then concat [ a, " result->", varName (normCat nt), " = $$;" ]+    else a++-- | Switch between STL or not.+generateAction :: IsFun a+  => RecordPositions     -- ^ Remember position information?+  -> ParserMode          -- ^ For C or C++?+  -> String              -- ^ List type.+  -> a                   -- ^ Rule name.+  -> Bool                -- ^ Reverse list?+  -> [(MetaVar, Bool)]   -- ^ Meta-vars; should the list referenced by the var be reversed?+  -> Action+generateAction rp = \case+  CppParser ns _ -> generateActionSTL rp ns+  CParser   b  _ -> \ nt f r -> generateActionC rp (not b) nt f r . map fst+ -- | Generates a string containing the semantic action.--- >>> generateAction NoRecordPositions "Foo" "Bar" False ["$1"]--- "make_Bar($1);"--- >>> generateAction NoRecordPositions "Foo" "_" False ["$1"]--- "$1;"--- >>> generateAction NoRecordPositions "ListFoo" "[]" False []--- "0;"--- >>> generateAction NoRecordPositions "ListFoo" "(:[])" False ["$1"]--- "make_ListFoo($1, 0);"--- >>> generateAction NoRecordPositions "ListFoo" "(:)" False ["$1","$2"]--- "make_ListFoo($1, $2);"--- >>> generateAction NoRecordPositions "ListFoo" "(:)" True ["$1","$2"]--- "make_ListFoo($2, $1);"-generateAction :: IsFun a => RecordPositions -> String -> a -> Bool -> [MetaVar] -> Action-generateAction rp nt f b ms-  | isCoercion f = unwords ms ++ ";" ++ loc-  | isNilFun f   = "0;"-  | isOneFun f   = concat ["make_", nt, "(", intercalate ", " ms', ", 0);"]-  | isConsFun f  = concat ["make_", nt, "(", intercalate ", " ms', ");"]-  | otherwise    = concat ["make_", funName f, "(", intercalate ", " ms', ");", loc]+-- >>> generateActionC NoRecordPositions False "Foo" "Bar" False ["$1"]+-- "$$ = new Bar($1);"+-- >>> generateActionC NoRecordPositions True "Foo" "Bar" False ["$1"]+-- "$$ = make_Bar($1);"+-- >>> generateActionC NoRecordPositions True "Foo" "_" False ["$1"]+-- "$$ = $1;"+-- >>> generateActionC NoRecordPositions True "ListFoo" "[]" False []+-- "$$ = 0;"+-- >>> generateActionC NoRecordPositions True "ListFoo" "(:[])" False ["$1"]+-- "$$ = make_ListFoo($1, 0);"+-- >>> generateActionC NoRecordPositions True "ListFoo" "(:)" False ["$1","$2"]+-- "$$ = make_ListFoo($1, $2);"+-- >>> generateActionC NoRecordPositions True "ListFoo" "(:)" True ["$1","$2"]+-- "$$ = make_ListFoo($2, $1);"+generateActionC :: IsFun a => RecordPositions -> Bool -> String -> a -> Bool -> [MetaVar] -> Action+generateActionC rp cParser nt f b ms+  | isCoercion f = "$$ = " ++ unwords ms ++ ";" ++ loc+  | isNilFun f   = "$$ = 0;"+  | isOneFun f   = concat ["$$ = ", new nt, "(", intercalate ", " ms', ", 0);"]+  | isConsFun f  = concat ["$$ = ", new nt, "(", intercalate ", " ms', ");"]+  | otherwise    = concat ["$$ = ", new (funName f), "(", intercalate ", " ms', ");", loc]  where   ms' = if b then reverse ms else ms-  loc = if rp == RecordPositions then " $$->line_number = @$.first_line; $$->char_number = @$.first_column;" else ""+  loc | RecordPositions <- rp+          = " $$->line_number = @$.first_line; $$->char_number = @$.first_column;"+      | otherwise+          = ""+  new :: String -> String+  new | cParser   = ("make_" ++)+      | otherwise = \ s -> if isUpper (head s) then "new " ++ s else sanitizeCpp s +generateActionSTL :: IsFun a => RecordPositions -> InPackage -> String -> a -> Bool -> [(MetaVar,Bool)] -> Action+generateActionSTL rp inPackage nt f b mbs = reverses +++  if | isCoercion f    -> concat ["$$ = ", unwords ms, ";", loc]+     | isNilFun f      -> concat ["$$ = ", "new ", scope, nt, "();"]+     | isOneFun f      -> concat ["$$ = ", "new ", scope, nt, "(); $$->push_back(", head ms, ");"]+     | isConsFun f     -> concat [lst, "->push_back(", el, "); $$ = ", lst, ";"]+     | isDefinedRule f -> concat ["$$ = ", scope, sanitizeCpp (funName f), "(", intercalate ", " ms, ");" ]+     | otherwise       -> concat ["$$ = ", "new ", scope, funName f, "(", intercalate ", " ms, ");", loc]+ where+  ms        = map fst mbs+  -- The following match only happens in the cons case:+  [el, lst] = applyWhen b reverse ms  -- b: left-recursion transformed?++  loc | RecordPositions <- rp+            = " $$->line_number = @$.first_line; $$->char_number = @$.first_column;"+      | otherwise+            = ""+  reverses  = unwords ["std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" | (m, True) <- mbs]+  scope     = nsScope inPackage+ -- Generate patterns and a set of metavariables indicating -- where in the pattern the non-terminal-generatePatterns :: CF -> SymMap -> Rule -> (Pattern,[MetaVar])-generatePatterns cf env r = case rhsRule r of+generatePatterns :: ParserMode -> CF -> SymMap -> Rule -> (Pattern,[(MetaVar,Bool)])+generatePatterns mode cf env r = case rhsRule r of   []  -> ("/* empty */",[])   its -> (unwords (map mkIt its), metas its)  where-   mkIt i = case i of-     Left (TokenCat s) -> fromMaybe (typeName s) $ Map.lookup (Tokentype s) env+   stl  = stlParser mode+   mkIt = \case+     Left (TokenCat s)+       | stl && isPositionCat cf s+                   -> typeName s+       | otherwise -> Map.findWithDefault (typeName s) (Tokentype s) env      Left c  -> identCat c-     Right s -> fromMaybe s $ Map.lookup (Keyword s) env-   metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]-   revIf c m = if not (isConsFun (funRule r)) && elem c revs+     Right s -> Map.findWithDefault s (Keyword s) env+   metas its = [(revIf c ('$': show i), revert c) | (i, Left c) <- zip [1 :: Int ..] its]+   -- C and C++/NoSTL: call reverse function+   revIf c m = if not stl && isntCons && elem c revs                  then "reverse" ++ identCat (normCat c) ++ "(" ++ m ++ ")"                else m  -- no reversal in the left-recursive Cons rule itself-   revs = cfgReversibleCats cf+   -- C++/STL: flag if reversal is necessary+   -- notice: reversibility with push_back vectors is the opposite+   -- of right-recursive lists!+   revert c = isntCons && isList c && notElem c revs+   revs     = cfgReversibleCats cf+   isntCons = not $ isConsFun $ funRule r  -- We have now constructed the patterns and actions, -- so the only thing left is to merge them into one string.@@ -337,11 +506,11 @@ prRules [] = [] prRules ((_, []):rs) = prRules rs --internal rule prRules ((nt, (p,a) : ls):rs) =-  unwords [nt', ":" , p, "{ $$ =", a, "}", '\n' : pr ls] ++ ";\n" ++ prRules rs+  unwords [nt', ":" , p, "{", a, "}", '\n' : pr ls] ++ ";\n" ++ prRules rs  where   nt' = identCat nt   pr []           = []-  pr ((p,a):ls)   = unlines [unwords ["  |", p, "{ $$ =", a , "}"]] ++ pr ls+  pr ((p,a):ls)   = unlines [unwords ["  |", p, "{", a , "}"]] ++ pr ls  --Some helper functions. resultName :: String -> String

@@ -18,15 +18,24 @@ module BNFC.Backend.C.CFtoCAbs (cf2CAbs) where  import Prelude hiding ((<>))-import Data.Char     (toLower)-import Data.Function (on)-import Data.List     (groupBy, intercalate, nub, sort) +import Control.Monad.State (State, gets, modify, evalState)++import Data.Char     ( toLower )+import Data.Either   ( lefts )+import Data.Function ( on )+import Data.List     ( groupBy, intercalate, intersperse, nub, sort )+import Data.Maybe    ( mapMaybe )+import Data.Set      ( Set )++import qualified Data.Set as Set+ import BNFC.CF import BNFC.PrettyPrint-import BNFC.Options (RecordPositions(..))-import BNFC.Utils   ((+++), uncurry3, unless)+import BNFC.Options  ( RecordPositions(..) )+import BNFC.Utils    ( (+++), uncurry3, unless ) import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.C.Common ( posixC )   -- | The result is two files (.H file, .C file)@@ -35,32 +44,60 @@   -> String -- ^ Ignored.   -> CF     -- ^ Grammar.   -> (String, String) -- ^ @.H@ file, @.C@ file.-cf2CAbs rp _ cf = (mkHFile rp cf, mkCFile cf)+cf2CAbs rp _ cf = (mkHFile rp classes datas cf, mkCFile datas cf)+  where+  datas :: [Data]+  datas = getAbstractSyntax cf+  classes :: [String]+  classes = nub $ map (identCat . fst) datas  {- **** Header (.H) File Functions **** -}  -- | Makes the Header file. -mkHFile :: RecordPositions -> CF -> String-mkHFile rp cf = unlines $ concat+mkHFile :: RecordPositions -> [String] -> [Data] -> CF -> String+mkHFile rp classes datas cf = unlines $ concat   [ [ "#ifndef ABSYN_HEADER"     , "#define ABSYN_HEADER"     , ""+    ]+  , posixC+  , [ ""+    , "#include <stddef.h>  /* NULL */"+    , "#include <string.h>  /* strdup */"+    , ""     , "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/"     , ""     , prTypeDefs user     , "/********************   Forward Declarations    ***********************/"     ]   , map prForward classes+   , [ "/********************   Abstract Syntax Classes    ********************/"     , ""     ]-  , map (prDataH rp) $ getAbstractSyntax cf+  , map (prDataH rp) datas++  -- Cloning+  , unless (null classes) $ concat+    [ cloneComment+    , map prCloneH classes+    , [ "" ]+    ]++  -- Freeing+  , unless (null classes) $ concat+    [ destructorComment+    , map prFreeH classes+    , [ "" ]+    ]+   , unless (null definedConstructors)     [ "/********************   Defined Constructors    ***********************/"     , ""     ]-  , map (uncurry3 (prDefH user)) definedConstructors+  , intersperse "" $ map (prDefH user) definedConstructors+   , [ ""     , "#endif"     ]@@ -68,49 +105,95 @@   where   user  :: [TokenCat]   user   = tokenNames cf-  rules :: [String]-  rules = getRules cf-  classes = nub (rules ++ getClasses (allCatsNorm cf))-  prForward s | not (isCoercion s) = unlines+  prForward :: String -> String+  prForward s = unlines     [ "struct " ++ s ++ "_;"     , "typedef struct " ++ s ++ "_ *" ++ s ++ ";"     ]-  prForward _ = ""-  getRules cf = map testRule (cfgRules cf)-  getClasses = map show . filter isDataCat-  testRule (Rule f (WithPosition _ c) _ _)-    | isList c && isConsFun f = identCat (normCat c)-    | otherwise = "_"-  definedConstructors = [ (funName f, xs, e) | FunDef f xs e <- cfgPragmas cf ]+  prCloneH :: String -> String+  prCloneH s = s ++ " clone_" ++ s ++ "(" ++ s ++ " p);"+  prFreeH :: String -> String+  prFreeH s = "void free_" ++ s ++ "(" ++ s ++ " p);"+  definedConstructors = definitions cf +cloneComment :: [String]+cloneComment =+  [ "/***************************   Cloning   ******************************/"+  , ""+  ]++destructorComment :: [String]+destructorComment =+  [ "/********************   Recursive Destructors    **********************/"+  , ""+  , "/* These free an entire abstract syntax tree"+  , " * including all subtrees and strings."+  , " *"+  , " * Will not work properly if there is sharing in the tree,"+  , " * i.e., when some pointers are aliased.  In this case"+  , " * it will attempt to free the same memory twice."+  , " */"+  , ""+  ]+ -- | For @define@d constructors, make a CPP definition. ----- >>> prDefH [] "iSg" ["i"] (App "ICons" [Var "i", App "INil" []])--- "#define make_iSg(i) make_ICons(i,make_INil())"+-- >>> prDefH [] (Define "iSg" [("i",undefined)] (App "ICons" undefined [Var "i", App "INil" undefined []]) undefined)+-- "#define make_iSg(i) \\\n  make_ICons (i, make_INil())" ----- >>> prDefH [] "snoc" ["xs","x"] (App "Cons" [Var "x", Var "xs"])--- "#define make_snoc(xs,x) make_Cons(x,xs)"+-- >>> prDefH [] (Define "snoc" (map (,undefined) ["xs","x"]) (App "Cons" undefined [Var "x", Var "xs"]) undefined)+-- "#define make_snoc(xs,x) \\\n  make_Cons (x, xs)" -- prDefH   :: [TokenCat] -- ^ Names of the token constructors (silent in C backend).-  -> String     -- ^ Name of the defined constructor.-  -> [String]   -- ^ Names of the arguments.-  -> Exp        -- ^ Definition (referring to arguments and rule labels).+  -> Define   -> String-prDefH tokenCats f xs e = concat [ "#define make_", f, "(", intercalate "," xs, ") ", prExp e ]+prDefH tokenCats (Define fun args e _t) =+  concat [ "#define make_", f, "(", intercalate "," xs, ") \\\n  ", prExp e `evalState` mempty ]   where-  prExp :: Exp -> String+  f  = funName fun+  xs = map fst args++  toCat :: Base -> Cat+  toCat = catOfType $ specialCatsP ++ tokenCats++  -- Issue #363, #348.+  -- Duplicate occurrences of variables in expression need to be cloned,+  -- because deallocation assumes that the AST is in fact a tree.+  -- Duplicate occurrences introduce sharing and thus turn it into a DAG+  -- (directed acyclic graph).+  -- We maintain a set of variables we have already encountered.+  prExp :: Exp -> State (Set String) String   prExp = \case-    Var x       -> x++    Var x -> gets (Set.member x) >>= \case+      -- The first use is not cloned.+      False -> x <$ modify (Set.insert x)+      -- Subsequent uses are cloned.+      True  -> case lookup x args of+        Just t -> return $ cloner (toCat t) x+        -- pattern match left incomplete on purpose+     -- Andreas, 2021-02-13, issue #338     -- Token categories are just @typedef@s in C, so no constructor needed.-    App g [e] | g `elem` tokenCats+    App g _ [e] | g `elem` tokenCats                 -> prExp e-    App g es    -> concat [ "make_", g, "(", intercalate "," (map prExp es), ")" ]-    LitInt    i -> show i-    LitDouble d -> show d-    LitChar   c -> show c-    LitString s -> show s+    App "[]" _ [] -> return "NULL"+    App g t es  -> do+      es' <- mapM prExp es+      return $ concat [ "make_", con g t, lparen es, intercalate ", " es', ")" ]+    LitInt    i -> return $ show i+    LitDouble d -> return $ show d+    LitChar   c -> return $ show c+    LitString s -> return $ concat [ "strdup(", show s, ")" ]  -- so that free() does not crash!+  con g ~(FunT ts t)+    | isConsFun g = identType t+    | otherwise   = g+  -- If more than one argument, or complex argument, put space before opening parenthesis.+  lparen = \case+    _:_:_           -> " ("+    [App _ _ (_:_)] -> " ("+    _               -> "("  -- | Prints struct definitions for all categories. prDataH :: RecordPositions -> Data -> String@@ -125,7 +208,7 @@       , c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);"       ]   | otherwise = unlines $ concat-    [ [ "struct " ++ show cat ++ "_"+    [ [ "struct " ++ identCat cat ++ "_"       , "{"       ]     , [ "  int line_number, char_number;" | rp == RecordPositions ]@@ -191,10 +274,17 @@ {- **** Implementation (.C) File Functions **** -}  -- | Makes the .C file-mkCFile :: CF -> String-mkCFile cf = concat+mkCFile :: [Data] -> CF -> String+mkCFile datas cf = concat   [ header-  , render $ vsep $ concatMap prDataC $ getAbstractSyntax cf+  , render $ vsep $ concatMap prDataC datas+  , unlines [ "", "" ]+  -- Cloning+  , unlines cloneComment+  , unlines $ concatMap prCloneC datas+  -- Freeing+  , unlines destructorComment+  , unlines $ concatMap prDestructorC datas   ]   where   header = unlines@@ -205,6 +295,197 @@     , "#include \"Absyn.h\""     , ""     ]++-- |+-- >>> text $ unlines $ prCloneC (Cat "Exp", [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Exp", Cat "Exp"])])+-- Exp clone_Exp(Exp p)+-- {+--   switch(p->kind)+--   {+--   case is_EInt:+--     return make_EInt (p->u.eint_.integer_);+-- <BLANKLINE>+--   case is_EAdd:+--     return make_EAdd+--       ( clone_Exp(p->u.eadd_.exp_1)+--       , clone_Exp(p->u.eadd_.exp_2)+--       );+-- <BLANKLINE>+--   default:+--     fprintf(stderr, "Error: bad kind field when cloning Exp!\n");+--     exit(1);+--   }+-- }+-- <BLANKLINE>+-- <BLANKLINE>+prCloneC :: Data -> [String]+prCloneC (cat, rules)+  | isList cat =+    [ cl ++ " clone_" ++ cl ++ "("++ cl +++ vname ++ ")"+    , "{"+    , "  if (" ++ vname ++ ")"+    , "  {"+    , "    /* clone of non-empty list */"+    , render $ prettyList 6 (text $ "    return make_" ++ cl) "(" ");" ","+        [ text $ visitMember+        , text $ "clone_" ++ cl ++ "(" ++ vname ++ "->" ++ vname ++ "_)"+        ]+    , "  }"+    , "  else return NULL; /* clone of empty list */"+    , "}"+    , ""+    ]+  | otherwise = concat+    [ [ cl ++ " clone_" ++ cl ++ "(" ++ cl ++ " p)"+      , "{"+      , "  switch(p->kind)"+      , "  {"+      ]+    , concatMap prCloneRule rules+    , [ "  default:"+      , "    fprintf(stderr, \"Error: bad kind field when cloning " ++ cl ++ "!\\n\");"+      , "    exit(1);"+      , "  }"+      , "}"+      , ""+      ]+    ]+  where+  cl          = identCat cat+  vname       = map toLower cl+  visitMember :: String+  visitMember = cloner el $ vname ++ "->" ++ member ++ "_"+    where+    el     = normCatOfList cat+    member = map toLower $ identCat el++  prCloneRule :: (String, [Cat]) -> [String]+  prCloneRule (fun, cats) | not (isCoercion fun) =+    [ "  case is_" ++ fnm ++ ":"+    , render $ prettyList 6 (text $ "    return make_" ++ fnm) "(" ");\n" "," $+        map (text . prCloneCat fnm) $ lefts $ numVars $ map Left cats+    ]+    where+    fnm = funName fun+  prCloneRule _ = []++  -- | This goes on to recurse to the instance variables.++  prCloneCat :: String -> (Cat, Doc) -> String+  prCloneCat fnm (cat, nt) = cloner cat member+    where+    member = concat [ "p->u.", map toLower fnm, "_.", render nt ]++-- | Clone or not depending on the category.+--   Only pointers need to be cloned.+--+cloner :: Cat -> String -> String+cloner cat x =+  case cat of+    TokenCat c+      | c `elem` ["Char", "Double", "Integer"]+                  -> x+      | otherwise -> "strdup" ++ parens x+    _             -> "clone_" ++ identCat (normCat cat) ++ parens x+  where parens = ("(" ++) . (++ ")")+++-- |+-- >>> text $ unlines $ prDestructorC (Cat "Exp", [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Exp", Cat "Exp"])])+-- void free_Exp(Exp p)+-- {+--   switch(p->kind)+--   {+--   case is_EInt:+--     break;+-- <BLANKLINE>+--   case is_EAdd:+--     free_Exp(p->u.eadd_.exp_1);+--     free_Exp(p->u.eadd_.exp_2);+--     break;+-- <BLANKLINE>+--   default:+--     fprintf(stderr, "Error: bad kind field when freeing Exp!\n");+--     exit(1);+--   }+--   free(p);+-- }+-- <BLANKLINE>+-- <BLANKLINE>+prDestructorC :: Data -> [String]+prDestructorC (cat, rules)+  | isList cat = concat+    [ [ "void free_" ++ cl ++ "("++ cl +++ vname ++ ")"+      , "{"+      , "  if (" ++ vname ++ ")"+      , "  {"+      ]+    , map ("    " ++) visitMember+    , [ "    free_" ++ cl ++ "(" ++ vname ++ "->" ++ vname ++ "_);"+      , "    free(" ++ vname ++ ");"+      , "  }"+      , "}"+      , ""+      ]+    ]+  | otherwise = concat+    [ [ "void free_" ++ cl ++ "(" ++ cl ++ " p)"+      , "{"+      , "  switch(p->kind)"+      , "  {"+      ]+    , concatMap prFreeRule rules+    , [ "  default:"+      , "    fprintf(stderr, \"Error: bad kind field when freeing " ++ cl ++ "!\\n\");"+      , "    exit(1);"+      , "  }"+      , "  free(p);"+      , "}"+      , ""+      ]+    ]+  where+  cl          = identCat cat+  vname       = map toLower cl+  visitMember =+    case ecat of+      TokenCat c+        | c `elem` ["Char", "Double", "Integer"] -> []+        | otherwise -> [ "free" ++ rest ]+      _             -> [ "free_" ++ ecl ++ rest ]+    where+    rest   = "(" ++ vname ++ "->" ++ member ++ "_);"+    member = map toLower ecl+    ecl    = identCat ecat+    ecat   = normCatOfList cat++  prFreeRule :: (String, [Cat]) -> [String]+  prFreeRule (fun, cats) | not (isCoercion fun) = concat+    [ [ "  case is_" ++ fnm ++ ":"+      ]+    , map ("    " ++) $ mapMaybe (prFreeCat fnm) $ lefts $ numVars $ map Left cats+    , [ "    break;"+      , ""+      ]+    ]+    where+    fnm = funName fun+  prFreeRule _ = []++  -- | This goes on to recurse to the instance variables.++  prFreeCat :: String -> (Cat, Doc) -> Maybe String+  prFreeCat fnm (TokenCat c, nt)+    | c `elem` ["Char", "Double", "Integer"] = Nothing+      -- Only pointer need to be freed.+  prFreeCat fnm (cat, nt) = Just $ concat+      [ maybe ("free_" ++ identCat (normCat cat)) (const "free") $ maybeTokenCat cat+      , "(p->u."+      , map toLower fnm+      , "_.", render nt, ");"+      ]++  prDataC :: Data -> [Doc] prDataC (cat, rules) = map (prRuleC cat) rules

@@ -26,11 +26,13 @@ import Data.Either    ( lefts ) import Data.Foldable  ( toList ) import Data.List      ( nub )+import Data.Maybe     ( isJust )  import BNFC.CF import BNFC.PrettyPrint-import BNFC.Utils ((+++), unless)-import BNFC.Backend.Common (renderListSepByPrecedence)+import BNFC.Utils     ( (+++), uniqOn, whenJust, unless, unlessNull )++import BNFC.Backend.Common import BNFC.Backend.Common.NamedVariables import BNFC.Backend.Common.StrUtils (renderCharOrString) @@ -85,6 +87,9 @@     "void renderCS(String s);",     "void indent(void);",     "void backup(void);",+    "void onEmptyLine(void);",+    "void removeTrailingSpaces(void);",+    "void removeTrailingWhitespace(void);",     ""    ]   footer = unlines $@@ -341,25 +346,25 @@   | isList cat = unlines $ concat     [ [ "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)"       , "{"-      , "  while(" ++ vname +++ "!= 0)"-      , "  {"-      , "    if (" ++ vname ++ "->" ++ vname ++ "_ == 0)"-      , "    {"-      , visitMember+      , "  if (" ++ vname +++ "== 0)"+      , "  { /* nil */"       ]-    , unless (hasOneFunc rules)-      [ "      " ++ render (renderX $ getCons rules) ++ ";" ]-    , [ "      " ++ vname +++ "= 0;"-      , "    }"-      , "    else"-      , "    {"-      , visitMember-      , render (nest 6 (renderListSepByPrecedence "i" renderX-          (getSeparatorByPrecedence rules)))-      , "      " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;"-      , "    }"+    , unlessNull (swRules isNilFun) $ \ docs ->+      [ render $ nest 4 $ vcat docs ]+    , [ "  }" ]+    , unlessNull (swRules isOneFun) $ \ docs ->+      [ "  else if (" ++ pre ++ vname ++ "_ == 0)"+      , "  { /* last */"+      , render $ nest 4 $ vcat docs       , "  }"-      , "}"+      ]+    , unlessNull (swRules isConsFun) $ \ docs ->+      [ "  else"+      , "  { /* cons */"+      , render $ nest 4 $ vcat docs+      , "  }"+      ]+    , [ "}"       , ""       ]     ]@@ -371,7 +376,7 @@       ]     , concatMap prPrintRule rules     , [ "  default:"-      , "    fprintf(stderr, \"Error: bad kind field when printing " ++ show cat ++ "!\\n\");"+      , "    fprintf(stderr, \"Error: bad kind field when printing " ++ catToStr cat ++ "!\\n\");"       , "    exit(1);"       , "  }"       , "}"@@ -380,10 +385,13 @@     ]  where    cl          = identCat (normCat cat)-   ecl         = identCat (normCatOfList cat)    vname       = map toLower cl-   member      = map toLower ecl-   visitMember = "      pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, i);"+   pre         = vname ++ "->"+   prules      = sortRulesByPrecedence rules+   swRules f   = switchByPrecedence "i" $+                   map (second $ sep . map text . prPrintRule_ pre) $+                     uniqOn fst $ filter f prules+                     -- Discard duplicates, can only handle one rule per precedence.  -- | Helper function that call the right c function (renderC or renderS) to -- render a literal string.@@ -402,32 +410,35 @@ -- | Pretty Printer methods for a rule.  prPrintRule :: Rule -> [String]-prPrintRule r@(Rule fun _ cats _) | not (isCoercion fun) = concat-  [ [ "  case is_" ++ f ++ ":"+prPrintRule r@(Rule fun _ _ _) = unless (isCoercion fun) $ concat+  [ [ "  case is_" ++ fnm ++ ":"     , "    if (_i_ > " ++ show p ++ ") renderC(_L_PAREN);"     ]-  , map (prPrintCat f) $ numVars cats+  , map ("    " ++) $ prPrintRule_ pre r   , [ "    if (_i_ > " ++ show p ++ ") renderC(_R_PAREN);"     , "    break;"     , ""     ]   ]   where-    f = funName fun-    p = precRule r-prPrintRule _ = []+    p   = precRule r+    fnm = funName fun+    pre = concat [ "p->u.", map toLower fnm, "_." ] +-- | Only render the rhs (items) of a rule.++prPrintRule_ :: IsFun a => String -> Rul a -> [String]+prPrintRule_ pre (Rule _ _ items _) = map (prPrintItem pre) $ numVars items+ -- | This goes on to recurse to the instance variables. -prPrintCat :: String -> Either (Cat, Doc) String -> String-prPrintCat fnm = \case-  Right t -> "    " ++ render (renderX t) ++ ";"+prPrintItem :: String -> Either (Cat, Doc) String -> String+prPrintItem pre = \case+  Right t -> render (renderX t) ++ ";"   Left (cat, nt) -> concat-    [ "    pp"+    [ "pp"     , maybe (identCat $ normCat cat) basicFunName $ maybeTokenCat cat-    , "(p->u."-    , map toLower fnm-    , "_.", render nt, ", ", show (precCat cat), ");"+    , "(", pre, render nt, ", ", show (precCat cat), ");"     ]  {- **** Abstract Syntax Tree Printer **** -}@@ -485,7 +496,7 @@    "  {",    concatMap prShowRule rules,    "  default:",-   "    fprintf(stderr, \"Error: bad kind field when showing " ++ show cat ++ "!\\n\");",+   "    fprintf(stderr, \"Error: bad kind field when showing " ++ catToStr cat ++ "!\\n\");",    "    exit(1);",    "  }",    "}\n"@@ -551,15 +562,14 @@ -- | An extremely simple @renderC@ for terminals.  prRender :: String-prRender = unlines-  [+prRender = unlines $ concat+  [ [       "/* You may wish to change the renderC functions */",       "void renderC(Char c)",       "{",       "  if (c == '{')",       "  {",-      "     bufAppendC('\\n');",-      "     indent();",+      "     onEmptyLine();",       "     bufAppendC(c);",       "     _n_ = _n_ + INDENT_WIDTH;",       "     bufAppendC('\\n');",@@ -569,30 +579,27 @@       "     bufAppendC(c);",       "  else if (c == ')' || c == ']')",       "  {",-      "     backup();",+      "     removeTrailingWhitespace();",       "     bufAppendC(c);",       "     bufAppendC(' ');",       "  }",       "  else if (c == '}')",       "  {",-      "     int t;",       "     _n_ = _n_ - INDENT_WIDTH;",-      "     for(t=0; t<INDENT_WIDTH; t++) {",-      "       backup();",-      "     }",+      "     onEmptyLine();",       "     bufAppendC(c);",       "     bufAppendC('\\n\');",       "     indent();",       "  }",       "  else if (c == ',')",       "  {",-      "     backup();",+      "     removeTrailingWhitespace();",       "     bufAppendC(c);",       "     bufAppendC(' ');",       "  }",       "  else if (c == ';')",       "  {",-      "     backup();",+      "     removeTrailingWhitespace();",       "     bufAppendC(c);",       "     bufAppendC('\\n');",       "     indent();",@@ -627,15 +634,38 @@       "    }",       "  }",       "}",+      "",       "void indent(void)",       "{",       "  int n = _n_;",       "  while (--n >= 0)",       "    bufAppendC(' ');",       "}",+      "",       "void backup(void)",       "{",       "  if (cur_ && buf_[cur_ - 1] == ' ')",       "    buf_[--cur_] = 0;",-      "}"+      "}",+      ""+    ]+  , [ "void removeTrailingSpaces()"+    , "{"+    , "  while (cur_ && buf_[cur_ - 1] == ' ') --cur_;"+    , "  buf_[cur_] = 0;"+    , "}"+    , ""+    , "void removeTrailingWhitespace()"+    , "{"+    , "  while (cur_ && (buf_[cur_ - 1] == ' ' || buf_[cur_ - 1] == '\\n')) --cur_;"+    , "  buf_[cur_] = 0;"+    , "}"+    , ""+    , "void onEmptyLine()"+    , "{"+    , "  removeTrailingSpaces();"+    , "  if (cur_ && buf_[cur_ - 1 ] != '\\n') bufAppendC('\\n');"+    , "  indent();"+    , "}"+    ]   ]

@@ -165,32 +165,33 @@           member = map toLower ecl  -- | Visits all the instance variables of a category.--- >>> let ab = Cat "ab"--- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab] Parsable)---   case is_abc:---     /* Code for abc Goes Here */---     visitab(p->u.abc_.ab_1);---     visitab(p->u.abc_.ab_2);+-- >>> let ab = Cat "Ab"+-- >>> prPrintRule (Rule "Abc" undefined [Left ab, Left ab] Parsable)+--   case is_Abc:+--     /* Code for Abc Goes Here */+--     visitAb(p->u.abc_.ab_1);+--     visitAb(p->u.abc_.ab_2); --     break; -- <BLANKLINE>--- >>> let ab = TokenCat "ab"--- >>> prPrintRule (Rule "abc" undefined [Left ab] Parsable)---   case is_abc:---     /* Code for abc Goes Here */+-- >>> let ab = TokenCat "Ab"+-- >>> prPrintRule (Rule "Abc" undefined [Left ab] Parsable)+--   case is_Abc:+--     /* Code for Abc Goes Here */ --     visitAb(p->u.abc_.ab_); --     break; -- <BLANKLINE>--- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab] Parsable)---   case is_abc:---     /* Code for abc Goes Here */+-- >>> prPrintRule (Rule "Abc" undefined [Left ab, Left ab] Parsable)+--   case is_Abc:+--     /* Code for Abc Goes Here */ --     visitAb(p->u.abc_.ab_1); --     visitAb(p->u.abc_.ab_2); --     break; -- <BLANKLINE> prPrintRule :: Rule -> Doc prPrintRule (Rule f _c cats _)-  | isCoercion f   = ""-  | otherwise      = nest 2 $ vcat+  | isCoercion f    = empty+  | isDefinedRule f = empty+  | otherwise       = nest 2 $ vcat     [ text $ "case is_" ++ fun ++ ":"     , nest 2 (vcat         [ "/* Code for " <> text fun <> " Goes Here */"

@@ -1,4 +1,6 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}  {-@@ -15,6 +17,7 @@  module BNFC.Backend.C.CFtoFlexC   ( cf2flex+  , ParserMode(..), parserName, parserPackage, cParser, stlParser, parserHExt   , preludeForBuffer  -- C code defining a buffer for lexing string literals.   , cMacros           -- Lexer definitions.   , commentStates     -- Stream of names for lexer states for comments.@@ -23,55 +26,101 @@   , lexChars          -- Lexing rules for character literals.   ) where -import Prelude hiding ((<>))-import Data.Bifunctor (first)-import Data.List  (isInfixOf)-import Data.Maybe (fromMaybe)+import Prelude hiding                ( (<>) )+import Data.Bifunctor                ( first )+import Data.Char                     ( isAlphaNum, isAscii )+import Data.List                     ( isInfixOf )+import Data.Maybe                    ( fromMaybe, maybeToList ) import qualified Data.Map as Map+import System.FilePath               ( (<.>) )  import BNFC.CF+import BNFC.Backend.C.Common         ( posixC ) import BNFC.Backend.C.RegToFlex import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.CPP.STL.STLUtils ( nsDefine, nsString )+import BNFC.Options                  ( InPackage ) import BNFC.PrettyPrint-import BNFC.Utils (cstring, unless, when)+import BNFC.Utils                    ( cstring, symbolToName, unless, when, whenJust ) +data ParserMode+  = CParser Bool String    -- ^ @C@ (@False@) or @C++ no STL@ (@True@) mode, with @name@ to use as prefix.+  | CppParser InPackage String    -- ^ @C++@ mode, with optional package name++parserName :: ParserMode -> String+parserName = \case+  CParser   _ n -> n+  CppParser p n -> fromMaybe n p++parserPackage :: ParserMode -> InPackage+parserPackage = \case+  CParser   _ _ -> Nothing+  CppParser p _ -> p++cParser :: ParserMode -> Bool+cParser = \case+  CParser   b _ -> not b+  CppParser _ _ -> False++stlParser :: ParserMode -> Bool+stlParser = \case+  CParser   _ _ -> False+  CppParser _ _ -> True++parserHExt :: ParserMode -> String+parserHExt = \case+  CParser   b _ -> if b then "H" else "h"+  CppParser _ _ -> "H"+ -- | Entrypoint.-cf2flex :: String -> CF -> (String, SymMap) -- The environment is reused by the parser.-cf2flex name cf = (, env) $ unlines-    [ prelude stringLiterals name+cf2flex :: ParserMode -> CF -> (String, SymMap) -- The environment is reused by the parser.+cf2flex mode cf = (, env) $ unlines+    [ prelude stringLiterals mode     , cMacros cf-    , lexSymbols env0-    , restOfFlex cf env+    , lexSymbols env1+    , restOfFlex (parserPackage mode) cf env+    , footer -- mode     ]   where-    env  = Map.fromList env1-    env0 = makeSymEnv (cfgSymbols cf ++ reservedWords cf) [0 :: Int ..]-    env1 = map (first Keyword )env0 ++ makeSymEnv (map Tokentype $ tokenNames cf) [length env0 ..]-    makeSymEnv = zipWith $ \ s n -> (s, "_SYMB_" ++ show n)+    env  = Map.fromList env2+    env0 = makeSymEnv (cfgSymbols cf) [0 :: Int ..]+    env1 = env0 ++ makeKwEnv (reservedWords cf) [length env0 ..]+    env2 = map (first Keyword) env1 ++ map (\ x -> (Tokentype x, "T_" ++ x)) (tokenNames cf)+    makeSymEnv     = zipWith $ \ s n -> (s, '_' : fromMaybe ("SYMB_" ++ show n) (symbolToName s))+    makeKwEnv      = zipWith $ \ s n -> (s, "_KW_" ++ if all (\ c -> isAlphaNum c && isAscii c) s then s else show n)     stringLiterals = isUsedCat cf (TokenCat catString) -prelude :: Bool -> String -> String-prelude stringLiterals name = unlines $ concat+prelude :: Bool -> ParserMode -> String+prelude stringLiterals mode = unlines $ concat   [ [ "/* -*- c -*- This FLex file was machine-generated by the BNF converter */"+    , ""     -- noinput and nounput are most often unused     -- https://stackoverflow.com/questions/39075510/option-noinput-nounput-what-are-they-for     , "%option noyywrap noinput nounput"-    , "%top{"-    , "/* strdup was not in the ISO C standard before 6/2019 (C2x), but in POSIX 1003.1."-    , " * See: https://en.cppreference.com/w/c/experimental/dynamic/strdup"-    , " * Setting _POSIX_C_SOURCE to 200809L activates strdup in string.h."-    , " */"+    , "%option reentrant bison-bridge bison-locations"+    , ""+    ]+  , when stringLiterals+    [ "/* Additional data for the lexer: a buffer for lexing string literals. */"+    , "%option extra-type=\"Buffer\""+    , ""+    ]+  , maybeToList $ ("%option prefix=\"" ++) . (++ "\"" ) <$> parserPackage mode+  , when (cParser mode) $ concat     -- The following #define needs to be at the top before the automatic #include <stdlib.h>-    , "#define _POSIX_C_SOURCE 200809L"-    , "}"-    , "%{"-    , "#define yylval " ++ name ++ "lval"-    , "#define yylloc " ++ name ++ "lloc"-    , "#define init_lexer " ++ name ++ "_init_lexer"-    , "#include \"Parser.h\""+    [ [ "%top{" ]+    , posixC+    , [ "}" ]+    ]+  , [ "%{"+    , "#include \"" ++ ("Absyn" <.> h) ++ "\""+    , "#include \"" ++ ("Bison" <.> h) ++ "\""     , ""     ]-  , when stringLiterals $ preludeForBuffer "Buffer.h"+  , [ "#define initialize_lexer " ++ parserName mode ++ "_initialize_lexer"+    , ""+    ]+  , when stringLiterals $ preludeForBuffer $ "Buffer" <.> h     -- https://www.gnu.org/software/bison/manual/html_node/Token-Locations.html     -- Flex is responsible for keeping tracking of the yylloc for Bison.     -- Flex also doesn't do this automatically so we need this function@@ -90,11 +139,13 @@     , "      }"     , "  }"     , "}"-    , "#define YY_USER_ACTION update_loc(&yylloc, yytext);"+    , "#define YY_USER_ACTION update_loc(yylloc, yytext);"     , ""     , "%}"     ]   ]+  where+  h = parserHExt mode  -- | Part of the lexer prelude needed when string literals are to be lexed. --   Defines an interface to the Buffer.@@ -108,7 +159,7 @@     , "#define LITERAL_BUFFER_INITIAL_SIZE 1024"     , ""     , "/* The pointer to the literal buffer. */"-    , "static Buffer literal_buffer = NULL;"+    , "#define literal_buffer yyextra"     , ""     , "/* Initialize the literal buffer. */"     , "#define LITERAL_BUFFER_CREATE() literal_buffer = newBuffer(LITERAL_BUFFER_INITIAL_SIZE)"@@ -139,7 +190,7 @@   , "DIGIT [0-9]"   , "IDENT [a-zA-Z0-9'_]"   , unwords $ concat-      [ [ "%START YYINITIAL CHAR CHARESC CHAREND STRING ESCAPED" ]+      [ [ "%START CHAR CHARESC CHAREND STRING ESCAPED" ]       , take (numberOfBlockCommentForms cf) commentStates       ]   , ""@@ -150,56 +201,53 @@ lexSymbols ss = concatMap transSym ss   where     transSym (s,r) =-      "<YYINITIAL>\"" ++ s' ++ "\"      \t return " ++ r ++ ";\n"+      "<INITIAL>\"" ++ s' ++ "\"      \t return " ++ r ++ ";\n"         where          s' = escapeChars s -restOfFlex :: CF -> SymMap -> String-restOfFlex cf env = unlines $ concat-  [ [ render $ lexComments Nothing (comments cf)+restOfFlex :: InPackage -> CF -> SymMap -> String+restOfFlex inPackage cf env = unlines $ concat+  [ [ render $ lexComments $ comments cf     , ""     ]   , userDefTokens   , ifC catString  $ lexStrings "yylval" "_STRING_" "_ERROR_"   , ifC catChar    $ lexChars   "yylval" "_CHAR_"-  , ifC catDouble  [ "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)?      \t yylval._double = atof(yytext); return _DOUBLE_;" ]-  , ifC catInteger [ "<YYINITIAL>{DIGIT}+      \t yylval._int = atoi(yytext); return _INTEGER_;" ]-  , ifC catIdent   [ "<YYINITIAL>{LETTER}{IDENT}*      \t yylval._string = strdup(yytext); return _IDENT_;" ]-  , [ "<YYINITIAL>[ \\t\\r\\n\\f]      \t /* ignore white space. */;"-    , "<YYINITIAL>.      \t return _ERROR_;"+  , ifC catDouble  [ "<INITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)?      \t yylval->_double = atof(yytext); return _DOUBLE_;" ]+  , ifC catInteger [ "<INITIAL>{DIGIT}+      \t yylval->_int = atoi(yytext); return _INTEGER_;" ]+  , ifC catIdent   [ "<INITIAL>{LETTER}{IDENT}*      \t yylval->_string = strdup(yytext); return _IDENT_;" ]+  , [ "<INITIAL>[ \\t\\r\\n\\f]      \t /* ignore white space. */;"+    , "<INITIAL>.      \t return _ERROR_;"     , ""     , "%%  /* Initialization code. */"-    , ""     ]-  , footer   ]   where   ifC cat s = if isUsedCat cf (TokenCat cat) then s else []   userDefTokens =-    [ "<YYINITIAL>" ++ printRegFlex exp ++-       "    \t yylval._string = strdup(yytext); return " ++ sName name ++ ";"+    [ "<INITIAL>" ++ printRegFlex exp +++       "    \t yylval->_string = strdup(yytext); return " ++ sName name ++ ";"     | (name, exp) <- tokenPragmas cf     ]     where sName n = fromMaybe n $ Map.lookup (Tokentype n) env-  footer =-    [-     "void init_lexer(FILE *inp)",-     "{",-     "  yyrestart(inp);",-     "  yylloc.first_line   = 1;",-     "  yylloc.first_column = 1;",-     "  yylloc.last_line    = 1;",-     "  yylloc.last_column  = 1;",-     "  BEGIN YYINITIAL;",-     "}"++footer :: String+footer = unlines+    [ "yyscan_t initialize_lexer(FILE *inp)"+    , "{"+    , "  yyscan_t scanner;"+    , "  if (yylex_init_extra(NULL, &scanner)) return 0;"+    , "  if (inp) yyrestart(inp, scanner);"+    , "  return scanner;"+    , "}"     ]  -- | Lexing of strings, converting escaped characters. lexStrings :: String -> String -> String -> [String] lexStrings yylval stringToken errorToken =-    [ "<YYINITIAL>\"\\\"\"        \t LITERAL_BUFFER_CREATE(); BEGIN STRING;"+    [ "<INITIAL>\"\\\"\"        \t LITERAL_BUFFER_CREATE(); BEGIN STRING;"     , "<STRING>\\\\             \t BEGIN ESCAPED;"-    , "<STRING>\\\"             \t " ++ yylval ++ "._string = LITERAL_BUFFER_HARVEST(); BEGIN YYINITIAL; return " ++ stringToken ++ ";"+    , "<STRING>\\\"             \t " ++ yylval ++ "->_string = LITERAL_BUFFER_HARVEST(); BEGIN INITIAL; return " ++ stringToken ++ ";"     , "<STRING>.              \t LITERAL_BUFFER_APPEND_CHAR(yytext[0]);"     , "<ESCAPED>n             \t LITERAL_BUFFER_APPEND_CHAR('\\n'); BEGIN STRING;"     , "<ESCAPED>\\\"            \t LITERAL_BUFFER_APPEND_CHAR('\"');  BEGIN STRING;"@@ -212,13 +260,13 @@ -- | Lexing of characters, converting escaped characters. lexChars :: String -> String -> [String] lexChars yylval charToken =-    [ "<YYINITIAL>\"'\" \tBEGIN CHAR;"+    [ "<INITIAL>\"'\" \tBEGIN CHAR;"     , "<CHAR>\\\\      \t BEGIN CHARESC;"-    , "<CHAR>[^']      \t BEGIN CHAREND; " ++ yylval ++ "._char = yytext[0]; return " ++ charToken ++ ";"-    , "<CHARESC>n      \t BEGIN CHAREND; " ++ yylval ++ "._char = '\\n';     return " ++ charToken ++ ";"-    , "<CHARESC>t      \t BEGIN CHAREND; " ++ yylval ++ "._char = '\\t';     return " ++ charToken ++ ";"-    , "<CHARESC>.      \t BEGIN CHAREND; " ++ yylval ++ "._char = yytext[0]; return " ++ charToken ++ ";"-    , "<CHAREND>\"'\"      \t BEGIN YYINITIAL;"+    , "<CHAR>[^']      \t BEGIN CHAREND; " ++ yylval ++ "->_char = yytext[0]; return " ++ charToken ++ ";"+    , "<CHARESC>n      \t BEGIN CHAREND; " ++ yylval ++ "->_char = '\\n';     return " ++ charToken ++ ";"+    , "<CHARESC>t      \t BEGIN CHAREND; " ++ yylval ++ "->_char = '\\t';     return " ++ charToken ++ ";"+    , "<CHARESC>.      \t BEGIN CHAREND; " ++ yylval ++ "->_char = yytext[0]; return " ++ charToken ++ ";"+    , "<CHAREND>\"'\"      \t BEGIN INITIAL;"     ]  -- ---------------------------------------------------------------------------@@ -232,15 +280,15 @@ -- lexSingleComment or lexMultiComment on each comment delimiter or pair of -- delimiters. ----- >>> lexComments (Just "myns.") ([("{-","-}")],["--"])--- <YYINITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */--- <YYINITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */--- <COMMENT>"-}" BEGIN YYINITIAL;+-- >>> lexComments ([("{-","-}")],["--"])+-- <INITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */+-- <INITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */+-- <COMMENT>"-}" BEGIN INITIAL; -- <COMMENT>.    /* skip */; -- <COMMENT>[\n] /* skip */;-lexComments :: Maybe String -> ([(String, String)], [String]) -> Doc-lexComments _ (m,s) = vcat $ concat-  [ map    lexSingleComment s+lexComments :: ([(String, String)], [String]) -> Doc+lexComments (m,s) = vcat $ concat+  [ map lexSingleComment s   , zipWith lexMultiComment m commentStates   ] @@ -254,13 +302,13 @@ -- comment. -- -- >>> lexSingleComment "--"--- <YYINITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */+-- <INITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */ -- -- >>> lexSingleComment "\""--- <YYINITIAL>"\""[^\n]* /* skip */; /* BNFC: comment "\"" */+-- <INITIAL>"\""[^\n]* /* skip */; /* BNFC: comment "\"" */ lexSingleComment :: String -> Doc lexSingleComment c =-    "<YYINITIAL>" <> cstring c <> "[^\\n]*"+    "<INITIAL>" <> cstring c <> "[^\\n]*"     <+> "/* skip */;"     <+> unless (containsCCommentMarker c) ("/* BNFC: comment" <+> cstring c <+> "*/") @@ -276,22 +324,22 @@ -- with another.  However this seems rare. -- -- >>> lexMultiComment ("{-", "-}") "COMMENT"--- <YYINITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */--- <COMMENT>"-}" BEGIN YYINITIAL;+-- <INITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */+-- <COMMENT>"-}" BEGIN INITIAL; -- <COMMENT>.    /* skip */; -- <COMMENT>[\n] /* skip */; -- -- >>> lexMultiComment ("\"'", "'\"") "COMMENT"--- <YYINITIAL>"\"'" BEGIN COMMENT; /* BNFC: block comment "\"'" "'\"" */--- <COMMENT>"'\"" BEGIN YYINITIAL;+-- <INITIAL>"\"'" BEGIN COMMENT; /* BNFC: block comment "\"'" "'\"" */+-- <COMMENT>"'\"" BEGIN INITIAL; -- <COMMENT>.    /* skip */; -- <COMMENT>[\n] /* skip */; lexMultiComment :: (String, String) -> String -> Doc lexMultiComment (b,e) comment = vcat-    [ "<YYINITIAL>" <> cstring b <+> "BEGIN" <+> text comment <> ";"+    [ "<INITIAL>" <> cstring b <+> "BEGIN" <+> text comment <> ";"       <+> unless (containsCCommentMarker b || containsCCommentMarker e)           ("/* BNFC: block comment" <+> cstring b <+> cstring e <+> "*/")-    , commentTag <> cstring e <+> "BEGIN YYINITIAL;"+    , commentTag <> cstring e <+> "BEGIN INITIAL;"     , commentTag <> ".    /* skip */;"     , commentTag <> "[\\n] /* skip */;"     ]

@@ -0,0 +1,18 @@+-- | Common definitions for the modules of the C backend.++module BNFC.Backend.C.Common+  ( posixC+  ) where++import Prelude++-- | Switch C to language variant that has @strdup@.++posixC :: [String]+posixC =+  [ "/* strdup was not in the ISO C standard before 6/2019 (C2x), but in POSIX 1003.1."+  , " * See: https://en.cppreference.com/w/c/experimental/dynamic/strdup"+  , " * Setting _POSIX_C_SOURCE to 200809L activates strdup in string.h."+  , " */"+  , "#define _POSIX_C_SOURCE 200809L"+  ]

@@ -0,0 +1,76 @@+{-# LANGUAGE LambdaCase #-}++-- | Common to the C++ backends.++module BNFC.Backend.CPP.Common where++import Data.Char  ( isUpper )+import Data.List  ( nub, intercalate )++import BNFC.CF+import BNFC.TypeChecker++import BNFC.Backend.CPP.Naming++-- | C++ code for the @define@d constructors.+--+-- @definedRules Nothing@ only prints the header.+definedRules :: Maybe ListConstructors -> CF -> String -> String+definedRules mlc cf banner+  | null theLines = []+  | otherwise     = unlines $ banner : "" : theLines+  where+    theLines = map rule $ definitions cf++    ctx = buildContext cf++    list = LC+      { nil  =  const ("[]", dummyType)+      , cons = \ t -> ("List" ++ unBase t, dummyType)+      }+      where+        unBase (ListT t) = unBase t+        unBase (BaseT x) = x++    rule (Define f args e t) =+      case mlc of+        Nothing -> header ++ ";"+        Just lc -> unlines+          [ header ++ " {"+          , "  return " ++ cppExp lc (map fst args) e ++ ";"+          , "}"+          ]+      where+        header = cppType t ++ " " ++ sanitizeCpp (funName f) ++ "(" +++                  intercalate ", " (map cppArg args) ++ ")"++        cppType :: Base -> String+        cppType (ListT (BaseT x)) = "List" ++ x ++ "*"+        cppType (ListT t)         = cppType t ++ "*"+        cppType (BaseT x)+            | x `elem` baseTokenCatNames = x+            | isToken x ctx = "String"+            | otherwise     = x ++ "*"++        cppArg :: (String, Base) -> String+        cppArg (x,t) = cppType t ++ " " ++ x ++ "_"++        cppExp :: ListConstructors -> [String] -> Exp -> String+        cppExp (LC nil cons) args = loop+          where+          loop = \case+            App "[]"  (FunT [] (ListT t)) [] -> fst $ nil t+            App "(:)" (FunT _  (ListT t)) es -> call (fst $ cons t) es+            Var x          -> x ++ "_"  -- argument+            App t _ [e]+              | isToken t ctx    -> loop e+            App x _ es+              | isUpper (head x) -> call ("new " ++ x) es+              | x `elem` args    -> call (x ++ "_") es+              | otherwise        -> call (sanitizeCpp x) es+            LitInt n       -> show n+            LitDouble x    -> show x+            LitChar c      -> show c+            LitString s    -> show s++          call x es = x ++ "(" ++ intercalate ", " (map loop es) ++ ")"

@@ -3,16 +3,16 @@ import BNFC.Backend.Common.Makefile import BNFC.PrettyPrint -makefile :: String -> String -> Doc-makefile name basename = vcat+makefile :: String -> String -> String -> Doc+makefile prefix name basename = vcat     [ mkVar "CC" "g++ -g"     , mkVar "CCFLAGS" "--ansi -W -Wall -Wno-unused-parameter -Wno-unused-function -Wno-unneeded-internal-declaration"     , ""     , mkVar "FLEX" "flex"-    , mkVar "FLEX_OPTS" ("-P" ++ name)+    , mkVar "FLEX_OPTS" ("-P" ++ prefix)     , ""     , mkVar "BISON" "bison"-    , mkVar "BISON_OPTS" ("-t -p" ++ name)+    , mkVar "BISON_OPTS" ("-t -p" ++ prefix)     , ""     , mkVar "OBJS" "Absyn.o Buffer.o Lexer.o Parser.o Printer.o"     , ""@@ -29,7 +29,7 @@             [ "Absyn.C", "Absyn.H"             , "Buffer.C", "Buffer.H"             , "Test.C"-            , "Parser.C", "Parser.H", "ParserError.H", name ++ ".y"+            , "Bison.H", "Parser.C", "Parser.H", "ParserError.H", name ++ ".y"             , "Lexer.C", name ++ ".l"             , "Skeleton.C", "Skeleton.H"             , "Printer.C", "Printer.H"@@ -45,12 +45,12 @@     , mkRule "Buffer.o" [ "Buffer.C", "Buffer.H" ]         [ "${CC} ${CCFLAGS} -c Buffer.C " ]     , mkRule "Lexer.C" [ name ++ ".l" ]-        [ "${FLEX} -oLexer.C " ++ name ++ ".l" ]-    , mkRule "Parser.C" [ name ++ ".y" ]-      [ "${BISON} " ++ name ++ ".y -o Parser.C" ]-    , mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ]+        [ "${FLEX} ${FLEX_OPTS} -oLexer.C " ++ name ++ ".l" ]+    , mkRule "Parser.C Bison.H" [ name ++ ".y" ]+      [ "${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.C" ]+    , mkRule "Lexer.o" [ "Lexer.C", "Bison.H" ]         [ "${CC} ${CCFLAGS} -c Lexer.C " ]-    , mkRule "Parser.o" [ "Parser.C", "Absyn.H" ]+    , mkRule "Parser.o" [ "Parser.C", "Absyn.H", "Bison.H" ]         [ "${CC} ${CCFLAGS} -c Parser.C" ]     , mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ]         [ "${CC} ${CCFLAGS} -c Printer.C" ]

@@ -19,3 +19,9 @@  mkVariable :: String -> String mkVariable = mkName cppReservedWords SnakeCase++sanitizeC :: String -> String+sanitizeC = mkName cReservedWords OrigCase++sanitizeCpp :: String -> String+sanitizeCpp = mkName cppReservedWords OrigCase

@@ -15,11 +15,10 @@ import BNFC.Options import BNFC.Backend.Base import BNFC.Backend.C            (bufferH, bufferC)-import BNFC.Backend.C.CFtoBisonC (unionBuiltinTokens)+import BNFC.Backend.C.CFtoBisonC (cf2Bison)+import BNFC.Backend.C.CFtoFlexC  (cf2flex, ParserMode(..)) import BNFC.Backend.CPP.Makefile import BNFC.Backend.CPP.NoSTL.CFtoCPPAbs-import BNFC.Backend.CPP.NoSTL.CFtoFlex-import BNFC.Backend.CPP.NoSTL.CFtoBison import BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL import BNFC.Backend.CPP.PrettyPrinter import qualified BNFC.Backend.Common.Makefile as Makefile@@ -31,9 +30,9 @@     mkfile "Absyn.C" cfile     mkfile "Buffer.H" bufferH     mkfile "Buffer.C" $ bufferC "Buffer.H"-    let (flex, env) = cf2flex Nothing name cf+    let (flex, env) = cf2flex parserMode cf     mkfile (name ++ ".l") flex-    let bison = cf2Bison name cf env+    let bison = cf2Bison(linenumbers opts) parserMode cf env     mkfile (name ++ ".y") bison     let header = mkHeaderFile cf (allParserCats cf) (toList $ allEntryPoints cf) (Map.elems env)     mkfile "Parser.H" header@@ -44,9 +43,17 @@     mkfile "Printer.H" prinH     mkfile "Printer.C" prinC     mkfile "Test.C" (cpptest cf)-    Makefile.mkMakefile opts $ makefile name-  where name = lang opts-+    Makefile.mkMakefile opts $ makefile prefix name+  where+    name :: String+    name = lang opts+    -- The prefix is a string used by flex and bison+    -- that is prepended to generated function names.+    -- It should be a valid C identifier.+    prefix :: String+    prefix = snakeCase_ name ++ "_"+    parserMode :: ParserMode+    parserMode = CParser True prefix  cpptest :: CF -> String cpptest cf =@@ -113,6 +120,7 @@     "      PrintAbsyn *p = new PrintAbsyn();",     "      printf(\"%s\\n\\n\", p->print(parse_tree));",     "    }",+    "    delete(parse_tree);",     "    return 0;",     "  }",     "  return 1;",@@ -128,18 +136,7 @@   [ [ "#ifndef PARSER_HEADER_FILE"     , "#define PARSER_HEADER_FILE"     , ""-    ]-  , map mkForwardDec $ nub $ map normCat cats-  , [ "typedef union"-    , "{"-    ]-  , map ("  " ++) unionBuiltinTokens-  , concatMap mkVar cats-  , [ "} YYSTYPE;"-    , ""-    , "#define _ERROR_ 258"-    , mkDefines (259 :: Int) env-    , "extern YYSTYPE yylval;"+    , "#include \"Absyn.H\""     , ""     ]   , map mkFunc eps@@ -148,24 +145,4 @@     ]   ]   where-  mkForwardDec s = "class " ++ identCat s ++ ";"-  mkVar s | normCat s == s = [ "  " ++ identCat s ++"*" +++ map toLower (identCat s) ++ "_;" ]-  mkVar _ = []-  mkDefines n [] = mkString n-  mkDefines n (s:ss) = "#define " ++ s +++ show n ++ "\n" ++ mkDefines (n+1) ss-  mkString n =  if isUsedCat cf (TokenCat catString)-   then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)-   else mkChar n-  mkChar n =  if isUsedCat cf (TokenCat catChar)-   then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)-   else mkInteger n-  mkInteger n =  if isUsedCat cf (TokenCat catInteger)-   then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)-   else mkDouble n-  mkDouble n =  if isUsedCat cf (TokenCat catDouble)-   then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)-   else mkIdent n-  mkIdent n =  if isUsedCat cf (TokenCat catIdent)-   then "#define _IDENT_ " ++ show n ++ "\n"-   else ""   mkFunc s = identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);"

@@ -1,226 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{--    BNF Converter: Bison generator-    Copyright (C) 2004  Author:  Michael Pellauer--    Description   : This module generates the Bison input file.-                    Note that because of the way bison stores results-                    the programmer can increase performance by limiting-                    the number of entry points in their grammar.--    Author        : Michael Pellauer-    Created       : 6 August, 2003--}--module BNFC.Backend.CPP.NoSTL.CFtoBison (cf2Bison) where--import Data.Char  ( toLower )-import Data.Foldable ( toList )-import Data.List  ( intersperse, nub )-import Data.Maybe ( fromMaybe )-import qualified Data.Map as Map--import BNFC.CF-import BNFC.Backend.Common.NamedVariables hiding (varName)-import BNFC.Backend.C.CFtoBisonC-  ( resultName, specialToks, startSymbol, typeName, varName )-import BNFC.Backend.CPP.STL.CFtoBisonSTL ( tokens, union, definedRules )-import BNFC.PrettyPrint-import BNFC.Utils ( (+++) )----This follows the basic structure of CFtoHappy.---- Type declarations-type Rules       = [(NonTerminal,[(Pattern,Action)])]-type Pattern     = String-type Action      = String-type MetaVar     = String----The environment comes from the CFtoFlex-cf2Bison :: String -> CF -> SymMap -> String-cf2Bison name cf env- = unlines-    [header name cf,-     render $ union Nothing (allParserCats cf),-     "%token _ERROR_",-     tokens user env,-     declarations cf,-     startSymbol cf,-     specialToks cf,-     "%%",-     prRules (rulesForBison name cf env)-    ]-  where-   user = fst (unzip (tokenPragmas cf))--header :: String -> CF -> String-header name cf = unlines-    [ "/* This Bison file was machine-generated by BNFC */"-    , "%{"-    , "#include <stdlib.h>"-    , "#include <stdio.h>"-    , "#include <string.h>"-    , "#include \"Absyn.H\""-    , ""-    , "#define YYMAXDEPTH 10000000"  -- default maximum stack size is 10000, but right-recursion needs O(n) stack-    , ""-    , "int yyparse(void);"-    , "int yylex(void);"-    , "int yy_mylinenumber;"  --- hack to get line number. AR 2006-    , "void initialize_lexer(FILE * inp);"-    , "int yywrap(void)"-    , "{"-    , "  return 1;"-    , "}"-    , "void yyerror(const char *str)"-    , "{"-    , "  extern char *yytext;"-    , "  fprintf(stderr,\"error: line %d: %s at %s\\n\", "-    , "    yy_mylinenumber + 1, str, yytext);"-    , "}"-    , ""-    , definedRules cf-    , concatMap reverseList $ filter isList $ allParserCatsNorm cf-    , unlines $ map parseResult dats-    , unlines $ map (parseMethod cf name) eps-    , "%}"-    ]-  where-  eps  = toList $ allEntryPoints cf-  dats = nub $ map normCat eps------ | Generates declaration and initialization of the @YY_RESULT@ for a parser.------   Different parsers (for different precedences of the same category)---   share such a declaration.------   Expects a normalized category.-parseResult :: Cat -> String-parseResult cat =-  "static " ++ cat' ++ "*" +++ resultName cat' +++ "= 0;"-  where-  cat' = identCat cat-----This generates a parser method for each entry point.-parseMethod :: CF -> String -> Cat -> String-parseMethod cf _ cat = unlines-  [-   dat ++"* p" ++ par ++ "(FILE *inp)",-   "{",-   "  initialize_lexer(inp);",-   "  if (yyparse())",-   "  { /* Failure */",-   "    return 0;",-   "  }",-   "  else",-   "  { /* Success */",-   "    return" +++ res ++ ";",-   "  }",-   "}"-  ]- where-  dat  = identCat (normCat cat)-  par  = identCat cat-  res0   = resultName dat-  revRes = "reverse" ++ dat ++ "(" ++ res0 ++ ")"-  res    = if cat `elem` cfgReversibleCats cf then revRes else res0----This method generates list reversal functions for each list type.-reverseList :: Cat -> String-reverseList c = unlines- [-  c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)",-  "{",-  "  " ++ c' +++"*prev = 0;",-  "  " ++ c' +++"*tmp = 0;",-  "  while (l)",-  "  {",-  "    tmp = l->" ++ v ++ ";",-  "    l->" ++ v +++ "= prev;",-  "    prev = l;",-  "    l = tmp;",-  "  }",-  "  return prev;",-  "}"- ]- where-  c' = identCat (normCat c)-  v = (map toLower c') ++ "_"----declares non-terminal types.-declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (allParserCats cf)- where --don't define internal rules-   typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n"-   typeNT _ _ = ""----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForBison :: String -> CF -> SymMap -> Rules-rulesForBison _ cf env = map mkOne $ ruleGroups cf where-  mkOne (cat,rules) = constructRule cf env rules cat---- For every non-terminal, we construct a set of rules.-constructRule :: CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) |-     r0 <- rules,-     let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs-                   then (True,revSepListRule r0)-                 else (False,r0),-     let (p,m) = generatePatterns cf env r])- where-   ruleName r = case funName $ funRule r of-     "(:)" -> identCat (normCat nt)-     "(:[])" -> identCat (normCat nt)-     z -> z-   revs = cfgReversibleCats cf-   eps = allEntryPoints cf-   isEntry nt = if elem nt eps then True else False-   result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""---- Generates a string containing the semantic action.-generateAction :: Fun -> Bool -> [MetaVar] -> Action-generateAction f b ms =-  if isCoercion f-  then (unwords ms) ++ ";"-  else if f == "[]"-  then "0;"-  else if isDefinedRule f-  then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ]-  else concat ["new ", f, "(", (concat (intersperse ", " ms')), ");"]- where-  ms' = if b then reverse ms else ms---- Generate patterns and a set of metavariables indicating--- where in the pattern the non-terminal-generatePatterns :: CF -> SymMap -> Rule -> (Pattern,[MetaVar])-generatePatterns cf env r = case rhsRule r of-  []  -> ("/* empty */",[])-  its -> (unwords (map mkIt its), metas its)- where-   mkIt i = case i of-     Left (TokenCat s) -> fromMaybe (typeName s) $ Map.lookup (Tokentype s) env-     Left  c -> identCat c-     Right s -> fromMaybe s $ Map.lookup (Keyword s) env-   metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]-   revIf c m = if (not (isConsFun (funRule r)) && elem c revs)-                 then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")-               else m  -- no reversal in the left-recursive Cons rule itself-   revs = cfgReversibleCats cf---- We have now constructed the patterns and actions,--- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules [] = []-prRules ((_, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) =-  (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where-  nt' = identCat nt-  pr []           = []-  pr ((p,a):ls)   = (unlines [(concat $ intersperse " " ["  |", p, "{ $$ =", a , "}"])]) ++ pr ls

@@ -1,4 +1,6 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  {-     BNF Converter: C++ abstract syntax generator@@ -18,13 +20,17 @@  import Prelude hiding ((<>)) +import Data.List  ( findIndices, intersperse )+import Data.Char  ( toLower )+import Text.PrettyPrint+ import BNFC.CF-import BNFC.Utils((+++),(++++))+import BNFC.TypeChecker ( ListConstructors(..) )+import BNFC.Utils       ( (+++), (++++) )+ import BNFC.Backend.Common.NamedVariables import BNFC.Backend.Common.OOAbstract-import Data.List-import Data.Char(toLower)-import Text.PrettyPrint+import BNFC.Backend.CPP.Common   --The result is two files (.H file, .C file)@@ -52,6 +58,9 @@   "/********************   Abstract Syntax Classes    ********************/\n",   concatMap (prDataH user) (getAbstractSyntax cf),   "",+  definedRules Nothing cf+  "/********************   Defined Constructors    ********************/",+  "",   "#endif"  ]  where@@ -67,7 +76,7 @@ --Prints interface classes for all categories. prDataH :: [UserDef] -> Data -> String prDataH  user (cat, rules) =-    case lookup (show cat) rules of+    case lookup (catToStr cat) rules of         Just _ -> concatMap (prRuleH user cat) rules         Nothing -> if isList cat             then concatMap (prRuleH user cat) rules@@ -125,7 +134,7 @@      c' = identCat (normCat c);      mem = drop 4 c'      memstar = if isBasic user mem then "" else "*"-     super = if show c == fun then "Visitable" else identCat c+     super = if catToStr c == fun then "Visitable" else identCat c      prConstructorH :: Int -> [(String, b)] -> String      prConstructorH _ [] = ""      prConstructorH n [(t,_)] = t +++ optstar t ++ "p" ++ show n@@ -218,10 +227,14 @@ mkCFile cf = unlines  [   header,-  concatMap (prDataC user) (getAbstractSyntax cf)+  concatMap (prDataC user) (getAbstractSyntax cf),+  definedRules (Just $ LC nil cons) cf+  "/********************   Defined Constructors    ********************/"  ]  where-  user = fst (unzip (tokenPragmas cf))+  nil _  = (,dummyType) $ "NULL"+  cons t = (,dummyType) $ "new List" ++ identType t+  user   = map fst (tokenPragmas cf)   header = unlines    [     "//C++ Abstract Syntax Implementation generated by the BNF Converter.",

@@ -1,204 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TupleSections #-}--{--    BNF Converter: Flex generator-    Copyright (C) 2004  Author:  Michael Pellauer-    Copyright (C) 2020  Andreas Abel--    Description   : This module generates the Flex file. It is-                    similar to JLex but with a few peculiarities.--    Author        : Michael Pellauer-    Created       : 5 August, 2003-    Modified      : 22 August, 2006 by Aarne Ranta--}--module BNFC.Backend.CPP.NoSTL.CFtoFlex (cf2flex) where--import Prelude hiding ((<>))-import Data.Bifunctor (first)-import Data.Maybe (fromMaybe)-import qualified Data.Map as Map--import BNFC.CF-import BNFC.Backend.C.CFtoFlexC (preludeForBuffer, cMacros, commentStates, lexChars, lexStrings)-import BNFC.Backend.C.RegToFlex-import BNFC.Backend.Common.NamedVariables-import BNFC.Backend.CPP.STL.STLUtils-import BNFC.PrettyPrint-import BNFC.Utils (cstring, when)----The environment must be returned for the parser to use.-cf2flex :: Maybe String -> String -> CF -> (String, SymMap)-cf2flex inPackage _name cf = (, env) $ unlines-    [ prelude stringLiterals inPackage-    , cMacros cf-    , lexSymbols env0-    , restOfFlex inPackage cf env-    ]-  where-    env  = Map.fromList env1-    env0 = makeSymEnv (cfgSymbols cf ++ reservedWords cf) [0 :: Int ..]-    env1 = map (first Keyword) env0 ++ makeSymEnv (map Tokentype $ tokenNames cf) [length env0 ..]-    makeSymEnv = zipWith $ \ s n -> (s, "_SYMB_" ++ show n)-    stringLiterals = isUsedCat cf (TokenCat catString)--prelude :: Bool -> Maybe String -> String-prelude stringLiterals inPackage = unlines $ concat-  [ [ "/* This FLex file was machine-generated by the BNF converter */" ]-  , maybe [] (\ ns -> [ "%option prefix=\"" ++ ns ++ "yy\"" ]) inPackage-  , [ "%{"-    , "#include <string.h>"-    , "#include \"Parser.H\""-    , "extern int " ++ nsString inPackage ++ "yy_mylinenumber ;" --- hack to get line number. AR 2006-    , ""-    ]-  , when stringLiterals $ preludeForBuffer "Buffer.H"-  , [ "%}" ]-  ]--lexSymbols :: SymEnv -> String-lexSymbols ss = concatMap transSym ss-  where-    transSym (s,r) =-      "<YYINITIAL>\"" ++ s' ++ "\"      \t return " ++ r ++ ";\n"-        where-         s' = escapeChars s--restOfFlex :: Maybe String -> CF -> SymMap -> String-restOfFlex inPackage cf env = unlines $ concat-  [ [ render $ lexComments inPackage (comments cf)-    , ""-    ]-  , userDefTokens-  , ifC catString  $ lexStrings (ns ++ "yylval") (nsDefine inPackage "_STRING_") (nsDefine inPackage "_ERROR_")-  , ifC catChar    $ lexChars   (ns ++ "yylval") (nsDefine inPackage "_CHAR_")-  , ifC catDouble  [ "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)?      \t " ++ ns ++ "yylval._double = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";" ]-  , ifC catInteger [ "<YYINITIAL>{DIGIT}+      \t " ++ ns ++ "yylval._int = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";" ]-  , ifC catIdent   [ "<YYINITIAL>{LETTER}{IDENT}*      \t " ++ ns ++ "yylval._string = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";" ]-  , [ "\\n  ++" ++ ns ++ "yy_mylinenumber ;"-    , "<YYINITIAL>[ \\t\\r\\n\\f]      \t /* ignore white space. */;"-    , "<YYINITIAL>.      \t return " ++ nsDefine inPackage "_ERROR_" ++ ";"-    , "%%"-    ]-  , footer-  ]-  where-   ifC cat s = if isUsedCat cf (TokenCat cat) then s else []-   ns = nsString inPackage-   userDefTokens =-     [ "<YYINITIAL>" ++ printRegFlex exp ++-         "     \t " ++ ns ++ "yylval._string = strdup(yytext); return " ++ sName name ++ ";"-     | (name, exp) <- tokenPragmas cf-     ]-     where sName n = fromMaybe n $ Map.lookup (Tokentype n) env-   footer =-     [ "void " ++ ns ++ "initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }"-     , "int yywrap(void) { return 1; }"-     ]----- ------------------------------------------------------------------------------ Comments---- | Create flex rules for single-line and multi-lines comments.--- The first argument is an optional namespace (for C++); the second--- argument is the set of comment delimiters as returned by BNFC.CF.comments.------ This function is only compiling the results of applying either--- lexSingleComment or lexMultiComment on each comment delimiter or pair of--- delimiters.------ >>> lexComments (Just "myns.") ([("{-","-}")],["--"])--- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}";--- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>.    /* skip */;--- <COMMENT>[\n] ++myns.yy_mylinenumber;-lexComments :: Maybe String -> ([(String, String)], [String]) -> Doc-lexComments ns (m,s) = vcat $ concat-  [ map    (lexSingleComment ns) s-  , zipWith (lexMultiComment ns) m commentStates-  ]---- | Create a lexer rule for single-line comments.--- The first argument is -- an optional c++ namespace--- The second argument is the delimiter that marks the beginning of the--- comment.------ >>> lexSingleComment (Just "mypackage.") "--"--- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";------ >>> lexSingleComment Nothing "--"--- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";------ >>> lexSingleComment Nothing "\""--- <YYINITIAL>"\""[^\n]* ; // BNFC: comment "\"";-lexSingleComment :: Maybe String -> String -> Doc-lexSingleComment _ c =-    "<YYINITIAL>" <> cstring c <> "[^\\n]*"-    <+> ";"-    <+> "// BNFC: comment" <+> cstring c <> ";"---- -- | Create a lexer rule for single-line comments.--- -- The first argument is -- an optional c++ namespace--- -- The second argument is the delimiter that marks the beginning of the--- -- comment.--- ----- -- >>> lexSingleComment (Just "mypackage.") "--"--- -- <YYINITIAL>"--"[^\n]*\n ++mypackage.yy_mylinenumber; // BNFC: comment "--";--- ----- -- >>> lexSingleComment Nothing "--"--- -- <YYINITIAL>"--"[^\n]*\n ++yy_mylinenumber; // BNFC: comment "--";--- ----- -- >>> lexSingleComment Nothing "\""--- -- <YYINITIAL>"\""[^\n]*\n ++yy_mylinenumber; // BNFC: comment "\"";--- lexSingleComment :: Maybe String -> String -> Doc--- lexSingleComment ns c =---     "<YYINITIAL>" <> cstring c <> "[^\\n]*\\n"---     <+> "++"<> text (fromMaybe "" ns)<>"yy_mylinenumber;"---     <+> "// BNFC: comment" <+> cstring c <> ";"---- | Create a lexer rule for multi-lines comments.--- The first argument is -- an optional c++ namespace--- The second arguments is the pair of delimiter for the multi-lines comment:--- start deleminiter and end delimiter.--- There might be a possible bug here if a language includes 2 multi-line--- comments. They could possibly start a comment with one character and end it--- with another.  However this seems rare.------ >>> lexMultiComment Nothing ("{-", "-}") "COMMENT"--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}";--- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>.    /* skip */;--- <COMMENT>[\n] ++yy_mylinenumber;------ >>> lexMultiComment (Just "foo.") ("{-", "-}") "COMMENT"--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}";--- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>.    /* skip */;--- <COMMENT>[\n] ++foo.yy_mylinenumber;------ >>> lexMultiComment Nothing ("\"'", "'\"") "COMMENT"--- <YYINITIAL>"\"'" BEGIN COMMENT; // BNFC: block comment "\"'" "'\"";--- <COMMENT>"'\"" BEGIN YYINITIAL;--- <COMMENT>.    /* skip */;--- <COMMENT>[\n] ++yy_mylinenumber;-lexMultiComment :: Maybe String -> (String, String) -> String -> Doc-lexMultiComment ns (b,e) comment = vcat-    [ "<YYINITIAL>" <> cstring b <+> "BEGIN" <+> text comment <> ";"-        <+> "// BNFC: block comment" <+> cstring b <+> cstring e <> ";"-    , commentTag <> cstring e <+> "BEGIN YYINITIAL;"-    , commentTag <> ".    /* skip */;"-    , commentTag <> "[\\n] ++" <> text (fromMaybe "" ns) <> "yy_mylinenumber;"-    ]-  where-  commentTag = text $ "<" ++ comment ++ ">"---- | Helper function that escapes characters in strings.-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)

@@ -23,10 +23,12 @@  import Prelude hiding ((<>)) -import Data.Char(toLower)+import Data.Bifunctor (second)+import Data.Char  (toLower)+import Data.Maybe (isJust)  import BNFC.CF-import BNFC.Utils ((+++), when)+import BNFC.Utils import BNFC.Backend.Common import BNFC.Backend.Common.NamedVariables import BNFC.Backend.Common.StrUtils (renderCharOrString)@@ -89,13 +91,16 @@     "  void render(const char *s);",     "  void indent(void);",     "  void backup(void);",+    "  void onEmptyLine(void);",+    "  void removeTrailingSpaces(void);",+    "  void removeTrailingWhitespace(void);",     " public:",     "  PrintAbsyn(void);",     "  ~PrintAbsyn(void);",     "  char *print(Visitable *v);"    ]   hdef = nsDefine inPackage "PRINTER_HEADER"-  content = concatMap prDataH groups+  content = concatMap (prDataH useStl) groups   classFooter = unlines $    [     "  void visitInteger(Integer i);",@@ -189,14 +194,18 @@    ]  --Prints all the required method names and their parameters.-prDataH :: (Cat, [Rule]) -> String-prDataH (cat, rules) =- if isList cat- then concat ["  void visit", cl, "(", cl, " *p);\n"]- else abstract ++ concatMap prRuleH rules+prDataH :: Bool -> (Cat, [Rule]) -> String+prDataH useSTL (cat, rules)+ | isList cat = unlines $ concat+     [ [ concat [ "  void visit", cl, "(", cl, " *p);"          ] ]+     , when useSTL+       [ concat [ "  void iter", cl, "(", itty, " i, ", itty, " j);" ] ]+     ]+ | otherwise  = abstract ++ concatMap prRuleH rules  where-   cl = identCat (normCat cat)-   abstract = case lookupRule (noPosition $ show cat) rules of+   cl       = identCat (normCat cat)+   itty     = concat [ cl, "::", "const_iterator" ]+   abstract = case lookupRule (noPosition $ catToStr cat) rules of     Just _ -> ""     Nothing ->  "  void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" @@ -394,140 +403,151 @@     abstract ++ concatMap (prPrintRule inPackage) rules   where   cl = identCat (normCat cat)-  abstract = case lookupRule (noPosition $ show cat) rules of+  abstract = case lookupRule (noPosition $ catToStr cat) rules of     Just _ -> ""     Nothing ->  "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl +++ "*p) {} //abstract class\n\n" --- | Generate pretty printer visitor for a list category:------ >>> let c = Cat "C" ; lc = ListCat c--- >>> let rules = [npRule "[]" lc [] Parsable, npRule "(:)" lc [Left c, Right "-", Left lc] Parsable]--- >>> genPrintVisitorList (lc, rules)--- void PrintAbsyn::visitListC(ListC *listc)--- {---   for (ListC::const_iterator i = listc->begin() ; i != listc->end() ; ++i)---   {---     (*i)->accept(this);---     render('-');---   }--- }+-- | Generate pretty printer visitor for a list category (STL version). ----- >>> let c2 = CoercCat "C" 2 ; lc2 = ListCat c2--- >>> let rules2 = rules ++ [npRule "[]" lc2 [] Parsable, npRule "(:)" lc2 [Left c2, Right "+", Left lc2] Parsable]--- >>> genPrintVisitorList (lc, rules2)--- void PrintAbsyn::visitListC(ListC *listc)--- {---   for (ListC::const_iterator i = listc->begin() ; i != listc->end() ; ++i)---   {---     (*i)->accept(this);---     switch(_i_)---     {---       case 2: render('+'); break;---       default: render('-');---     }---   }--- } genPrintVisitorList :: (Cat, [Rule]) -> Doc-genPrintVisitorList (cat@(ListCat c), rules) =-    "void PrintAbsyn::visit" <> text cl <> "(" <> text cl <> " *" <> vname <> ")"-    $$ codeblock 2-      [ "for ("<> text cl <> "::const_iterator i = " <> vname <> "->begin() ; i != " <> vname <> "->end() ; ++i)"-      , codeblock 2-          [ if isTokenCat c-              then "visit" <> text (baseName cl) <> "(*i) ;"-              else "(*i)->accept(this);"-          , (if hasOneFunc rules-              then "if (i != " <> vname <> "->end() - 1)"-              else empty)-            <+> renderListSepByPrecedence "_i_" renderSep separators-          ]+genPrintVisitorList (cat@(ListCat c), rules) = vcat+  [ "void PrintAbsyn::visit" <> lty <> parens (lty <+> "*" <> vname)+  , codeblock 2+    [ "iter" <> lty <> parens (vname <> "->begin()" <> comma <+> vname <> "->end()") <> semi ]+  , ""+  , "void PrintAbsyn::iter" <> lty <> parens (itty <+> "i" <> comma <+> itty <+> "j")+  , codeblock 2 $ concat+    [ if null docs0 then+      [ "if (i == j) return;" ]+      else+      [ "if (i == j)"+      , "{ /* nil */"+      , nest 2 $ vcat docs0+      , "}"+      , "else"       ]+    , unless (null docs1)+      [ "if (i == j-1)"+      , "{ /* last */"+      , nest 2 $ vcat docs1+      , "}"+      , "else"+      ]+    , [ "{ /* cons */"+      ,  nest 2 $ vcat docs2+      , "}"+      ]+    ]+  , ""+  , ""+  ]   where-   separators  = getSeparatorByPrecedence rules-   cl          = identCat (normCat cat)-   vname       = text $ map toLower cl-   renderSep s = "render(" <> text (snd (renderCharOrString s)) <> ")"+  cl        = identCat (normCat cat)+  lty       = text cl                   -- List type+  itty      = lty <> "::const_iterator" -- Iterator type+  vname     = text $ map toLower cl+  prules    = sortRulesByPrecedence rules+  swRules f = switchByPrecedence "_i_" $+                map (second $ sep . prListRule_) $+                  uniqOn fst $ filter f prules+                  -- Discard duplicates, can only handle one rule per precedence.+  docs0     = swRules isNilFun+  docs1     = swRules isOneFun+  docs2     = swRules isConsFun  genPrintVisitorList _ = error "genPrintVisitorList expects a ListCat" --- | This is the only part of the pretty printer that differs significantly+-- | Only render the rhs (items) of a list rule.++prListRule_ :: IsFun a => Rul a -> [Doc]+prListRule_ (Rule _ _ items _) = for items $ \case+  Right t       -> "render(" <> text (snd (renderCharOrString t)) <> ");"+  Left c+    | Just t <- maybeTokenCat c+                -> "visit" <> dat <> "(*i);"+    | isList c  -> "iter" <> dat <> "(i+1, j);"+    | otherwise -> "(*i)->accept(this);"+    where+    dat = text $ identCat $ normCat c++-- This is the only part of the pretty printer that differs significantly -- between the versions with and without STL.+-- The present version has been adapted from CFtoCPrinter. genPrintVisitorListNoStl :: (Cat, [Rule]) -> String genPrintVisitorListNoStl (cat@(ListCat c), rules) = unlines $ concat   [ [ "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")"     , "{"-    , "  while(" ++ vname +++ "!= 0)"-    , "  {"-    , "    if (" ++ vname ++ "->" ++ vname ++ "_ == 0)"-    , "    {"-    , visitMember-    ]-  , optsep-  , [ "      " ++ vname +++ "= 0;"-    , "    }"-    , "    else"-    , "    {"-    , visitMember-    , render $ nest 6 $ renderListSepByPrecedence "_i_" renderSep separators-    , "      " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;"-    , "    }"-    , "  }"-    , "}"-    , ""+      , "  if (" ++ vname +++ "== 0)"+      , "  { /* nil */"+      ]+    , unlessNull (swRules isNilFun) $ \ docs ->+      [ render $ nest 4 $ vcat docs ]+    , [ "  }" ]+    , unlessNull (swRules isOneFun) $ \ docs ->+      [ "  else if (" ++ pre ++ vname ++ "_ == 0)"+      , "  { /* last */"+      , render $ nest 4 $ vcat docs+      , "  }"+      ]+    , unlessNull (swRules isConsFun) $ \ docs ->+      [ "  else"+      , "  { /* cons */"+      , render $ nest 4 $ vcat docs+      , "  }"+      ]+    , [ "}"+      , ""+      ]     ]-  ]   where-    visitMember-      | Just t <- maybeTokenCat c =-          "      visit" ++ t ++ "(" ++ vname ++ "->" ++ member ++ ");"-      | otherwise =-          "      " ++ vname ++ "->" ++ member ++ "->accept(this);"-    cl     = identCat (normCat cat)-    ecl    = identCat (normCatOfList cat)-    vname  = map toLower cl-    member = map toLower ecl ++ "_"-    optsep = if hasOneFunc rules || null sep' then []-             else [ "      render(" ++ sep' ++ ");" ]-    sep' = snd $ renderCharOrString $ getCons rules-    renderSep s = "render(" <> text (snd $ renderCharOrString s) <> ")"-    separators = getSeparatorByPrecedence rules+  cl          = identCat (normCat cat)+  vname       = map toLower cl+  pre         = vname ++ "->"+  prules      = sortRulesByPrecedence rules+  swRules f   = switchByPrecedence "_i_" $+                  map (second $ sep . map text . prPrintRule_ pre) $+                    uniqOn fst $ filter f prules+                    -- Discard duplicates, can only handle one rule per precedence. genPrintVisitorListNoStl _ = error "genPrintVisitorListNoStl expects a ListCat"  --Pretty Printer methods for a rule. prPrintRule :: Maybe String -> Rule -> String-prPrintRule inPackage r@(Rule fun _ cats _) | isProperLabel fun = unlines-  [-   "void PrintAbsyn::visit" ++ funName fun ++ "(" ++ funName fun +++ "*" ++ fnm ++ ")",-   "{",-   "  int oldi = _i_;",-   lparen,-   cats',-   rparen,-   "  _i_ = oldi;",-   "}",-   ""+prPrintRule inPackage r@(Rule fun _ items _) | isProperLabel fun = unlines $ concat+  [ [ "void PrintAbsyn::visit" ++ funName fun ++ "(" ++ funName fun +++ "*" ++ fnm ++ ")"+    , "{"+    , "  int oldi = _i_;"+    , parenCode "_L_PAREN"+    , ""+    ]+  , prPrintRule_ (fnm ++ "->") r+  , [ ""+    , parenCode "_R_PAREN"+    , "  _i_ = oldi;"+    , "}"+    , ""+    ]   ]-   where-    p = precRule r-    (lparen, rparen) =-      ("  if (oldi > " ++ show p ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n",-       "  if (oldi > " ++ show p ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n")-    cats' = concatMap (prPrintCat fnm) (numVars cats)-    fnm = "p" --old names could cause conflicts+  where+  p = precRule r+  parenCode x = "  if (oldi > " ++ show p ++ ") render(" ++ nsDefine inPackage x ++ ");"+  fnm = "p" --old names could cause conflicts prPrintRule _ _ = "" +prPrintRule_ :: IsFun a => String -> Rul a -> [String]+prPrintRule_ pre (Rule _ _ items _) = map (prPrintItem pre) $ numVars items+ --This goes on to recurse to the instance variables.-prPrintCat :: String -> Either (Cat, Doc) String -> String-prPrintCat _ (Right t) = "  render(" ++ t' ++ ");\n"-  where t' = snd (renderCharOrString t)-prPrintCat fnm (Left (c, nt))+prPrintItem :: String -> Either (Cat, Doc) String -> String+prPrintItem _   (Right t) = "  render(" ++ snd (renderCharOrString t) ++ ");"+prPrintItem pre (Left (c, nt))   | Just t <- maybeTokenCat c-              = "  visit" ++ t ++ "(" ++ fnm ++ "->" ++ s ++ ");\n"-  | isList c  = "  if(" ++ fnm ++ "->" ++ s ++ ") {" ++ accept ++ "}\n"-  | otherwise = "  " ++ accept ++ "\n"+              = "  visit" ++ t   ++ "(" ++ pre ++ s ++ ");"+  | isList c  = "  " ++ setI (precCat c) +++                  "visit" ++ elt ++ "(" ++ pre ++ s ++ ");"+  | otherwise = "  " ++ setI (precCat c) ++ pre ++ s ++ "->accept(this);"   where-    s = render nt-    accept = setI (precCat c) ++ fnm ++ "->" ++ s ++ "->accept(this);"+  s   = render nt+  elt = identCat $ normCat c  {- **** Abstract Syntax Tree Printer **** -} @@ -587,7 +607,7 @@   abstract ++ concatMap prShowRule rules   where     cl = identCat (normCat cat)-    abstract = case lookupRule (noPosition $ show cat) rules of+    abstract = case lookupRule (noPosition $ catToStr cat) rules of       Just _ -> ""       Nothing ->  "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ " *p) {} //abstract class\n\n" @@ -660,8 +680,7 @@       "{",       "  if (c == '{')",       "  {",-      "     bufAppend('\\n');",-      "     indent();",+      "     onEmptyLine();",       "     bufAppend(c);",       "     _n_ = _n_ + INDENT_WIDTH;",       "     bufAppend('\\n');",@@ -671,30 +690,27 @@       "     bufAppend(c);",       "  else if (c == ')' || c == ']')",       "  {",-      "     backup();",+      "     removeTrailingWhitespace();",       "     bufAppend(c);",       "     bufAppend(' ');",       "  }",       "  else if (c == '}')",       "  {",-      "     int t;",       "     _n_ = _n_ - INDENT_WIDTH;",-      "     for (t=0; t<INDENT_WIDTH; t++) {",-      "       backup();",-      "     }",+      "     onEmptyLine();",       "     bufAppend(c);",       "     bufAppend('\\n\');",       "     indent();",       "  }",       "  else if (c == ',')",       "  {",-      "     backup();",+      "     removeTrailingWhitespace();",       "     bufAppend(c);",       "     bufAppend(' ');",       "  }",       "  else if (c == ';')",       "  {",-      "     backup();",+      "     removeTrailingWhitespace();",       "     bufAppend(c);",       "     bufAppend('\\n');",       "     indent();",@@ -750,8 +766,27 @@     , ""     , "void PrintAbsyn::backup()"     , "{"-    , "  if (buf_[cur_ - 1] == ' ')"+    , "  if (cur_ && buf_[cur_ - 1] == ' ')"     , "    buf_[--cur_] = 0;"+    , "}"+    , ""+    , "void PrintAbsyn::removeTrailingSpaces()"+    , "{"+    , "  while (cur_ && buf_[cur_ - 1] == ' ') --cur_;"+    , "  buf_[cur_] = 0;"+    , "}"+    , ""+    , "void PrintAbsyn::removeTrailingWhitespace()"+    , "{"+    , "  while (cur_ && (buf_[cur_ - 1] == ' ' || buf_[cur_ - 1] == '\\n')) --cur_;"+    , "  buf_[cur_] = 0;"+    , "}"+    , ""+    , "void PrintAbsyn::onEmptyLine()"+    , "{"+    , "  removeTrailingSpaces();"+    , "  if (cur_ && buf_[cur_ - 1 ] != '\\n') bufAppend('\\n');"+    , "  indent();"     , "}"     , ""     ]

@@ -19,11 +19,10 @@ import BNFC.Options import BNFC.Backend.Base import BNFC.Backend.C            (bufferH, bufferC)-import BNFC.Backend.C.CFtoBisonC (unionBuiltinTokens)+import BNFC.Backend.C.CFtoBisonC (cf2Bison)+import BNFC.Backend.C.CFtoFlexC  (cf2flex, ParserMode(..)) import BNFC.Backend.CPP.Makefile import BNFC.Backend.CPP.STL.CFtoSTLAbs-import BNFC.Backend.CPP.NoSTL.CFtoFlex-import BNFC.Backend.CPP.STL.CFtoBisonSTL import BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL import BNFC.Backend.CPP.PrettyPrinter import BNFC.Backend.CPP.STL.STLUtils@@ -36,9 +35,9 @@     mkfile "Absyn.C" cfile     mkfile "Buffer.H" bufferH     mkfile "Buffer.C" $ bufferC "Buffer.H"-    let (flex, env) = cf2flex (inPackage opts) name cf+    let (flex, env) = cf2flex parserMode cf     mkfile (name ++ ".l") flex-    let bison = cf2Bison (linenumbers opts) (inPackage opts) name cf env+    let bison = cf2Bison (linenumbers opts) parserMode cf env     mkfile (name ++ ".y") bison     let header = mkHeaderFile (inPackage opts) cf (allParserCats cf) (toList $ allEntryPoints cf) (Map.elems env)     mkfile "Parser.H" header@@ -50,8 +49,17 @@     mkfile "Printer.H" prinH     mkfile "Printer.C" prinC     mkfile "Test.C" (cpptest (inPackage opts) cf)-    Makefile.mkMakefile opts $ makefile name-  where name = lang opts+    Makefile.mkMakefile opts $ makefile prefix name+  where+    name :: String+    name = lang opts+    -- The prefix is a string used by flex and bison+    -- that is prepended to generated function names.+    -- It should be a valid C identifier.+    prefix :: String+    prefix = snakeCase_ name ++ "_"+    parserMode :: ParserMode+    parserMode = CppParser (inPackage opts) prefix  printParseErrHeader :: Maybe String -> String printParseErrHeader inPackage =@@ -149,6 +157,7 @@     "      " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();",     "      printf(\"%s\\n\\n\", p->print(parse_tree));",     "    }",+    "    delete(parse_tree);",     "    return 0;",     "  }",     "  return 1;",@@ -167,50 +176,18 @@     , ""     , "#include<vector>"     , "#include<string>"+    , "#include \"Absyn.H\""     , ""     , nsStart inPackage     ]-  , map mkForwardDec $ List.nub $ map normCat cats-  , [ "typedef union"-    , "{"-    ]-  , map ("  " ++) unionBuiltinTokens-  , concatMap mkVar cats-  , [ "} YYSTYPE;"-    , ""-    ]   , concatMap mkFuncs eps   , [ nsEnd inPackage     , ""-    , "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258"-    , mkDefines (259 :: Int) env-    , "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;"-    , ""     , "#endif"     ]   ]   where   hdef = nsDefine inPackage "PARSER_HEADER_FILE"-  mkForwardDec s = "class " ++ identCat s ++ ";"-  mkVar s | normCat s == s = [ "  " ++ identCat s ++"*" +++ map toLower (identCat s) ++ "_;" ]-  mkVar _ = []-  mkDefines n [] = mkString n-  mkDefines n (s:ss) = "#define " ++ s +++ show n ++ "\n" ++ mkDefines (n+1) ss -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv)-  mkString n =  if isUsedCat cf (TokenCat catString)-   then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)-   else mkChar n-  mkChar n =  if isUsedCat cf (TokenCat catChar)-   then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)-   else mkInteger n-  mkInteger n =  if isUsedCat cf (TokenCat catInteger)-   then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)-   else mkDouble n-  mkDouble n =  if isUsedCat cf (TokenCat catDouble)-   then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)-   else mkIdent n-  mkIdent n =  if isUsedCat cf (TokenCat catIdent)-   then "#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n"-   else ""   mkFuncs s =     [ identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);"     , identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(const char *str);"

@@ -1,378 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--{--    BNF Converter: C++ Bison generator-    Copyright (C) 2004  Author:  Michael Pellauer--    Description   : This module generates the Bison input file using-                    STL. The main difference to CFtoBison is in handling-                    lists: by using std::vector and push_back, our rules-                    for reverting lists are the opposite to linked lists.-                    Note that because of the way bison stores results-                    the programmer can increase performance by limiting-                    the number of entry points in their grammar.--    Author        : Michael Pellauer-    Created       : 6 August, 2003-    Modified      : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se)---}--module BNFC.Backend.CPP.STL.CFtoBisonSTL-  ( cf2Bison-  , tokens, union-  , definedRules-  ) where--import Prelude hiding ((<>))--import Data.Char  ( isUpper )-import Data.Foldable (toList)-import Data.List  ( nub, intercalate )-import Data.Maybe ( fromMaybe )-import qualified Data.Map as Map--import BNFC.Backend.C.CFtoBisonC-  ( resultName, specialToks, startSymbol, typeName, unionBuiltinTokens, varName )-import BNFC.Backend.CPP.STL.STLUtils-import BNFC.Backend.Common.NamedVariables hiding (varName)-import BNFC.CF-import BNFC.Options (RecordPositions(..))-import BNFC.PrettyPrint-import BNFC.TypeChecker-import BNFC.Utils ((+++), when)----This follows the basic structure of CFtoHappy.---- Type declarations-type Rules       = [(NonTerminal,[(Pattern,Action)])]-type Pattern     = String-type Action      = String-type MetaVar     = String----The environment comes from the CFtoFlex-cf2Bison :: RecordPositions -> Maybe String -> String -> CF -> SymMap -> String-cf2Bison rp inPackage name cf env- = unlines-    [header inPackage name cf,-     render $ union inPackage (map TokenCat (positionCats cf) ++ allParserCats cf),-     maybe "" (\ns -> "%define api.prefix {" ++ ns ++ "yy}") inPackage,-     "%token _ERROR_",-     tokens user env,-     declarations cf,-     startSymbol cf,-     specialToks cf,-     "%%",-     prRules (rulesForBison rp inPackage cf env)-    ]-  where-   user = fst (unzip (tokenPragmas cf))---positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))--header :: Maybe String -> String -> CF -> String-header inPackage name cf = unlines-    [ "/* This Bison file was machine-generated by BNFC */"-    , "%{"-    , "#include <stdlib.h>"-    , "#include <stdio.h>"-    , "#include <string.h>"-    , "#include <algorithm>"-    , "#include \"ParserError.H\""-    , "#include \"Absyn.H\""-    , ""-    , "#define YYMAXDEPTH 10000000"  -- default maximum stack size is 10000, but right-recursion needs O(n) stack-    , ""-    , "typedef struct yy_buffer_state *YY_BUFFER_STATE;"-    , "int yyparse(void);"-    , "int yylex(void);"-    , "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);"-    , "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);"-    , "int " ++ ns ++ "yy_mylinenumber;"  --- hack to get line number. AR 2006-    , "void " ++ ns ++ "initialize_lexer(FILE * inp);"-    , "int " ++ ns ++ "yywrap(void)"-    , "{"-    , "  return 1;"-    , "}"-    , "void " ++ ns ++ "yyerror(const char *str)"-    , "{"-    , "  throw "++ns++"::parse_error("++ ns ++ "yy_mylinenumber,str);"-    , "}"-    , ""-    , nsStart inPackage-    , definedRules cf-    , unlines $ map parseResult dats-    , unlines $ map (parseMethod cf inPackage name) eps-    , nsEnd inPackage-    , "%}"-    ]-  where-    ns   = nsString inPackage-    eps  = toList (allEntryPoints cf) ++ map TokenCat (positionCats cf)-    dats = nub $ map normCat eps--definedRules :: CF -> String-definedRules cf =-    unlines [ rule f xs e | FunDef f xs e <- cfgPragmas cf ]-  where-    ctx = buildContext cf--    list = LC (const "[]") (\ t -> "List" ++ unBase t)-      where-        unBase (ListT t) = unBase t-        unBase (BaseT x) = show $ normCat $ strToCat x--    rule f xs e =-        case runTypeChecker $ checkDefinition' list ctx f xs e of-        Left err -> error $ "Panic! This should have been caught already:\n" ++ err-        Right (args,(e',t)) -> unlines-            [ cppType t ++ " " ++ funName f ++ "_ (" ++-                intercalate ", " (map cppArg args) ++ ") {"-            , "  return " ++ cppExp e' ++ ";"-            , "}"-            ]-      where-        cppType :: Base -> String-        cppType (ListT (BaseT x)) = "List" ++ show (normCat $ strToCat x) ++ " *"-        cppType (ListT t)         = cppType t ++ " *"-        cppType (BaseT x)-            | x `elem` baseTokenCatNames = x-            | isToken x ctx = "String"-            | otherwise     = show (normCat $ strToCat x) ++ " *"--        cppArg :: (String, Base) -> String-        cppArg (x,t) = cppType t ++ " " ++ x ++ "_"--        cppExp :: Exp -> String-        cppExp (App "[]" [])    = "0"-        cppExp (Var x)          = x ++ "_"  -- argument-        cppExp (App t [e])-            | isToken t ctx     = cppExp e-        cppExp (App x es)-            | isUpper (head x)  = call ("new " ++ x) es-            | otherwise         = call (x ++ "_") es-        cppExp (LitInt n)       = show n-        cppExp (LitDouble x)    = show x-        cppExp (LitChar c)      = show c-        cppExp (LitString s)    = show s--        call x es = x ++ "(" ++ intercalate ", " (map cppExp es) ++ ")"----- | Generates declaration and initialization of the @YY_RESULT@ for a parser.------   Different parsers (for different precedences of the same category)---   share such a declaration.------   Expects a normalized category.-parseResult :: Cat -> String-parseResult cat =-  "static " ++ cat' ++ "*" +++ resultName cat' +++ "= 0;"-  where-  cat' = identCat cat----This generates a parser method for each entry point.-parseMethod :: CF -> Maybe String -> String -> Cat -> String-parseMethod cf inPackage _ cat = unlines $ concat-  [ [ cat' ++ "* p" ++ par ++ "(FILE *inp)"-    , "{"-    , "  " ++ ns ++ "yy_mylinenumber = 1;"-    , "  " ++ ns ++ "initialize_lexer(inp);"-    , "  if (yyparse())"-    , "  { /* Failure */"-    , "    return 0;"-    , "  }"-    , "  else"-    , "  { /* Success */"-    ]-  , revOpt-  , [ "    return" +++ res ++ ";"-    , "  }"-    , "}"-    , cat' ++ "* p" ++ par ++ "(const char *str)"-    , "{"-    , "  YY_BUFFER_STATE buf;"-    , "  int result;"-    , "  " ++ ns ++ "yy_mylinenumber = 1;"-    , "  " ++ ns ++ "initialize_lexer(0);"-    , "  buf = " ++ ns ++ "yy_scan_string(str);"-    , "  result = yyparse();"-    , "  " ++ ns ++ "yy_delete_buffer(buf);"-    , "  if (result)"-    , "  { /* Failure */"-    , "    return 0;"-    , "  }"-    , "  else"-    , "  { /* Success */"-    ]-  , revOpt-  , [ "    return" +++ res ++ ";"-    , "  }"-    , "}"-    ]-  ]-  where-  cat' = identCat (normCat cat)-  par  = identCat cat-  ns   = nsString inPackage-  res  = resultName cat'-  -- Vectors are snoc lists-  revOpt = when (isList cat && cat `notElem` cfgReversibleCats cf)-             [ "std::reverse(" ++ res ++ "->begin(), " ++ res ++"->end());" ]---- | The union declaration is special to Bison/Yacc and gives the type of--- yylval.  For efficiency, we may want to only include used categories here.------ >>> let foo = Cat "Foo"--- >>> union Nothing [foo, ListCat foo]--- %union--- {---   int    _int;---   char   _char;---   double _double;---   char*  _string;---   Foo* foo_;---   ListFoo* listfoo_;--- }------ If the given list of categories is contains coerced categories, those should--- be normalized and duplicate removed--- E.g. if there is both [Foo] and [Foo2] we should only print one pointer:---    ListFoo* listfoo_;------ >>> let foo2 = CoercCat "Foo" 2--- >>> union Nothing [foo, ListCat foo, foo2, ListCat foo2]--- %union--- {---   int    _int;---   char   _char;---   double _double;---   char*  _string;---   Foo* foo_;---   ListFoo* listfoo_;--- }-union :: Maybe String -> [Cat] -> Doc-union inPackage cats = vcat-    [ "%union"-    , codeblock 2 $ map text unionBuiltinTokens ++ map mkPointer normCats-    ]-  where-    normCats = nub (map normCat cats)-    mkPointer s = scope <> text (identCat s) <> "*" <+> text (varName s) <> ";"-    scope = text (nsScope inPackage)----declares non-terminal types.-declarations :: CF -> String-declarations cf = concatMap typeNT $-  map TokenCat (positionCats cf) ++-  filter (not . null . rulesForCat cf) (allParserCats cf) -- don't define internal rules-  where-  typeNT nt = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n"----declares terminal types.-tokens :: [UserDef] -> SymMap -> String-tokens user env = unlines $ map declTok $ Map.toList env-  where-  declTok (Keyword   s, r) = tok "" s r-  declTok (Tokentype s, r) = tok (if s `elem` user then "<_string>" else "") s r-  tok t s r = concat [ "%token", t, " ", r, "    //   ", s ]----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs--rulesForBison :: RecordPositions -> Maybe String -> CF -> SymMap -> Rules-rulesForBison rp inPackage cf env = map mkOne (ruleGroups cf) ++ posRules-  where-  mkOne (cat,rules) = constructRule rp inPackage cf env rules cat-  posRules = (`map` positionCats cf) $ \ n -> (TokenCat n,-    [( fromMaybe n $ Map.lookup (Tokentype n) env-     , concat-         [ "$$ = new ", nsScope inPackage, n, "($1, ", nsString inPackage, "yy_mylinenumber); "-         , nsScope inPackage, "YY_RESULT_", n, "_= $$;"-         ]-     )])---- For every non-terminal, we construct a set of rules.-constructRule ::-  RecordPositions -> Maybe String -> CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule rp inPackage cf env rules nt =-  (nt,[(p, generateAction rp inPackage nt (funName $ ruleName r) b m +++ result) |-     r0 <- rules,-     let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs-                   then (True,revSepListRule r0)-                 else (False,r0),-     let (p,m) = generatePatterns cf env r b])- where-   ruleName r = case funRule r of-     ---- "(:)" -> identCat nt-     ---- "(:[])" -> identCat nt-     z -> z-   revs = cfgReversibleCats cf-   eps = toList $ allEntryPoints cf-   isEntry nt = nt `elem` eps-   result = if isEntry nt then (nsScope inPackage ++ resultName (identCat (normCat nt))) ++ "= $$;" else ""---- Generates a string containing the semantic action.-generateAction :: RecordPositions -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action-generateAction rp inPackage cat f b mbs =-  reverses ++-  if isCoercion f-  then "$$ = " ++ unwords ms ++ ";"-  else if f == "[]"-  then concat ["$$ = ","new ", scope, identCatV cat, "();"]-  else if f == "(:[])"-  then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"]-  else if f == "(:)" && b-  then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;"-  else if f == "(:)"-  then lastms ++ "->push_back(" ++ head ms ++ ") ; $$ = " ++ lastms ++ " ;" ---- not left rec-  else if isDefinedRule f-  then concat ["$$ = ", scope, f, "_", "(", intercalate ", " ms, ");" ]-  else concat-    ["$$ = ", "new ", scope, f, "(", intercalate ", " ms, ");" ++ addLn rp]- where-  ms = map fst mbs-  lastms = last ms-  addLn rp = if rp == RecordPositions then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else ""  -- O.F.-  identCatV = identCat . normCat-  reverses = unwords [-    "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" |-       (m,True) <- mbs]-  scope = nsScope inPackage---- Generate patterns and a set of metavariables indicating--- where in the pattern the non-terminal-generatePatterns :: CF -> SymMap -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])-generatePatterns cf env r _ = case rhsRule r of-  []  -> ("/* empty */",[])-  its -> (unwords (map mkIt its), metas its)- where-   mkIt = \case-     Left (TokenCat s)-       | isPositionCat cf s -> typeName s-       | otherwise -> fromMaybe (typeName s) $ Map.lookup (Tokentype s) env-     Left c  -> identCat c-     Right s -> fromMaybe s $ Map.lookup (Keyword s) env-   metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]--   -- notice: reversibility with push_back vectors is the opposite-   -- of right-recursive lists!-   revert c = isList c && not (isConsFun (funRule r)) && notElem c revs-   revs = cfgReversibleCats cf---- We have now constructed the patterns and actions,--- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules [] = []-prRules ((_, []):rs) = prRules rs --internal rule-prRules ((nt, (p, a) : ls):rs) =-    unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls] ++ ";\n" ++ prRules rs- where-  nt' = identCat nt-  pr []           = []-  pr ((p,a):ls)   = unlines [unwords ["  |", p, "{ ", a , "}"]] ++ pr ls

@@ -1,3 +1,5 @@+{-# LANGUAGE TupleSections #-}+ {-     BNF Converter: C++ abstract syntax generator     Copyright (C) 2004  Author:  Michael Pellauer@@ -16,17 +18,21 @@  module BNFC.Backend.CPP.STL.CFtoSTLAbs (cf2CPPAbs) where +import Data.List        ( intercalate, intersperse )+ import BNFC.Backend.Common.OOAbstract import BNFC.CF-import BNFC.Options (RecordPositions(..))-import BNFC.Utils((+++))-import Data.List+import BNFC.Options     ( RecordPositions(..) )+import BNFC.TypeChecker ( ListConstructors(..) )+import BNFC.Utils       ( (+++), applyWhen )++import BNFC.Backend.CPP.Common import BNFC.Backend.CPP.STL.STLUtils  --The result is two files (.H file, .C file)  cf2CPPAbs :: RecordPositions -> Maybe String -> String -> CF -> (String, String)-cf2CPPAbs rp inPackage _ cf = (mkHFile rp inPackage cab, mkCFile inPackage cab)+cf2CPPAbs rp inPackage _ cf = (mkHFile rp inPackage cab cf, mkCFile inPackage cab cf)   where     cab = cf2cabs cf @@ -34,8 +40,8 @@ -- **** Header (.H) File Functions **** --  --Makes the Header file.-mkHFile :: RecordPositions -> Maybe String -> CAbs -> String-mkHFile rp inPackage cf = unlines+mkHFile :: RecordPositions -> Maybe String -> CAbs -> CF -> String+mkHFile rp inPackage cabs cf = unlines  [   "#ifndef " ++ hdef,   "#define " ++ hdef,@@ -49,29 +55,32 @@   "",   unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes],   "",-  unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf],+  unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cabs],   "",   "/********************   Forward Declarations    ********************/",   "",-  unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)],+  unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cabs)],   "",   "/********************   Visitor Interfaces    ********************/",-  prVisitor cf,+  prVisitor cabs,   "",   prVisitable,   "",   "/********************   Abstract Syntax Classes    ********************/",   "",-  unlines [prAbs rp c | c <- absclasses cf],+  unlines [prAbs rp c | c <- absclasses cabs],   "",-  unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs],+  unlines [prCon (c,r) | (c,rs) <- signatures cabs, r <- rs],   "",-  unlines [prList c | c <- listtypes cf],+  unlines [prList c | c <- listtypes cabs],+  "",+  definedRules Nothing cf+  "/********************   Defined Constructors    ********************/",   nsEnd inPackage,   "#endif"  ]  where-  classes = allClasses cf+  classes = allClasses cabs   hdef = nsDefine inPackage "ABSYN_HEADER"  -- auxiliaries@@ -133,34 +142,43 @@    conargs = concat $ intersperse ", "      [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]] -prList :: (String,Bool) -> String-prList (c,b) = unlines [-  "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">",-  "{",-  "public:",-  "  virtual void accept(Visitor *v);",-  "  virtual " ++ c ++ " *clone() const;",-  "};"+prList :: (String, Bool) -> String+prList (c, b) = unlines+  [ "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">"+  , "{"+  , "public:"+  , "  virtual void accept(Visitor *v);"+  , "  virtual " ++ c ++ " *clone() const;"+  , "};"+  , ""+    -- cons for this list type+  , concat [ c, "* ", "cons", c, "(", bas, " x, ", c, "* xs);" ]   ]- where-   bas = drop 4 c {- drop "List" -} ++ if b then "*" else ""+  where+  bas = applyWhen b (++ "*") $ drop 4 c {- drop "List" -}   -- **** Implementation (.C) File Functions **** -- -mkCFile :: Maybe String -> CAbs -> String-mkCFile inPackage cf = unlines $ [+mkCFile :: Maybe String -> CAbs -> CF -> String+mkCFile inPackage cabs cf = unlines $ [   "//C++ Abstract Syntax Implementation generated by the BNF Converter.",   "#include <algorithm>",   "#include <string>",   "#include <vector>",   "#include \"Absyn.H\"",   nsStart inPackage,-  unlines [prConC  r | (_,rs) <- signatures cf, r <- rs],-  unlines [prListC c | (c,_) <- listtypes cf],+  unlines [prConC  r | (_,rs) <- signatures cabs, r <- rs],+  unlines [prListC l | l <- listtypes cabs],+  definedRules (Just $ LC nil cons) cf+  "/********************   Defined Constructors    ********************/",   nsEnd inPackage   ]+  where+  nil  t = (,dummyType) $ concat [ "new List", identType t, "()" ]+  cons t = (,dummyType) $ concat [ "consList", identType t ] + prConC :: CAbsRule -> String prConC fcs@(f,_) = unlines [   "/********************   " ++ f ++ "    ********************/",@@ -172,14 +190,14 @@   ""  ] -prListC :: String -> String-prListC c = unlines [-  "/********************   " ++ c ++ "    ********************/",-  "",-  prAcceptC c,-  "",-  prCloneC c- ]+prListC :: (String,Bool) -> String+prListC (c,b) = unlines+  [ "/********************   " ++ c ++ "    ********************/"+  , ""+  , prAcceptC c+  , prCloneC c+  , prConsC c b+  ]   --The standard accept function for the Visitor pattern@@ -199,6 +217,17 @@   "  return new" +++ c ++ "(*this);",   "}"   ]++-- | Make a list constructor definition.+prConsC :: String -> Bool -> String+prConsC c b = unlines+  [ concat [ c, "* ", "cons", c, "(", bas, " x, ", c, "* xs) {" ]+  , "  xs->insert(xs->begin(), x);"+  , "  return xs;"+  , "}"+  ]+  where+  bas = applyWhen b (++ "*") $ drop 4 c {- drop "List" -}  --The constructor assigns the parameters to the corresponding instance variables. prConstructorC :: CAbsRule -> String

@@ -1,14 +1,23 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  -- | Functions common to different backends. -module BNFC.Backend.Common where+module BNFC.Backend.Common+  ( unicodeAndSymbols+  , asciiKeywords+  , flexEps+  , switchByPrecedence+  )+  where  import Prelude hiding ((<>)) +import Data.Bifunctor   ( second ) import Data.Char  import BNFC.CF+import BNFC.Utils       ( (>.>) ) import BNFC.PrettyPrint  -- Andreas, 2020-10-08, issue #292:@@ -40,16 +49,35 @@ -- switch(x) -- { --   case 3: my_render(";"); break;---   default: my_render("--");+--   case 1: my_render("--"); break; -- }-renderListSepByPrecedence :: Doc                 -- ^ Name of the coercion level variable-                         -> (String -> Doc)     -- ^ render function-                         -> [(Integer, String)] -- ^ separators by precedence-                         -> Doc-renderListSepByPrecedence _ _ [] = empty-renderListSepByPrecedence _ render [(_,sep)] = render sep <> ";"-renderListSepByPrecedence var render ss = "switch(" <> var <> ")" $$ codeblock 2-    ( ["case" <+> integer i <:> render sep <>"; break;" | (i, sep) <- init ss]-    ++ ["default" <:> render sep <>";" | let (_,sep) = last ss])-  where+renderListSepByPrecedence+  :: Doc                 -- ^ Name of the coercion level variable+  -> (String -> Doc)     -- ^ render function+  -> [(Integer, String)] -- ^ separators by precedence+  -> Doc+renderListSepByPrecedence var render =+  vcat . switchByPrecedence var . map (second $ render >.> (<> ";"))++-- Note (Andreas, 2021-05-02):+-- @renderListSepByPrecedence@ did not account for mixfix lists (issue #358)+-- and has been replaced by the more general @switchByPrecedence@.++switchByPrecedence+  :: Doc              -- ^ Name of the coercion level variable/+  -> [(Integer, Doc)] -- ^ Content by precedence.+  -> [Doc]+switchByPrecedence var = filter (not . isEmpty . snd) >.> \case+  []        -> []+  [(_,doc)] -> [ doc  ]+  ds        ->+    [ "switch(" <> var <> ")"+    , codeblock 2+      [ "case" <+> integer i <:> doc <+> "break;" | (i, doc) <- ds ]+    -- , codeblock 2 $ concat+    --   [ [ "case" <+> integer i <:> doc <+> "break;" |     (i, doc) <- init ds ]+    --   , [ "default" <:> doc                         | let (i, doc) =  last ds ]+    --   ]+    ]+    where     a <:> b = a <> ":" <+> b

@@ -132,15 +132,16 @@ --This fixes the problem with coercions. fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])] fixCoercions rs = nub (fixAll rs rs)- where+  where   fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule]   fixCoercion _ [] = []   fixCoercion cat ((c,rules):cats) = if normCat c == normCat cat     then rules ++ fixCoercion cat cats     else fixCoercion cat cats+   fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]   fixAll _ [] = []-  fixAll top ((cat,_):cats) = if isCoercion (noPosition $ show cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!+  fixAll top ((cat,_):cats) = if isCoercion (noPosition $ catToStr cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!     then fixAll top cats     else (normCat cat, fixCoercion cat top) : fixAll top cats @@ -148,7 +149,7 @@ varName c = map toLower c ++ "_"  --this makes var names a little cleaner.-showNum n = if n == 0 then [] else show n+showNum n = if n == 0 then "" else show n  -- Makes the first letter a lowercase. firstLowerCase :: String -> String

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ {-     BNF Converter: Datastructure for object-oriented abstract syntax generators     Copyright (C) 2006  Author:  Aarne Ranta@@ -15,9 +17,11 @@  module BNFC.Backend.Common.OOAbstract where +import Data.Char  (toLower)+import qualified Data.List as List+import Data.Maybe+ import BNFC.CF-import Data.List-import Data.Char(toLower)  -- A datastructure more appropriate than CF @@ -45,19 +49,19 @@   map fst basetypes ++ tokentypes ca  cf2cabs :: CF -> CAbs-cf2cabs cf = CAbs {-  tokentypes = toks,-  listtypes  = [(c, snd (status (drop 4 c))) | -- remove "List" from "ListC"-                  c <- map (identCat . normCat) lists],-  absclasses = nub $ map (show.normCat) cats,-  conclasses = [f | Just f <- map testRule (cfgRules cf)],-  signatures = posdata ++ map normSig (cf2data cf),-  postokens  = pos,-  defineds   = defs+cf2cabs cf = CAbs+  { tokentypes = toks+  , listtypes  = [(c, snd (status (drop 4 c))) | -- remove "List" from "ListC"+                  c <- map (identCat . normCat) lists]+  , absclasses = List.nub $ map (identCat . normCat) cats -- NB: does not include list categories+  , conclasses = mapMaybe testRule $ cfgRules cf+  , signatures = posdata ++ map normSig (cf2data cf)+  , postokens  = pos+  , defineds   = defs   }  where-  (pos,  toks) = partition (isPositionCat cf) $ map fst $ tokenPragmas cf-  (lists,cats) = partition isList $ allCatsNorm cf+  (pos,  toks) = List.partition (isPositionCat cf) $ map fst $ tokenPragmas cf+  (lists,cats) = List.partition isList $ allCatsNorm cf   testRule (Rule f c _ _)    | isList (wpThing c)  = Nothing    | funName f == "_"  = Nothing@@ -68,15 +72,15 @@     [("Visitable",  -- to give superclass      [(c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos]   status cat = (cat, notElem cat (map fst basetypes ++ toks))-  defs = [ funName f | FunDef f _ _ <- cfgPragmas cf]+  defs = [ funName f | FunDef (Define f _ _ _) <- cfgPragmas cf]    classVars :: [(String,Bool)] -> [(String,Bool,String)]   classVars cs =     [(c,b,s) | ((c,b),s) <- zip cs (vars [] (map (classVar . fst) cs))]   --- creating new names is quadratic, but parameter lists are short   --- this should conform with Michael's naming-  vars seen vv = case vv of-    []   -> vv+  vars seen = \case+    []   -> []     v:vs -> case length (filter (==v) seen) of       0 | elem v vs -> (v ++ "1"): vars (v:seen) vs       0             -> v         : vars (v:seen) vs

@@ -9,6 +9,7 @@ module BNFC.Backend.Haskell (makeHaskell, AlexVersion(..), makefile, testfile) where  import qualified Control.Monad as Ctrl+import Data.Maybe      (isJust) import System.FilePath ((<.>), (</>), pathSeparator) import Text.Printf     (printf) import Text.PrettyPrint@@ -58,7 +59,7 @@         liftIO $ printf "Use Alex 3 to compile %s.\n" (alexFile opts)      Ctrl.when (hasLayout cf) $ mkfile (layoutFile opts) $-      cf2Layout (tokenText opts) layMod lexMod cf+      cf2Layout layMod lexMod cf      -- Generate Happy parser and matching test program.     do@@ -84,7 +85,7 @@     Ctrl.when (agda opts) $ makeAgda time opts cf      -- Generate Makefile.-    Makefile.mkMakefile opts $ makefile opts+    Makefile.mkMakefile opts $ makefile opts cf   -- | Generate the makefile (old version, with just one "all" target).@@ -186,9 +187,10 @@ -- | Generate the makefile. makefile   :: Options+  -> CF   -> String    -- ^ Filename of the makefile.   -> Doc       -- ^ Content of the makefile.-makefile opts makeFile = vcat+makefile opts cf makeFile = vcat   [ makefileHeader opts   , phonyRule   , defaultRule@@ -234,11 +236,16 @@     where     recipe    = unwords [ "bnfc", printOptions opts{ make = Nothing } ]     tgts      = unwords . map ($ opts) . concat $-      [ [ absFile, alexFile, happyFile, printerFile, tFile ]+      [ [ absFile ]+      , [ layoutFile | lay ]+      , [ alexFile, happyFile, printerFile, tFile ]       , when (agda opts)         [ agdaASTFile, agdaParserFile, agdaLibFile, agdaMainFile ]       ] +  lay :: Bool+  lay = hasLayout cf+   -- | Rule to invoke @happy@.   happyRule :: Doc   happyRule = Makefile.mkRule "%.hs" [ "%.y" ] [ "${HAPPY} ${HAPPY_OPTS} $<" ]@@ -254,28 +261,33 @@     tgt :: String     tgt = tFileExe opts     deps :: [String]-    deps = map ($ opts)-      [ absFile-      , alexFileHs-      , happyFileHs-      , printerFile-      , tFile+    deps = map ($ opts) $ concat+      [ [ absFile ]+      , [ layoutFile | lay ]+      , [ alexFileHs+        , happyFileHs+        , printerFile+        , tFile+        ]       ]    -- | Rule to build Agda parser.   agdaRule :: Doc   agdaRule = Makefile.mkRule "Main" deps [ "agda --no-libraries --ghc --ghc-flag=-Wwarn $<" ]     where-    deps = map ($ opts)-      [ agdaMainFile  -- must be first!-      , agdaASTFile-      , agdaParserFile-      , agdaLibFile-      -- Haskell modules bound by Agda modules:-      , errFile-      , alexFileHs-      , happyFileHs-      , printerFile+    deps = map ($ opts) $ concat+      [ [ agdaMainFile  -- must be first!+        , agdaASTFile+        , agdaParserFile+        , agdaLibFile+        -- Haskell modules bound by Agda modules:+        , errFile+        ]+      , [ layoutFile | lay ]+      , [ alexFileHs+        , happyFileHs+        , printerFile+        ]       ]  testfile :: Options -> CF -> String@@ -285,18 +297,18 @@     , "module Main where"     , ""     , "import Prelude"-    , "  ( ($)"+    , "  ( ($), (.)"     ]   , [ "  , Bool(..)" | lay ]   , [ "  , Either(..)"     , "  , Int, (>)"-    , "  , String, (++), unlines"+    , "  , String, (++), concat, unlines"     , "  , Show, show"     , "  , IO, (>>), (>>=), mapM_, putStrLn"     , "  , FilePath"     ]   , [ "  , getContents, readFile" | tokenText opts == StringToken ]-  , [ "  , (.), error, flip, map, replicate, sequence_, zip" | use_glr ]+  , [ "  , error, flip, map, replicate, sequence_, zip" | use_glr ]   , [ "  )" ]   , case tokenText opts of       StringToken -> []@@ -316,7 +328,7 @@   , table "" $ concat     [ [ [ "import " , absFileM      opts , " (" ++ if_glr impTopCat ++ ")" ] ]     , [ [ "import " , layoutFileM   opts , " ( resolveLayout )"      ] | lay     ]-    , [ [ "import " , alexFileM     opts , " ( Token )"                          ]+    , [ [ "import " , alexFileM     opts , " ( Token, mkPosToken )"              ]       , [ "import " , happyFileM    opts , " ( " ++ impParser ++ ", myLexer" ++ impParGLR ++ " )" ]       , [ "import " , printerFileM  opts , " ( Print, printTree )"               ]       , [ "import " , templateFileM opts , " ()"                                 ]@@ -367,14 +379,14 @@     , ""     ]   , if_glr $-    [ "the_parser :: ParseFun " ++ show topType+    [ "the_parser :: ParseFun " ++ catToStr topType     , "the_parser = lift_parser " ++ render (parserName topType)     , ""     , liftParser     ]   ]   where-    lay         = hasLayout cf+    lay         = isJust hasTopLevelLayout || not (null layoutKeywords)     use_xml     = xml opts > 0     xpr         = if use_xml then "XPrint a, "     else ""     use_glr     = glr opts == GLR@@ -386,8 +398,10 @@     impTopCat   = unwords [ "", identCat topType, "" ]     impParGLR   = if_glr ", GLRResult(..), Branch, ForestId, TreeDecode(..), decode"     myLLexer atom-      | lay     = unwords [ "resolveLayout True $ myLexer", atom]+      | lay     = unwords [ "resolveLayout", show useTopLevelLayout, "$ myLexer", atom]       | True    = unwords [ "myLexer", atom]+    (hasTopLevelLayout, layoutKeywords, _) = layoutPragmas cf+    useTopLevelLayout = isJust hasTopLevelLayout   runStd xml myLLexer = unlines $ concat@@ -396,7 +410,8 @@    , "    Left err -> do"    , "      putStrLn \"\\nParse              Failed...\\n\""    , "      putStrV v \"Tokens:\""-   , "      putStrV v $ show ts"+   , "      mapM_ (putStrV v . showPosToken . mkPosToken) ts"+   -- , "      putStrV v $ show ts"    , "      putStrLn err"    , "      exitFailure"    , "    Right tree -> do"@@ -407,6 +422,7 @@  , [ "      exitSuccess"    , "  where"    , "  ts = " ++ myLLexer "s"+   , "  showPosToken ((l,c),t) = concat [ show l, \":\", show c, \"\\t\", show t ]"    ]  ] 

@@ -50,10 +50,10 @@         , [ "{-# LANGUAGE DeriveGeneric #-}"              | gen ]         , [ "{-# LANGUAGE DeriveTraversable #-}"          | fun ]         , [ "{-# LANGUAGE FlexibleInstances #-}"          | fun ]-        , [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | hasIdentLike ] -- for IsString+        , [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | hasIdentLikeNoPos ] -- for IsString         , [ "{-# LANGUAGE LambdaCase #-}"                 | fun ]         , [ "{-# LANGUAGE PatternSynonyms #-}"            | defPosition ]-        , [ "{-# LANGUAGE OverloadedStrings #-}"          | tokenText /= StringToken ]+        , [ "{-# LANGUAGE OverloadedStrings #-}"          | not (null definitions), tokenText /= StringToken ]         ]       ]     , [ "-- | The abstract syntax of language" <+> text lang <> "." ]@@ -66,11 +66,11 @@         , [ prettyList 2 "import qualified Prelude as C" "(" ")" "," $ qualifiedPreludeImports             | not $ null qualifiedPreludeImports ]         , [ "import qualified Data.String"-            | hasIdentLike ] -- for IsString+            | hasIdentLikeNoPos ] -- for IsString         ]       ]     , [ vcat . concat $-        [ map text $ tokenTextImport tokenText+        [ when hasTextualToks $ map text $ tokenTextImport tokenText         , [ "import qualified Data.Data    as C (Data, Typeable)" | gen ]         , [ "import qualified GHC.Generics as C (Generic)"        | gen ]         ]@@ -80,7 +80,7 @@     , map (prData functor (derivingClasses functor)) datas      -- Smart constructors-    , definedRules functor cf+    , definitions      -- Token definition types     , (`map` specialCats cf) $ \ c ->@@ -105,7 +105,7 @@       | defPosition       ] -    -- HasPosition class if either @fun@ or @hasIdentLikeTokens@+    -- HasPosition class     , [ vcat         [ "-- | Get the start position of something."         , ""@@ -122,15 +122,19 @@     , [ "" ] -- ensure final newline     ]   where+    definitions  = definedRules functor cf+     datas        = cf2data cf     positionCats = filter (isPositionCat cf) $ specialCats cf -    hasIdentLike = hasIdentLikeTokens cf+    hasIdentLikeNoPos = hasIdentLikeTokens cf+    hasTextualToks    = hasTextualTokens cf+    hasPosToks   = hasPositionTokens cf     hasData      = not (null datas)     -- @defPosition@: should the @BNCF'Position@ type be defined?-    defPosition  = hasPositionTokens cf || functor+    defPosition  = hasPosToks || functor     -- @hasPosition@: should the @HasPosition@ class be defined?-    hasPosition  = hasPositionTokens cf || fun+    hasPosition  = hasPosToks || fun     gen   = generic && hasData     fun   = functor && hasData @@ -148,11 +152,11 @@       ]     -- import Prelude (Char, Double, Integer, String)     typeImports =-      filter (\ s -> hasData      && s `elem` cfgLiterals cf-                  || hasIdentLike && tokenText == StringToken && s == "String")+      filter (\ s -> hasData        && s `elem` cfgLiterals cf+                  || hasTextualToks && tokenText == StringToken && s == "String")         baseTokenCatNames     qualifiedPreludeImports = concat-      [ [ text $ List.intercalate ", " stdClasses | hasIdentLike || hasData ]+      [ [ text $ List.intercalate ", " stdClasses | hasTextualToks || hasData ]       , [ text $ List.intercalate ", " funClasses | fun ]       , [ text $ "Int, Maybe(..)" | defPosition ]       ]@@ -194,7 +198,7 @@   ]   where     prRule (fun, cats) = hsep $ concat [ [text fun], ["a" | functor], map prArg cats ]-    unprimedType       = text (show cat)+    unprimedType       = pretty cat     primedType         = prime unprimedType     prime              = (<> "'")     dataType | functor = primedType <+> "a"@@ -291,24 +295,26 @@  -- | Generate Haskell code for the @define@d constructors. definedRules :: Bool -> CF -> [Doc]-definedRules functor cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]+definedRules functor cf = map mkDef $ definitions cf   where-  mkDef f xs e = vcat $ map text $ concat-    [ [ unwords [ fName, "::", typ $ wpThing t ]+  mkDef (Define f args e t) = vcat $ concat+    [ [ text $ unwords [ fName, "::", typ $ wpThing t ]       | t <- maybeToList $ sigLookup f cf       ]-    , [ unwords $ fName : xs' ++ [ "=", show $ sanitize e ] ]+    , [ hsep $ map text (fName : xs') ++ [ "=", pretty $ sanitize e ] ]     ]     where     fName = mkDefName f+    xs    = map fst args     avoidReserved = avoidReservedWords [fName]     xs' = addFunctorArg id $ map avoidReserved xs     typ (FunT ts t) | functor = List.intercalate " -> " $ "a" : (map funBase $ ts ++ [t])     typ t = typeToHaskell t     sanitize = \case-      App x es-        | tokTyp x  -> App x $ map sanitize es-        | otherwise -> App x $ addFunctorArg (`App` []) $ map sanitize es+      App x t es+        | isNilCons x -> App x t $ map sanitize es+        | tokTyp x    -> App x t $ map sanitize es+        | otherwise   -> App x t $ addFunctorArg (\ e -> App e dummyType []) $ map sanitize es       Var x         -> Var $ avoidReserved x       e@LitInt{}    -> e       e@LitDouble{} -> e

@@ -13,11 +13,12 @@  import BNFC.Abs import BNFC.CF-import BNFC.Lexing  (mkRegMultilineComment)-import BNFC.Options (TokenText(..))--- import BNFC.Utils   (unless)+import BNFC.Lexing         ( mkRegMultilineComment )+import BNFC.Options        ( TokenText(..) )+import BNFC.PrettyPrint+import BNFC.Utils          ( table, when, unless ) -import BNFC.Backend.Common (unicodeAndSymbols)+import BNFC.Backend.Common ( unicodeAndSymbols ) import BNFC.Backend.Haskell.Utils  cf2alex3 :: String -> TokenText -> CF -> String@@ -36,6 +37,9 @@     , "{"     , "{-# OPTIONS -fno-warn-incomplete-patterns #-}"     , "{-# OPTIONS_GHC -w #-}"+    , ""+    , "{-# LANGUAGE PatternSynonyms #-}"+    , ""     , "module " ++ name ++ " where"     , ""     , "import Prelude"@@ -43,16 +47,20 @@     ]   , tokenTextImport tokenText   , [ "import qualified Data.Bits"-    , "import Data.Word (Word8)"-    , "import Data.Char (ord)"+    , "import Data.Char     (ord)"+    , "import Data.Function (on)"+    , "import Data.Word     (Word8)"     , "}"-    , ""     ]   ] +-- | Character class definitions.+ cMacros :: [String] cMacros =-  [ "$c = [A-Z\\192-\\221] # [\\215]  -- capital isolatin1 letter (215 = \\times) FIXME"+  [ "-- Predefined character classes"+  , ""+  , "$c = [A-Z\\192-\\221] # [\\215]  -- capital isolatin1 letter (215 = \\times) FIXME"   , "$s = [a-z\\222-\\255] # [\\247]  -- small   isolatin1 letter (247 = \\div  ) FIXME"   , "$l = [$c $s]         -- letter"   , "$d = [0-9]           -- digit"@@ -60,269 +68,344 @@   , "$u = [. \\n]          -- universal: any character"   ] +-- | Regular expressions and lex actions.+ rMacros :: CF -> [String]-rMacros cf = if null symbs then [] else-  [ "@rsyms =    -- symbols and non-identifier-like reserved words"-  , "   " ++ List.intercalate " | " (map mkEsc symbs)+rMacros cf = unless (null symbs)+  [ "-- Symbols and non-identifier-like reserved words"+  , ""+  , "@rsyms = " ++ List.intercalate " | " (map (unwords . esc) symbs)   ]   where   symbs = unicodeAndSymbols cf-  mkEsc = unwords . esc+  esc :: String -> [String]   esc s = if null a then rest else show a : rest-      where (a,r) = span (\ c -> isAscii c && isAlphaNum c) s-            rest = case r of-                       [] -> []-                       (c:xs) -> s : esc xs-                         where s = if isPrint c then ['\\',c]-                                                else '\\':show (ord c)+    where+    (a, r) = span (\ c -> isAscii c && isAlphaNum c) s+    rest = case r of+      []     -> []+      c : xs -> (if isPrint c then ['\\',c] else '\\' : show (ord c)) : esc xs  restOfAlex :: TokenText -> CF -> [String]-restOfAlex tokenText cf = [-  ":-",-  "",-  lexComments (comments cf),-  "$white+ ;",-  pTSpec (unicodeAndSymbols cf),--  userDefTokenTypes,-  ident,--  ifC catString ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t | r | f)))* \\\"" ++-                  "\n    { tok (\\p s -> PT p (TL $ unescapeInitTail s)) }"),-  ifC catChar    "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t r f]) \\'\n    { tok (\\p s -> PT p (TC s))  }",-  ifC catInteger "$d+\n    { tok (\\p s -> PT p (TI s))    }",-  ifC catDouble  "$d+ \\. $d+ (e (\\-)? $d+)?\n    { tok (\\p s -> PT p (TD s)) }",-  "",-  "{",-  "",-  "tok :: (Posn -> " ++ stringType ++ " -> Token) -> (Posn -> " ++ stringType ++ " -> Token)",-  "tok f p s = f p s",-  "",-  "data Tok =",-  "   TS !"++stringType++" !Int    -- reserved words and symbols",-  " | TL !"++stringType++"         -- string literals",-  " | TI !"++stringType++"         -- integer literals",-  " | TV !"++stringType++"         -- identifiers",-  " | TD !"++stringType++"         -- double precision float literals",-  " | TC !"++stringType++"         -- character literals",-  userDefTokenConstrs,-  " deriving (Eq,Show,Ord)",-  "",-  "data Token =",-  "   PT  Posn Tok",-  " | Err Posn",-  "  deriving (Eq,Show,Ord)",-  "",-  "printPosn :: Posn -> String",-  "printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c",-  "",-  "tokenPos :: [Token] -> String",-  "tokenPos (t:_) = printPosn (tokenPosn t)",-  "tokenPos [] = \"end of file\"",-  "",-  "tokenPosn :: Token -> Posn",-  "tokenPosn (PT p _) = p",-  "tokenPosn (Err p) = p",-  "",-  "tokenLineCol :: Token -> (Int, Int)",-  "tokenLineCol = posLineCol . tokenPosn",-  "",-  "posLineCol :: Posn -> (Int, Int)",-  "posLineCol (Pn _ l c) = (l,c)",-  "",-  "mkPosToken :: Token -> ((Int, Int), " ++ stringType ++ ")",-  "mkPosToken t@(PT p _) = (posLineCol p, tokenText t)",-  "",-  "tokenText :: Token -> " ++ stringType,-  "tokenText t = case t of",-  "  PT _ (TS s _) -> s",-  "  PT _ (TL s)   -> " ++ applyP stringPack "show s",-  "  PT _ (TI s)   -> s",-  "  PT _ (TV s)   -> s",-  "  PT _ (TD s)   -> s",-  "  PT _ (TC s)   -> s",-  "  Err _         -> " ++ apply stringPack "\"#error\"",-  userDefTokenPrint,-  "prToken :: Token -> String",-  "prToken t = " ++ applyP stringUnpack "tokenText t",-  "",-  "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",-  "",-  "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",-  "eitherResIdent tv s = treeFind resWords",-  "  where",-  "  treeFind N = tv s",-  "  treeFind (B a t left right) | s < a  = treeFind left",-  "                              | s > a  = treeFind right",-  "                              | s == a = t",-  "",-  "resWords :: BTree",-  "resWords = " ++ show (sorted2tree $ cfTokens cf),-  "   where b s n = let bs = "++ apply stringPack "s",-  "                 in  B bs (TS bs n)",-  "",-  "unescapeInitTail :: "++stringType++" -> "++stringType++"",-  "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack,-  "  where",-  "  unesc s = case s of",-  "    '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",-  "    '\\\\':'n':cs  -> '\\n' : unesc cs",-  "    '\\\\':'t':cs  -> '\\t' : unesc cs",-  "    '\\\\':'r':cs  -> '\\r' : unesc cs",-  "    '\\\\':'f':cs  -> '\\f' : unesc cs",-  "    '\"':[]    -> []",-  "    c:cs      -> c : unesc cs",-  "    _         -> []",-  "",-  "-------------------------------------------------------------------",-  "-- Alex wrapper code.",-  "-- A modified \"posn\" wrapper.",-  "-------------------------------------------------------------------",-  "",-  "data Posn = Pn !Int !Int !Int",-  "      deriving (Eq, Show,Ord)",-  "",-  "alexStartPos :: Posn",-  "alexStartPos = Pn 0 1 1",-  "",-  "alexMove :: Posn -> Char -> Posn",-  "alexMove (Pn a l c) '\\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)",-  "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1)   1",-  "alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)",-  "",-  "type Byte = Word8",-  "",-  "type AlexInput = (Posn,     -- current position,",-  "                  Char,     -- previous char",-  "                  [Byte],   -- pending bytes on the current char",-  "                  "++stringType++")   -- current input string",-  "",-  "tokens :: "++stringType++" -> [Token]",-  "tokens str = go (alexStartPos, '\\n', [], str)",-  "    where",-  "      go :: AlexInput -> [Token]",-  "      go inp@(pos, _, _, str) =",-  "               case alexScan inp 0 of",-  "                AlexEOF                   -> []",-  "                AlexError (pos, _, _, _)  -> [Err pos]",-  "                AlexSkip  inp' len        -> go inp'",-  "                AlexToken inp' len act    -> act pos ("++stringTake++" len str) : (go inp')",-  "",-  "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)",-  "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))",-  "alexGetByte (p, _, [], s) =",-  "  case " ++ apply stringUncons "s" ++ " of",-  "    "++stringNilP++"  -> Nothing",-  "    "++stringConsP++" ->",-  "             let p'     = alexMove p c",-  "                 (b:bs) = utf8Encode c",-  "              in p' `seq` Just (b, (p', c, bs, s))",-  "",-  "alexInputPrevChar :: AlexInput -> Char",-  "alexInputPrevChar (p, c, bs, s) = c",-  "",-  "-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.",-  "utf8Encode :: Char -> [Word8]",-  "utf8Encode = map fromIntegral . go . ord",-  " where",-  "  go oc",-  "   | oc <= 0x7f       = [oc]",-  "",-  "   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)",-  "                        , 0x80 + oc Data.Bits..&. 0x3f",-  "                        ]",-  "",-  "   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)",-  "                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",-  "                        , 0x80 + oc Data.Bits..&. 0x3f",-  "                        ]",-  "   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)",-  "                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)",-  "                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",-  "                        , 0x80 + oc Data.Bits..&. 0x3f",-  "                        ]",-  "}"+restOfAlex tokenText cf = concat+  [ [ ":-"+    , ""+    ]+  , lexComments $ comments cf+  , [ "-- Whitespace (skipped)"+    ,  "$white+ ;"+    , ""+    ]+  , unless (null $ unicodeAndSymbols cf)+    [ "-- Symbols"+    , "@rsyms"+    , "    { tok (eitherResIdent TV) }"+    , ""+    ]+  , userDefTokenTypes+  , [ "-- Keywords and Ident"+    , "$l $i*"+    , "    { tok (eitherResIdent TV) }"+    , ""+    ]+  , ifC catString+    [ "-- String"+    , "\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t | r | f)))* \\\""+    , "    { tok (TL . unescapeInitTail) }"+    , ""+    ]+  , ifC catChar+    [ "-- Char"+    , "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t r f]) \\'"+    , "    { tok TC }"+    , ""+    ]+  , ifC catInteger+    [ "-- Integer"+    , "$d+"+    , "    { tok TI }"+    , ""+    ]+  , ifC catDouble+    [ "-- Double"+    , "$d+ \\. $d+ (e (\\-)? $d+)?"+    , "    { tok TD }"+    , ""+    ]+  , [ "{"+    , "-- | Create a token with position."+    , "tok :: (" ++ stringType ++ " -> Tok) -> (Posn -> " ++ stringType ++ " -> Token)"+    , "tok f p = PT p . f"+    , ""+    , "-- | Token without position."+    , "data Tok"+    ]+  , map ("  " ++) $ table "  " $+    [ [ "= TK {-# UNPACK #-} !TokSymbol", "-- ^ Reserved word or symbol." ]+    , [ "| TL !" ++ stringType          , "-- ^ String literal."          ]+    , [ "| TI !" ++ stringType          , "-- ^ Integer literal."         ]+    , [ "| TV !" ++ stringType          , "-- ^ Identifier."              ]+    , [ "| TD !" ++ stringType          , "-- ^ Float literal."           ]+    , [ "| TC !" ++ stringType          , "-- ^ Character literal."       ]+    ]+  , [ "  | T_" ++ name ++ " !" ++ stringType | name <- tokenNames cf ]+  , [ "  deriving (Eq, Show, Ord)"+    , ""+    , "-- | Smart constructor for 'Tok' for the sake of backwards compatibility."+    , "pattern TS :: " ++ stringType ++ " -> Int -> Tok"+    , "pattern TS t i = TK (TokSymbol t i)"+    , ""+    , "-- | Keyword or symbol tokens have a unique ID."+    , "data TokSymbol = TokSymbol"+    , "  { tsText :: " ++ stringType+    , "      -- ^ Keyword or symbol text."+    , "  , tsID   :: !Int"+    , "      -- ^ Unique ID."+    , "  } deriving (Show)"+    , ""+    , "-- | Keyword/symbol equality is determined by the unique ID."+    , "instance Eq  TokSymbol where (==)    = (==)    `on` tsID"+    , ""+    , "-- | Keyword/symbol ordering is determined by the unique ID."+    , "instance Ord TokSymbol where compare = compare `on` tsID"+    , ""+    , "-- | Token with position."+    , "data Token"+    , "  = PT  Posn Tok"+    , "  | Err Posn"+    , "  deriving (Eq, Show, Ord)"+    , ""+    , "-- | Pretty print a position."+    , "printPosn :: Posn -> String"+    , "printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c"+    , ""+    , "-- | Pretty print the position of the first token in the list."+    , "tokenPos :: [Token] -> String"+    , "tokenPos (t:_) = printPosn (tokenPosn t)"+    , "tokenPos []    = \"end of file\""+    , ""+    , "-- | Get the position of a token."+    , "tokenPosn :: Token -> Posn"+    , "tokenPosn (PT p _) = p"+    , "tokenPosn (Err p)  = p"+    , ""+    , "-- | Get line and column of a token."+    , "tokenLineCol :: Token -> (Int, Int)"+    , "tokenLineCol = posLineCol . tokenPosn"+    , ""+    , "-- | Get line and column of a position."+    , "posLineCol :: Posn -> (Int, Int)"+    , "posLineCol (Pn _ l c) = (l,c)"+    , ""+    , "-- | Convert a token into \"position token\" form."+    , "mkPosToken :: Token -> ((Int, Int), " ++ stringType ++ ")"+    , "mkPosToken t = (tokenLineCol t, tokenText t)"+    , ""+    , "-- | Convert a token to its text."+    , "tokenText :: Token -> " ++ stringType+    , "tokenText t = case t of"+    , "  PT _ (TS s _) -> s"+    , "  PT _ (TL s)   -> " ++ applyP stringPack "show s"+    , "  PT _ (TI s)   -> s"+    , "  PT _ (TV s)   -> s"+    , "  PT _ (TD s)   -> s"+    , "  PT _ (TC s)   -> s"+    , "  Err _         -> " ++ apply stringPack "\"#error\""+    ]+  , [ "  PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf ]+  , [ ""+    , "-- | Convert a token to a string."+    , "prToken :: Token -> String"+    , "prToken t = " ++ applyP stringUnpack "tokenText t"+    , ""+    , "-- | Finite map from text to token organized as binary search tree."+    , "data BTree"+    , "  = N -- ^ Nil (leaf)."+    , "  | B " ++ stringType ++ " Tok BTree BTree"+    , "      -- ^ Binary node."+    , "  deriving (Show)"+    , ""+    , "-- | Convert potential keyword into token or use fallback conversion."+    , "eitherResIdent :: (" ++ stringType ++ " -> Tok) -> " ++ stringType ++ " -> Tok"+    , "eitherResIdent tv s = treeFind resWords"+    , "  where"+    , "  treeFind N = tv s"+    , "  treeFind (B a t left right) ="+    , "    case compare s a of"+    , "      LT -> treeFind left"+    , "      GT -> treeFind right"+    , "      EQ -> t"+    , ""+    , "-- | The keywords and symbols of the language organized as binary search tree."+    , "resWords :: BTree"+    , render $ hang "resWords =" 2 $ pretty $ sorted2tree tokens+    ]+  , unless (null tokens)+    [ "  where"+    , "  b s n = B bs (TS bs n)"+    , "    where"+    , "    bs = "++ apply stringPack "s"+    ]+  , [ ""+    , "-- | Unquote string literal."+    , "unescapeInitTail :: " ++ stringType ++ " -> " ++ stringType ++ ""+    , "unescapeInitTail = " ++ stringPack ++ " . unesc . tail . " ++ stringUnpack+    , "  where"+    , "  unesc s = case s of"+    , "    '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs"+    , "    '\\\\':'n':cs  -> '\\n' : unesc cs"+    , "    '\\\\':'t':cs  -> '\\t' : unesc cs"+    , "    '\\\\':'r':cs  -> '\\r' : unesc cs"+    , "    '\\\\':'f':cs  -> '\\f' : unesc cs"+    , "    '\"':[]       -> []"+    , "    c:cs         -> c : unesc cs"+    , "    _            -> []"+    , ""+    , "-------------------------------------------------------------------"+    , "-- Alex wrapper code."+    , "-- A modified \"posn\" wrapper."+    , "-------------------------------------------------------------------"+    , ""+    , "data Posn = Pn !Int !Int !Int"+    , "  deriving (Eq, Show, Ord)"+    , ""+    , "alexStartPos :: Posn"+    , "alexStartPos = Pn 0 1 1"+    , ""+    , "alexMove :: Posn -> Char -> Posn"+    , "alexMove (Pn a l c) '\\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)"+    , "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1)   1"+    , "alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)"+    , ""+    , "type Byte = Word8"+    , ""+    , "type AlexInput = (Posn,     -- current position,"+    , "                  Char,     -- previous char"+    , "                  [Byte],   -- pending bytes on the current char"+    , "                  " ++ stringType ++ ")   -- current input string"+    , ""+    , "tokens :: " ++ stringType ++ " -> [Token]"+    , "tokens str = go (alexStartPos, '\\n', [], str)"+    , "    where"+    , "      go :: AlexInput -> [Token]"+    , "      go inp@(pos, _, _, str) ="+    , "               case alexScan inp 0 of"+    , "                AlexEOF                   -> []"+    , "                AlexError (pos, _, _, _)  -> [Err pos]"+    , "                AlexSkip  inp' len        -> go inp'"+    , "                AlexToken inp' len act    -> act pos (" ++ stringTake ++ " len str) : (go inp')"+    , ""+    , "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)"+    , "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))"+    , "alexGetByte (p, _, [], s) ="+    , "  case " ++ apply stringUncons "s" ++ " of"+    , "    " ++ stringNilP ++ "  -> Nothing"+    , "    " ++ stringConsP ++ " ->"+    , "             let p'     = alexMove p c"+    , "                 (b:bs) = utf8Encode c"+    , "              in p' `seq` Just (b, (p', c, bs, s))"+    , ""+    , "alexInputPrevChar :: AlexInput -> Char"+    , "alexInputPrevChar (p, c, bs, s) = c"+    , ""+    , "-- | Encode a Haskell String to a list of Word8 values, in UTF8 format."+    , "utf8Encode :: Char -> [Word8]"+    , "utf8Encode = map fromIntegral . go . ord"+    , "  where"+    , "  go oc"+    , "   | oc <= 0x7f       = [oc]"+    , ""+    , "   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)"+    , "                        , 0x80 + oc Data.Bits..&. 0x3f"+    , "                        ]"+    , ""+    , "   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)"+    , "                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)"+    , "                        , 0x80 + oc Data.Bits..&. 0x3f"+    , "                        ]"+    , "   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)"+    , "                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)"+    , "                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)"+    , "                        , 0x80 + oc Data.Bits..&. 0x3f"+    , "                        ]"+    , "}"+    ]   ]- where-   (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP) = case tokenText of-     StringToken     -> ("String",        "take",    "",          "id",      "id",        "[]",      "(c:s)"     )-     ByteStringToken -> ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")-     TextToken       -> ("Data.Text.Text", "Data.Text.take", "Data.Text.uncons", "Data.Text.pack", "Data.Text.unpack", "Nothing", "Just (c,s)")--   apply :: String -> String -> String-   apply ""   s = s-   apply "id" s = s-   apply f    s = f ++ " " ++ s--   applyP :: String -> String -> String-   applyP ""   s = s-   applyP "id" s = s-   applyP f    s = f ++ " (" ++ s ++ ")"--   ifC :: TokenCat -> String -> String-   ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""--   lexComments-     :: ( [(String, String)]  -- block comment delimiters-        , [String]            -- line  comment initiators-        ) -> String           -- Alex declarations-   lexComments (block, line) = unlines $ concat $-     [ [ "-- Line comments"  | not (null line)               ]-     , map lexLineComment line-     , [ ""                  | not (null line || null block) ]-     , [ "-- Block comments" | not (null block)              ]-     , map (uncurry lexBlockComment) block-     ]+  where+  (stringType, stringTake, stringUncons, stringPack, stringUnpack, stringNilP, stringConsP) =+    case tokenText of+      StringToken     -> ("String",        "take",    "",          "id",      "id",        "[]",      "(c:s)"     )+      ByteStringToken -> ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")+      TextToken       -> ("Data.Text.Text", "Data.Text.take", "Data.Text.uncons", "Data.Text.pack", "Data.Text.unpack", "Nothing", "Just (c,s)") -   lexLineComment-     :: String   -- ^ Line comment start.-     -> String   -- ^ Alex declaration.-   lexLineComment s = concat [ "\"", s, "\" [.]* ;" ]+  apply :: String -> String -> String+  apply ""   s = s+  apply "id" s = s+  apply f    s = f ++ " " ++ s -   lexBlockComment-     :: String   -- ^ Start of block comment.-     -> String   -- ^ End of block comment.-     -> String   -- ^ Alex declaration.-   lexBlockComment start end = printRegAlex (mkRegMultilineComment start end) ++ " ;"+  applyP :: String -> String -> String+  applyP ""   s = s+  applyP "id" s = s+  applyP f    s = f ++ " (" ++ s ++ ")" -   -- tokens consisting of special symbols-   pTSpec [] = ""-   pTSpec _ = "@rsyms\n    { tok (\\p s -> PT p (eitherResIdent TV s)) }"+  ifC :: Monoid m => TokenCat -> m -> m+  ifC = when . isUsedCat cf . TokenCat -   userDefTokenTypes = unlines-     [ printRegAlex exp ++-       "\n    { tok (\\p s -> PT p (eitherResIdent T_"  ++ name ++ " s)) }"-     | (name,exp) <- tokenPragmas cf-     ]+  lexComments+    :: ( [(String, String)]  -- block comment delimiters+       , [String]            -- line  comment initiators+       ) -> [String]         -- Alex declarations+  lexComments (block, line) = concat $+    [ concatMap lexLineComment line+    , concatMap (uncurry lexBlockComment) block+    ] -   userDefTokenConstrs = unlines-     [ " | T_" ++ name ++ " !"++stringType-     | name <- tokenNames cf-     ]+  lexLineComment+    :: String   -- ^ Line comment start.+    -> [String] -- ^ Alex declaration.+  lexLineComment s =+    [ unwords [ "-- Line comment", show s ]+    , concat [ "\"", s, "\" [.]* ;" ]+    , ""+    ] -   userDefTokenPrint = unlines-     [ "  PT _ (T_" ++ name ++ " s) -> s"-     | name <- tokenNames cf-     ]+  lexBlockComment+    :: String   -- ^ Start of block comment.+    -> String   -- ^ End of block comment.+    -> [String] -- ^ Alex declaration.+  lexBlockComment start end =+    [ unwords [ "-- Block comment", show start, show end ]+    , printRegAlex (mkRegMultilineComment start end) ++ " ;"+    , ""+    ] -   ident =-     "$l $i*\n    { tok (\\p s -> PT p (eitherResIdent TV s)) }"-     --ifC "Ident"  "<ident>   ::= ^l ^i*   { ident  p = PT p . eitherResIdent TV }"+  userDefTokenTypes :: [String]+  userDefTokenTypes = concat+    [ [ "-- token " ++ name+      , printRegAlex exp+      , "    { tok (eitherResIdent T_"  ++ name ++ ") }"+      , ""+      ]+    | (name, exp) <- tokenPragmas cf+    ] +  tokens = cfTokens cf -data BTree = N | B String Int BTree BTree+-- | Binary search tree.+data BTree a+  = N+  | B String a (BTree a) (BTree a) -instance Show BTree where-  showsPrec _  N          = showString "N"-  showsPrec n (B s k l r) = mparens-      $ showString "b " . shows s-      . showChar ' ' . shows k-      . showChar ' ' . showsPrec 1 l-      . showChar ' ' . showsPrec 1 r-    where-    mparens f = if n > 0 then showChar '(' . f . showChar ')' else f+instance Pretty a => Pretty (BTree a) where+  prettyPrec _  N          = text "N"+  prettyPrec n (B k v l r) = parensIf (n > 0) $+    hang ("b" <+> text (show k) <+> pretty v) 2 $ sep+      [ prettyPrec 1 l+      , prettyPrec 1 r+      ] -sorted2tree :: [(String,Int)] -> BTree+-- | Create a balanced search tree from a sorted list.+sorted2tree :: [(String,a)] -> BTree a sorted2tree [] = N sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2)   where@@ -338,16 +421,16 @@  -- the top-level printing method printRegAlex :: Reg -> String-printRegAlex = render . prt 0+printRegAlex = render' . prt 0 -render :: [String] -> String-render = \case-    "["      : ts -> cons "["  $ render ts-    "("      : ts -> cons "("  $ render ts-    t  : "," : ts -> cons t    $ space "," $ render ts-    t  : ")" : ts -> cons t    $ cons ")"  $ render ts-    t  : "]" : ts -> cons t    $ cons "]"  $ render ts-    t        : ts -> space t   $ render ts+render' :: [String] -> String+render' = \case+    "["      : ts -> cons "["  $ render' ts+    "("      : ts -> cons "("  $ render' ts+    t  : "," : ts -> cons t    $ space "," $ render' ts+    t  : ")" : ts -> cons t    $ cons ")"  $ render' ts+    t  : "]" : ts -> cons t    $ cons "]"  $ render' ts+    t        : ts -> space t   $ render' ts     _             -> ""   where   cons s t  = s ++ t

@@ -50,6 +50,7 @@   , delimiter   , specialRules absName functor tokenText cf   , render $ prRules absName functor (rulesForHappy absName functor cf)+  , ""   , footer absName tokenText functor eps cf   ]   where@@ -61,6 +62,8 @@   [ [ "-- This Happy file was machine-generated by the BNF converter"     , "{"     , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}"+    , "{-# LANGUAGE PatternSynonyms #-}"+    , ""     , "module " ++ modName     , "  ( happyError"     , "  , myLexer"@@ -117,10 +120,10 @@   -- Andreas, 2019-01-02: "%token" followed by nothing is a Happy parse error.   -- Thus, if we have no tokens, do not output anything.   | null ts   = empty-  | otherwise = "%token" $$ (nest 2 $ vcat ts)+  | otherwise = "%token" $$ (nest 2 $ vcat $ map text $ table " " ts)   where-    ts            = map prToken (cfTokens cf) ++ map text (specialToks cf functor)-    prToken (t,k) = hsep [ convert t, lbrace, text ("PT _ (TS _ " ++ show k ++ ")"), rbrace ]+    ts            = map prToken (cfTokens cf) ++ specialToks cf functor+    prToken (t,k) = [ render (convert t), "{ PT _ (TS _ " ++ show k ++ ")", "}" ]  -- Happy doesn't allow characters such as åäö to occur in the happy file. This -- is however not a restriction, just a naming paradigm in the happy source file.@@ -204,13 +207,18 @@ -- Expr : Integer { Foo.EInt $1 } | Expr '+' Expr { Foo.EPlus $1 $3 } -- -- if there's a lot of cases, print on several lines:--- >>> prRules "" False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5")])]+-- >>> prRules "" False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5"), ("P6", "A6"), ("P7", "A7"), ("P8", "A8"), ("P9","A9")])] -- Expr :: { Expr }--- Expr : Abcd { Action }---      | P2 { A2 }---      | P3 { A3 }---      | P4 { A4 }---      | P5 { A5 }+-- Expr+--   : Abcd { Action }+--   | P2 { A2 }+--   | P3 { A3 }+--   | P4 { A4 }+--   | P5 { A5 }+--   | P6 { A6 }+--   | P7 { A7 }+--   | P8 { A8 }+--   | P9 { A9 } -- -- >>> prRules "" False [(Cat "Internal", [])] -- nt has only internal use -- <BLANKLINE>@@ -231,14 +239,15 @@ prRules absM functor = vsep . map prOne   where     prOne (_ , []      ) = empty -- nt has only internal use-    prOne (nt, (p,a):ls) =-        hsep [ nt', "::", "{", if functor then functorType' nt else type' nt, "}" ]-        $$ nt' <+> sep (pr ":" (p, a) : map (pr "|") ls)+    prOne (nt, (p,a):ls) = vcat+        [ hsep [ nt', "::", "{", if functor then functorType' nt else type' nt, "}" ]+        , hang nt' 2 $ sep (pr ":" (p, a) : map (pr "|") ls)+        ]       where-        nt' = text (identCat nt)+        nt'          = text (identCat nt)         pr pre (p,a) = hsep [pre, text p, "{", text a , "}"]-    type' = catToType qualify empty-    functorType' nt = hcat ["(", qualify posType, ", ", type' nt, ")"]+    type'            = catToType qualify empty+    functorType' nt  = hcat ["(", qualify posType, ", ", type' nt, ")"]     qualify       | null absM = id       | otherwise = ((text absM <> ".") <>)@@ -285,14 +294,14 @@       | otherwise    = ((text absName <> ".") <>)  -- | GF literals.-specialToks :: CF -> Bool -> [String]+specialToks :: CF -> Bool -> [[String]]  -- ^ A table with three columns (last is "}"). specialToks cf functor = (`map` literals cf) $ \t -> case t of-  "Ident"   -> "L_Ident  { PT _ (TV " ++ posn t ++ ") }"-  "String"  -> "L_quoted { PT _ (TL " ++ posn t ++ ") }"-  "Integer" -> "L_integ  { PT _ (TI " ++ posn t ++ ") }"-  "Double"  -> "L_doubl  { PT _ (TD " ++ posn t ++ ") }"-  "Char"    -> "L_charac { PT _ (TC " ++ posn t ++ ") }"-  own       -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn own ++ ") }"+  "Ident"   -> [ "L_Ident" , "{ PT _ (TV " ++ posn t ++ ")", "}" ]+  "String"  -> [ "L_quoted", "{ PT _ (TL " ++ posn t ++ ")", "}" ]+  "Integer" -> [ "L_integ ", "{ PT _ (TI " ++ posn t ++ ")", "}" ]+  "Double"  -> [ "L_doubl ", "{ PT _ (TD " ++ posn t ++ ")", "}" ]+  "Char"    -> [ "L_charac", "{ PT _ (TC " ++ posn t ++ ")", "}" ]+  own       -> [ "L_" ++ own,"{ PT _ (T_" ++ own ++ " " ++ posn own ++ ")", "}" ]   where     posn tokenCat = if isPositionCat cf tokenCat || functor then "_" else "$$" 

@@ -7,283 +7,344 @@  module BNFC.Backend.Haskell.CFtoLayout where -import Data.List (sort)+import Data.Maybe                 ( fromMaybe )+ import BNFC.CF-import BNFC.Options (TokenText(..))-import BNFC.Backend.Haskell.Utils+import BNFC.Options               ( TokenText )+import BNFC.PrettyPrint+import BNFC.Utils                 ( caseMaybe, for, whenJust ) -layoutOpen  = "{"-layoutClose = "}"-layoutSep   = ";"+data TokSymbol = TokSymbol String Int+  deriving Show -cf2Layout :: TokenText -> String -> String -> CF -> String-cf2Layout tokenText layName lexName cf = unlines $ [-  "module " ++ layName ++ " where",-  "",-  "import Prelude",-  "",-  "import " ++ lexName,-  "",-  if tokenText == TextToken then "import qualified Data.Text" else "",-  "import Data.Maybe (isNothing, fromJust)",-  "",-  "-- Generated by the BNF Converter",-  "",-  "-- local parameters",-  "",-  "",-  "topLayout :: Bool",-  "topLayout = " ++ show top,-  "",-  "layoutWords, layoutStopWords :: [String]",-  "layoutWords     = " ++ show lay,-  "layoutStopWords = " ++ show stop,-  "",-  "-- layout separators",-  "",-  "",-  "layoutOpen, layoutClose, layoutSep :: String",-  "layoutOpen  = " ++ show layoutOpen,-  "layoutClose = " ++ show layoutClose,-  "layoutSep   = " ++ show layoutSep,-  "",-  "-- | Replace layout syntax with explicit layout tokens.",-  "resolveLayout :: Bool    -- ^ Whether to use top-level layout.",-  "              -> [Token] -> [Token]",-  "resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]",-  "  where",-  "  -- Do top-level layout if the function parameter and the grammar say so.",-  "  tl = tp && topLayout",-  "",-  "  res :: Maybe Token -- ^ The previous token, if any.",-  "      -> [Block] -- ^ A stack of layout blocks.",-  "      -> [Token] -> [Token]",-  "",-  "  -- The stack should never be empty.",-  "  res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts",-  "",-  "  res _ st (t0:ts)",-  "    -- We found an open brace in the input,",-  "    -- put an explicit layout block on the stack.",-  "    -- This is done even if there was no layout word,",-  "    -- to keep opening and closing braces.",-  "    | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts",-  "",-  "  -- We are in an implicit layout block",-  "  res pt (Implicit n:ns) (t0: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,ns') = span (`moreIndent` column t0) ns",-  "           moreIndent (Implicit x) y = x > y",-  "           moreIndent Explicit _ = False",-  "           -- the number of blocks exited",-  "           b = 1 + length ebs",-  "           bs = replicate b layoutClose",-  "           -- Insert closing braces after the previous token.",-  "           (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)",-  "        in moveAlong ns' ts1 ts2",-  "",-  "    -- End of an implicit layout block",-  "    | newLine pt t0 && column t0 < n  = ",-  "           -- Insert a closing brace after the previous token.",-  "       let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)",-  "           -- Repeat, with the current block removed from the stack",-  "        in moveAlong ns [b] (t0':ts')",-  "",-  "  res pt st (t0:ts)",-  "    -- Start a new layout block if the first token is a layout word",-  "    | isLayout t0 =",-  "        case ts of",-  "            -- Explicit layout, just move on. The case above",-  "            -- will push an explicit layout block.",-  "            t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts",-  "                 -- The column of the next token determines the starting column",-  "                 -- of the implicit layout block.",-  "                 -- However, the next block needs to be strictly more indented",-  "                 -- than the previous block.",-  "            _ -> let col = max (indentation st + 1) $",-  "                       -- at end of file, the start column doesn't matter",-  "                       if null ts then column t0 else column (head ts)",-  "                     -- insert an open brace after the layout word",-  "                     b:ts' = addToken (nextPos t0) layoutOpen ts",-  "                     -- save the start column",-  "                     st' = Implicit col:st ",-  "                 in -- Do we have to insert an extra layoutSep?",-  "                case st of",-  "                  Implicit n:_",-  "                    | newLine pt t0 && column t0 == n",-  "                      && not (isNothing pt ||",-  "                              isTokenIn [layoutSep,layoutOpen] (fromJust pt)) ->",-  "                     let b':t0':b'':_ =",-  "                           addToken (afterPrev pt) layoutSep (t0:b:ts')",-  "                     in moveAlong st' [b',t0',b''] ts'",-  "                  _ -> moveAlong st' [t0,b] ts'",-  "",-  "    -- If we encounter a closing brace, exit the first explicit layout block.",-  "    | isLayoutClose t0 = ",-  "          let st' = drop 1 (dropWhile isImplicit st)",-  "           in if null st' ",-  "                 then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ",-  "                              ++ show (line t0) ++ \",\" ++ show (column t0) ",-  "                              ++ \") without an explicit layout block.\"",-  "                 else moveAlong st' [t0] ts",-  "",-  "  -- Insert separator if necessary.",-  "  res pt st@(Implicit n : _) (t0:ts)",-  "    -- Encounted a new line in an implicit layout block.",-  "    | newLine pt t0 && column t0 == n = ",-  "       -- Insert a semicolon after the previous token.",-  "       -- unless we are the beginning of the file,",-  "       -- or the previous token is a semicolon or open brace.",-  "       if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt)",-  "          then moveAlong st [t0] ts",-  "          else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)",-  "                in moveAlong st [b,t0'] ts'",-  "",-  "  -- Nothing to see here, move along.",-  "  res _ st (t:ts)  = moveAlong st [t] ts",-  "",-  "  -- At EOF: skip explicit blocks.",-  "  res (Just t) (Explicit:bs) [] | null bs = []",-  "                                | otherwise = res (Just t) bs []",-  "",-  "  -- If we are using top-level layout, insert a semicolon after",-  "  -- the last token, if there isn't one already",-  "  res (Just t) [Implicit _n] []",-  "      | isTokenIn [layoutSep] t = []",-  "      | otherwise = addToken (nextPos t) layoutSep []",-  "",-  "  -- At EOF in an implicit, non-top-level block: close the block",-  "  res (Just t) (Implicit _ : bs) [] =",-  "     let c = addToken (nextPos t) layoutClose []",-  "      in moveAlong bs c []",-  "",-  "  -- This should only happen if the input is empty.",-  "  res Nothing _st [] = []",-  "",-  "  -- | Move on to the next token.",-  "  moveAlong :: [Block] -- ^ The layout stack.",-  "            -> [Token] -- ^ Any tokens just processed.",-  "            -> [Token] -- ^ the rest of the tokens.",-  "            -> [Token]",-  "  moveAlong _  [] _  = error \"Layout error: moveAlong got [] as old tokens\"",-  "  moveAlong st ot ts = ot ++ res (Just $ last ot) st ts",-  "",-  "  newLine :: Maybe Token -> Token -> Bool",-  "  newLine pt t0 = case pt of",-  "    Nothing -> True",-  "    Just t  -> line t /= line t0",-  "",-  "data Block",-  "   = Implicit Int -- ^ An implicit layout block with its start column.",-  "   | Explicit",-  "   deriving Show",-  "",-  "-- | Get current indentation.  0 if we are in an explicit block.",-  "indentation :: [Block] -> Int",-  "indentation (Implicit n : _) = n",-  "indentation _ = 0",-  "",-  "-- | Check if s block is implicit.",-  "isImplicit :: Block -> Bool",-  "isImplicit (Implicit _) = True",-  "isImplicit _ = False",-  "",-  "type Position = Posn",-  "",-  "-- | Insert a number of tokens at the begninning of a list of tokens.",-  "addTokens :: Position -- ^ Position of the first new token.",-  "          -> [String] -- ^ Token symbols.",-  "          -> [Token]  -- ^ The rest of the tokens. These will have their",-  "                      --   positions updated to make room for the new tokens .",-  "          -> [Token]",-  "addTokens p ss ts = foldr (addToken p) ts ss",-  "",-  "-- | Insert a new symbol token at the begninning of a list of tokens.",-  "addToken :: Position -- ^ Position of the new token.",-  "         -> String   -- ^ Symbol in the new token.",-  "         -> [Token]  -- ^ The rest of the tokens. These will have their",-  "                     --   positions updated to make room for the new token.",  "         -> [Token]",-  "addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts",-  "",-  "-- | Get the position immediately to the right of the given token.",-  "--   If no token is given, gets the first position in the file.",-  "afterPrev :: Maybe Token -> Position",-  "afterPrev = maybe (Pn 0 1 1) nextPos",-  "",-  "-- | Get the position immediately to the right of the given token.",-  "nextPos :: Token -> Position",-  "nextPos t = Pn (g + s) l (c + s + 1)",-  "  where Pn g l c = position t",-  "        s = tokenLength t",-  "",-  "-- | Add to the global and column positions of a token.",-  "--   The column position is only changed if the token is on",-  "--   the same line as the given position.",-  "incrGlobal :: Position -- ^ If the token is on the same line",-  "                       --   as this position, update the column position.",-  "           -> Int      -- ^ Number of characters to add to the position.",-  "           -> Token -> Token",-  "incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =",-  "  if l /= l0 then PT (Pn (g + i) l c) t",-  "             else PT (Pn (g + i) l (c + i)) t",-  "incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p",-  "",-  "-- | Create a symbol token.",-  "sToken :: Position -> String -> Token",-  "sToken p s = PT p (TS " ++ tokenTextPackParens tokenText "s" ++ " i)",-  "  where",-  "    i = case s of"] ++-  [ "      " ++ show s ++ " -> " ++ show i-    | (s, i) <- zip resws [1..]-  ] ++-  ["      _ -> error $ \"not a reserved word: \" ++ show s",-  "",-  "-- | Get the position of a token.",-  "position :: Token -> Position",-  "position t = case t of",-  "  PT p _ -> p",-  "  Err p -> p",-  "",-  "-- | Get the line number of a token.",-  "line :: Token -> Int",-  "line t = case position t of Pn _ l _ -> l",-  "",-  "-- | Get the column number of a token.",-  "column :: Token -> Int",-  "column t = case position t of Pn _ _ c -> c",-  "",-  "-- | Check if a token is one of the given symbols.",-  "isTokenIn :: [String] -> Token -> Bool",-  "isTokenIn ts t = case t of",-  "  PT _ (TS r _) | " ++ tokenTextUnpack tokenText "r" ++ " `elem` ts -> True",-  "  _ -> False",-  "",-  "-- | Check if a word is a layout start token.",-  "isLayout :: Token -> Bool",-  "isLayout = isTokenIn layoutWords",-  "",-  "-- | Check if a token is a layout stop token.",-  "isStop :: Token -> Bool",-  "isStop = isTokenIn layoutStopWords",-  "",-  "-- | Check if a token is the layout open token.",-  "isLayoutOpen :: Token -> Bool",-  "isLayoutOpen = isTokenIn [layoutOpen]",-  "",-  "-- | Check if a token is the layout close token.",-  "isLayoutClose :: Token -> Bool",-  "isLayoutClose = isTokenIn [layoutClose]",-  "",-  "-- | Get the number of characters in the token.",-  "tokenLength :: Token -> Int",-  "tokenLength t = length $ prToken t",+data LayoutDelimiters = LayoutDelimiters TokSymbol (Maybe TokSymbol) (Maybe TokSymbol)+  deriving Show -  ""+cf2Layout :: String -> String -> CF -> String+cf2Layout layName lexName cf = unlines $ concat+  [ [ "-- Generated by the BNF Converter"+    , ""+    , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"+    , ""+    , "{-# LANGUAGE LambdaCase #-}"+    , "{-# LANGUAGE PatternGuards #-}"+    , "{-# LANGUAGE OverloadedStrings #-}"+    , ""+    , "module " ++ layName ++ " where"+    , ""+    , "import Prelude"+    , "import Data.Maybe ( fromMaybe, listToMaybe, mapMaybe )"+    , "import qualified Data.List as List"+    , ""+    , "import " ++ lexName+    , "  ( Posn(..), Tok(..), Token(..), TokSymbol(..)"+    , "  , prToken, tokenLineCol, tokenPos, tokenPosn"+    , "  )"+    , ""+    , "-- local parameters"+    , ""+    , "data LayoutDelimiters"+    , "  = LayoutDelimiters"+    , "    { delimSep   :: TokSymbol"+    , "    , delimOpen  :: Maybe TokSymbol  -- ^ Nothing for toplevel layout."+    , "    , delimClose :: Maybe TokSymbol  -- ^ Nothing for toplevel layout."+    , "    }"+    , ""+    , "layoutWords :: [(TokSymbol, LayoutDelimiters)]"+    , render $ prettyList 2 "layoutWords =" "[" "]" "," $+        for lay $ \ (kw, delims) ->+          prettyList 0 empty "(" ")" "," $+            map text [ show kw, show delims ]+    , ""+    , "layoutStopWords :: [TokSymbol]"+    , render $ prettyList 2 "layoutStopWords =" "[" "]" "," $ map (text . show) stop+    , ""+    , "-- layout separators"+    , ""+    , "layoutOpen, layoutClose, layoutSep :: [TokSymbol]"+    , "layoutOpen  = List.nub $ mapMaybe (delimOpen  . snd) layoutWords"+    , "layoutClose = List.nub $ mapMaybe (delimClose . snd) layoutWords"+    , unwords $ concat+      [ [ "layoutSep   = List.nub $" ]+      , whenJust top $ \ sep -> [ show sep, ":" ]+      , [ "map (delimSep . snd) layoutWords" ]+      ]+    , ""+    , "-- | Replace layout syntax with explicit layout tokens."+    , "resolveLayout :: Bool    -- ^ Whether to use top-level layout."+    , "              -> [Token] -> [Token]"+    ]+  , caseMaybe topDelim+    -- No top-level layout+    [ "resolveLayout _topLayout = res Nothing [Explicit]"+    , "  where"+    ]+    -- Can have top-level layout+    (\ delim ->+    [ "resolveLayout topLayout ="+    , "  res Nothing [if topLayout then Implicit topDelim Definitive 1 else Explicit]"+    , "  where"+    , "  topDelim :: LayoutDelimiters"+    , "  topDelim = " ++ show delim+    ])+  , [ ""+    , "  res :: Maybe Token -- ^ The previous token, if any."+    , "      -> [Block]     -- ^ A stack of layout blocks."+    , "      -> [Token] -> [Token]"+    , ""+    , "  -- The stack should never be empty."+    , "  res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts"+    , ""+    , "  -- Handling explicit blocks:"+    , "  res _ st (t0 : ts)"+    , "    -- We found an open brace in the input,"+    , "    -- put an explicit layout block on the stack."+    , "    -- This is done even if there was no layout word,"+    , "    -- to keep opening and closing braces."+    , "    | isLayoutOpen t0"+    , "      = t0 : res (Just t0) (Explicit : st) ts"+    , ""+    , "    -- If we encounter a closing brace, exit the first explicit layout block."+    , "    | isLayoutClose t0"+    , "      , 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.\""+    , "          ]"+    , "        else map (closingToken (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)"+    , ""+    , "      -- 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"+    , ""+    , "    -- 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"+    , "      = c : res (Just c) bs (t0 : ts)"+    , ""+    , "    -- If we are on a newline, confirm the last tentative blocks."+    , "    | newLine pt t0, Tentative{} <- status"+    , "      = res pt (Implicit delim Definitive col : confirm col bs) (t0 : ts)"+    , ""+    , "  -- Starting and processing implicit layout blocks:"+    , "  res pt st (t0 : ts)"+    , "    -- Start a new layout block if the first token is a layout word."+    , "    | Just delim@(LayoutDelimiters _ mopen _) <- isLayout t0"+    , "      = maybeInsertSeparator pt t0 st $"+    , "        case ts of"+    , "          -- Explicit layout, just move on. The next step"+    , "          -- will push an explicit layout block."+    , "          t1 : _ | isLayoutOpen t1 ->"+    , "            t0 : res (Just t0) st ts"+    , "          -- Otherwise, insert an open brace after the layout word"+    , "          _ ->"+    , "            t0 : b : res (Just b) (addImplicit delim (tokenPosn t0) pos st) ts"+    , "            where"+    , "            b   = sToken (nextPos t0) $ fromMaybe undefined mopen"+    , "            -- At the end of the file, the start column does not matter."+    , "            -- So if there is no token t1 after t0, just use the position of t0."+    , "            pos = tokenPosn $ fromMaybe t0 $ listToMaybe ts"+    , ""+    , "    -- Insert separator if necessary."+    , "    | otherwise"+    , "      = maybeInsertSeparator pt t0 st $"+    , "        t0 : res (Just t0) st ts"+    , ""+    , "  -- At EOF: skip explicit blocks."+    , "  res (Just _) [Explicit]      [] = []"+    , "  res (Just t) (Explicit : bs) [] = res (Just t) bs []"+    , ""+    , "  -- If we are using top-level layout, insert a semicolon after"+    , "  -- the last token, if there isn't one already"+    , "  res (Just t) [Implicit (LayoutDelimiters sep _ _) _ _] []"+    , "    | isLayoutSep t = []"+    , "    | otherwise     = [sToken (nextPos t) sep]"+    , ""+    , "  -- At EOF in an implicit, non-top-level block: close the block"+    , "  res (Just t) (Implicit (LayoutDelimiters _ _ (Just close)) _ _ : bs) []"+    , "      = b : res (Just b) bs []"+    , "        where b = sToken (nextPos t) close"+    , ""+    , "  -- This should only happen if the input is empty."+    , "  res Nothing _st []"+    , "      = []"+    , ""+    , "  -- | Insert a 'layoutSep' if we are on a new line on the current"+    , "  --   implicit layout column."+    , "  maybeInsertSeparator"+    , "    :: Maybe Token  -- ^ The previous token."+    , "    -> Token        -- ^ The current token."+    , "    -> [Block]      -- ^ The layout stack."+    , "    -> [Token]      -- ^ The result token stream."+    , "    -> [Token]      -- ^ Maybe prepended with a 'layoutSep'."+    , "  maybeInsertSeparator pt t0 = \\case"+    , "    Implicit (LayoutDelimiters sep _ _) _ n : _"+    , "      | newLine pt t0"+    , "      , column t0 == n"+    , "      , maybe False (not . isTokenIn (layoutSep ++ layoutOpen)) pt"+    , "       -- Insert a semicolon after the previous token"+    , "       -- unless we are the beginning of the file,"+    , "       -- or the previous token is a semicolon or open brace."+    , "      -> (sToken (afterPrev pt) sep :)"+    , "    _ -> id"+    , ""+    , "  closingToken :: Position -> Block -> Token"+    , "  closingToken pos = sToken pos . \\case"+    , "    Implicit (LayoutDelimiters _ _ (Just sy)) _ _ -> sy"+    , ""+    , "type Position = Posn"+    , "type Line     = Int"+    , "type Column   = Int"+    , ""+    , "-- | Entry of the layout stack."+    , "data Block"+    , "   = Implicit LayoutDelimiters Status Column"+    , "       -- ^ An implicit layout block with its start column."+    , "   | Explicit"+    , ""+    , "-- | Get current indentation.  0 if we are in an explicit block."+    , "indentation :: Block -> Column"+    , "indentation = \\case"+    , "  Implicit _ _ n -> n"+    , "  Explicit -> 0"+    , ""+    , "-- | Check if s block is implicit."+    , "isImplicit :: Block -> Bool"+    , "isImplicit = \\case"+    , "  Implicit{} -> True"+    , "  Explicit{} -> False"+    , ""+    , "data Status"+    , "  = Tentative   -- ^ A layout column that has not been confirmed by a line break"+    , "  | Definitive  -- ^ A layout column that has been confirmed by a line break."+    , ""+    , "-- | Add a new implicit layout block."+    , "addImplicit"+    , "  :: LayoutDelimiters -- ^ Delimiters of the new block."+    , "  -> Position         -- ^ Position of the layout keyword."+    , "  -> Position         -- ^ Position of the token following the layout keword."+    , "  -> [Block]"+    , "  -> [Block]"+    , "addImplicit delim (Pn _ l0 _) (Pn _ l1 c1) st"+    , "    -- Case: layout keyword was at the end of the line:"+    , "    -- New implicit block is definitive."+    , "    | l1 > l0   = Implicit delim Definitive (col st') : st'"+    , "    -- Case: staying on the same line:"+    , "    -- New implicit block is tentative."+    , "    | otherwise = Implicit delim Tentative (col st) : st"+    , "  where"+    , "  st' = confirm c1 st"+    , "  col bs = max c1 $ 1 + definiteIndentation bs"+    , "    -- The column of the next token determines the starting column"+    , "    -- of the implicit layout block."+    , "    -- However, the next block needs to be strictly more indented"+    , "    -- than the previous block."+    , ""+    , "  -- | Get the current confirmed indentation level."+    , "  definiteIndentation :: [Block] -> Int"+    , "  definiteIndentation bs ="+    , "    case dropWhile isTentative bs of"+    , "      Implicit _ Definitive n : _ -> n"+    , "      _ -> 0  -- 0 enables a first unindented block, see 194_layout/good05.in"+    , ""+    , "  isTentative :: Block -> Bool"+    , "  isTentative = \\case"+    , "    Implicit _ Tentative _ -> True"+    , "    _ -> False"+    , ""+    , "-- | Confirm tentative blocks that are not more indented than @col@."+    , "confirm :: Column -> [Block] -> [Block]"+    , "confirm c0 = loop"+    , "  where"+    , "  loop = \\case"+    , "    Implicit delim Tentative c : bs"+    , "      | c <= c0 -> Implicit delim Definitive c : loop bs"+    , "    bs -> bs"+    , ""+    , "-- | Get the position immediately to the right of the given token."+    , "--   If no token is given, gets the first position in the file."+    , "afterPrev :: Maybe Token -> Position"+    , "afterPrev = maybe (Pn 0 1 1) nextPos"+    , ""+    , "-- | Get the position immediately to the right of the given token."+    , "nextPos :: Token -> Position"+    , "nextPos t = Pn (g + s) l (c + s + 1)"+    , "  where"+    , "  Pn g l c = tokenPosn t"+    , "  s        = tokenLength t"+    , ""+    , "-- | Get the number of characters in the token."+    , "tokenLength :: Token -> Int"+    , "tokenLength = length . prToken"+    , ""+    , "-- | Create a position symbol token."+    , "sToken :: Position -> TokSymbol -> Token"+    , "sToken p t = PT p $ TK t"+    , ""+    , "-- | Get the line number of a token."+    , "line :: Token -> Line"+    , "line = fst . tokenLineCol"+    , ""+    , "-- | Get the column number of a token."+    , "column :: Token -> Column"+    , "column = snd . tokenLineCol"+    , ""+    , "-- | Is the following token on a new line?"+    , "newLine :: Maybe Token -> Token -> Bool"+    , "newLine pt t0 = maybe True ((line t0 >) . line) pt"+    , ""+    , "-- | Check if a word is a layout start token."+    , "isLayout :: Token -> Maybe LayoutDelimiters"+    , "isLayout = \\case"+    , "  PT _ (TK t) -> lookup t layoutWords"+    , "  _ -> Nothing"+    , ""+    , "-- | Check if a token is one of the given symbols."+    , "isTokenIn :: [TokSymbol] -> Token -> Bool"+    , "isTokenIn ts = \\case"+    , "  PT _ (TK t) -> t `elem` ts"+    , "  _ -> False"+    , ""+    , "-- | Check if a token is a layout stop token."+    , "isStop :: Token -> Bool"+    , "isStop = isTokenIn layoutStopWords"+    , ""+    , "-- | Check if a token is the layout open token."+    , "isLayoutOpen :: Token -> Bool"+    , "isLayoutOpen = isTokenIn layoutOpen"+    , ""+    , "-- | Check if a token is the layout separator token."+    , "isLayoutSep :: Token -> Bool"+    , "isLayoutSep = isTokenIn layoutSep"+    , ""+    , "-- | Check if a token is the layout close token."+    , "isLayoutClose :: Token -> Bool"+    , "isLayoutClose = isTokenIn layoutClose"+    ]   ]   where-    resws = sort $ reservedWords cf ++ cfgSymbols cf-    (top,lay,stop) = layoutPragmas cf+  (top0, lay0, stop0) = layoutPragmas cf+  top      = fmap mkTokSymbol top0+  topDelim = fmap (\ sep -> LayoutDelimiters sep Nothing Nothing) top+  lay      = for lay0 $ \ (kw, Delimiters sep open close) ->+    ( mkTokSymbol kw+    , LayoutDelimiters (mkTokSymbol sep) (Just $ mkTokSymbol open) (Just $ mkTokSymbol close)+    )+  stop = map mkTokSymbol stop0+  mkTokSymbol :: String -> TokSymbol+  mkTokSymbol x = TokSymbol x n+    where+    n = fromMaybe (-1) $ lookup x tokens+  tokens = cfTokens cf

@@ -38,15 +38,15 @@   -> String  -- ^ Name of created Haskell module.   -> AbsMod  -- ^ Name of Haskell module for abstract syntax.   -> CF      -- ^ Grammar.-  -> String-cf2Printer tokenText functor useGadt name absMod cf = unlines $ concat $-  -- Each of the following list entries is itself a list of lines-  [ prologue tokenText useGadt name [ absMod | importAbsMod ]+  -> Doc+cf2Printer tokenText functor useGadt name absMod cf = vcat $ concat $+  -- Each of the following list entries is itself a list of Docs+  [ prologue tokenText useGadt name [ absMod | importAbsMod ] cf   , integerRule absMod cf   , doubleRule absMod cf-  , if hasIdent cf then identRule absMod tokenText cf else []-  ] ++ [ ownPrintRule absMod tokenText cf own | (own,_) <- tokenPragmas cf ] ++-  [ rules absMod functor cf+  , when (hasIdent cf) $ identRule absMod tokenText cf+  , concat [ ownPrintRule absMod tokenText cf own | (own,_) <- tokenPragmas cf ]+  , rules absMod functor cf   ]   where   importAbsMod = not (null $ cf2data cf) || not (null $ specialCats cf)@@ -54,10 +54,10 @@ -- | Lowercase Haskell identifiers imported from ''Prelude''. lowerCaseImports :: [String] lowerCaseImports =-  [ "all", "dropWhile", "elem", "foldr", "id", "map", "null", "replicate", "shows", "span" ]+  [ "all", "elem", "foldr", "id", "map", "null", "replicate", "shows", "span" ] -prologue :: TokenText -> Bool -> String -> [AbsMod] -> [String]-prologue tokenText useGadt name absMod = concat+prologue :: TokenText -> Bool -> String -> [AbsMod] -> CF -> [Doc]+prologue tokenText useGadt name absMod cf = map text $ concat   [ [ "{-# LANGUAGE CPP #-}"     , "{-# LANGUAGE FlexibleInstances #-}"     , "{-# LANGUAGE LambdaCase #-}"@@ -86,7 +86,7 @@     , "import Data.Char ( Char, isSpace )"     ]   , fmap ("import qualified " ++) absMod  -- At most 1.  (Unnecessary if Abs module is empty.)-  , tokenTextImport tokenText+  , when (hasTextualTokens cf) $ tokenTextImport tokenText   , [ ""     , "-- | The top-level printing method."     , ""@@ -99,19 +99,48 @@     , "doc = (:)"     , ""     , "render :: Doc -> String"-    , "render d = rend 0 (map ($ \"\") $ d []) \"\" where"-    , "  rend i = \\case"-    , "    \"[\"      :ts -> showChar '[' . rend i ts"-    , "    \"(\"      :ts -> showChar '(' . rend i ts"-    , "    \"{\"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts"-    , "    \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts"-    , "    \"}\"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts"-    , "    [\";\"]        -> showChar ';'"-    , "    \";\"      :ts -> showChar ';' . new i . rend i ts"-    , "    t  : ts@(p:_) | closingOrPunctuation p -> showString t . rend i ts"-    , "    t        :ts -> space t . rend i ts"-    , "    _            -> id"-    , "  new i     = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace"+    , "render d = rend 0 False (map ($ \"\") $ d []) \"\""+    , "  where"+    , "  rend"+    , "    :: Int        -- ^ Indentation level."+    , "    -> Bool       -- ^ Pending indentation to be output before next character?"+    , "    -> [String]"+    , "    -> ShowS"+    , "  rend i p = \\case"+    , "      \"[\"      :ts -> char '[' . rend i False ts"+    , "      \"(\"      :ts -> char '(' . rend i False ts"+    , "      \"{\"      :ts -> onNewLine i     p . showChar   '{'  . new (i+1) ts"+    , "      \"}\" : \";\":ts -> onNewLine (i-1) p . showString \"};\" . new (i-1) ts"+    , "      \"}\"      :ts -> onNewLine (i-1) p . showChar   '}'  . new (i-1) ts"+    , "      [\";\"]        -> char ';'"+    , "      \";\"      :ts -> char ';' . new i ts"+    , "      t  : ts@(s:_) | closingOrPunctuation s"+    , "                   -> pending . showString t . rend i False ts"+    , "      t        :ts -> pending . space t      . rend i False ts"+    , "      []           -> id"+    , "    where"+    , "    -- Output character after pending indentation."+    , "    char :: Char -> ShowS"+    , "    char c = pending . showChar c"+    , ""+    , "    -- Output pending indentation."+    , "    pending :: ShowS"+    , "    pending = if p then indent i else id"+    , ""+    , "  -- Indentation (spaces) for given indentation level."+    , "  indent :: Int -> ShowS"+    , "  indent i = replicateS (2*i) (showChar ' ')"+    , ""+    , "  -- Continue rendering in new line with new indentation."+    , "  new :: Int -> [String] -> ShowS"+    , "  new j ts = showChar '\\n' . rend j True ts"+    , ""+    , "  -- Make sure we are on a fresh line."+    , "  onNewLine :: Int -> Bool -> ShowS"+    , "  onNewLine i p = (if p then id else showChar '\\n') . indent i"+    , ""+    , "  -- Separate given string from following text by a space (if needed)."+    , "  space :: String -> ShowS"     , "  space t s ="     , "    case (all isSpace t', null spc, null rest) of"     , "      (True , _   , True ) -> []              -- remove trailing space"@@ -145,16 +174,26 @@     , ""     , "class Print a where"     , "  prt :: Int -> a -> Doc"-    , "  prtList :: Int -> [a] -> Doc"-    , "  prtList i = concatD . map (prt i)"     , ""     , "instance {-# OVERLAPPABLE #-} Print a => Print [a] where"-    , "  prt = prtList"+    , "  prt i = concatD . map (prt i)"     , ""     , "instance Print Char where"-    , "  prt     _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')"-    , "  prtList _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')"+    , "  prt _ c = doc (showChar '\\'' . mkEsc '\\'' c . showChar '\\'')"     , ""+    ]+  , if haveListChar then+    [ "-- | No @instance 'Print' String@ because it would clash with the instance"+    , "--   for @[Char]@."+    ]+    else+    [ "instance Print String where"+    , "  prt _ = printString"+    , ""+    ]+  , [ "printString :: String -> Doc"+    , "printString s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')"+    , ""     , "mkEsc :: Char -> Char -> ShowS"     , "mkEsc q = \\case"     , "  s | s == q -> showChar '\\\\' . showChar s"@@ -168,21 +207,22 @@     , ""     ]   ]+  where+  haveListChar = not $ null $ rulesForCat cf $ ListCat $ TokenCat "Char"  -- | Printing instance for @Integer@, and possibly @[Integer]@.-integerRule :: AbsMod -> CF -> [String]+integerRule :: AbsMod -> CF -> [Doc] integerRule absMod cf = showsPrintRule absMod cf $ TokenCat catInteger  -- | Printing instance for @Double@, and possibly @[Double]@.-doubleRule :: AbsMod -> CF -> [String]+doubleRule :: AbsMod -> CF -> [Doc] doubleRule absMod cf = showsPrintRule absMod cf $ TokenCat catDouble -showsPrintRule :: AbsMod -> CF -> Cat -> [String]+showsPrintRule :: AbsMod -> CF -> Cat -> [Doc] showsPrintRule absMod cf t =-  [ unwords [ "instance Print" , qualifiedCat absMod t , "where" ]+  [ hsep [ "instance Print" , text (qualifiedCat absMod t) , "where" ]   , "  prt _ x = doc (shows x)"-  ] ++ ifList cf t ++-  [ ""+  , ""   ]  -- | Print category (data type name) qualified if user-defined.@@ -198,62 +238,69 @@   where   unqualified = catToStr t   qualified   = qualify absMod unqualified-  impossible  = error $ "impossible in Backend.Haskell.CFtoPrinter.qualifiedCat: " ++ show t+  impossible  = error $ "impossible in Backend.Haskell.CFtoPrinter.qualifiedCat: " ++ catToStr t  qualify :: AbsMod -> String -> String qualify absMod s = concat [ absMod, "." , s ]  -- | Printing instance for @Ident@, and possibly @[Ident]@.-identRule :: AbsMod -> TokenText -> CF -> [String]+identRule :: AbsMod -> TokenText -> CF -> [Doc] identRule absMod tokenText cf = ownPrintRule absMod tokenText cf catIdent  -- | Printing identifiers and terminals.-ownPrintRule :: AbsMod -> TokenText -> CF -> TokenCat -> [String]-ownPrintRule absMod tokenText cf own = concat-  [ [ "instance Print " ++ q ++ " where"-    , "  prt _ (" ++ q ++ posn ++ ") = doc $ showString " ++ tokenTextUnpack tokenText "i"-    ]-  , ifList cf (TokenCat own)-  , [ ""-    ]+ownPrintRule :: AbsMod -> TokenText -> CF -> TokenCat -> [Doc]+ownPrintRule absMod tokenText cf own =+  [ "instance Print" <+> q <+> "where"+  , "  prt _ (" <> q <+> posn <> ") = doc $ showString" <+> text (tokenTextUnpack tokenText "i")   ]  where-   q    = qualifiedCat absMod $ TokenCat own-   posn = if isPositionCat cf own then " (_,i)" else " i"+   q    = text $ qualifiedCat absMod $ TokenCat own+   posn = if isPositionCat cf own then "(_,i)" else "i"  -- | Printing rules for the AST nodes.-rules :: AbsMod -> Bool -> CF -> [String]+rules :: AbsMod -> Bool -> CF -> [Doc] rules absMod functor cf = do-    (cat, xs :: [(Fun, [Cat])]) <- cf2dataLists cf-    [ render (case_fun absMod functor cat (map (toArgs cat) xs)) ] ++ ifList cf cat ++ [ "" ]+  (cat, xs :: [ (Fun, [Cat]) ]) <- cf2dataLists cf+  concat $+    [ case_fun absMod functor cf cat $ map (toArgs cat) xs+    , [ "" ]+    ]   where     toArgs :: Cat -> (Fun, [Cat]) -> Rule     toArgs cat (cons, _) =-      case filter (\ (Rule f c _rhs _internal) -> cons == funName f && cat == normCat (wpThing c)) (cfgRules cf)+      case filter (\ (Rule f c _rhs _internal) ->+                        cons == funName f && cat == normCat (wpThing c))+                  (cfgRules cf)       of         (r : _) -> r         -- 2018-01-14:  Currently, there can be overlapping rules like         --   Foo. Bar ::= "foo" ;         --   Foo. Bar ::= "bar" ;         -- Of course, this will generate an arbitary printer for @Foo@.-        [] -> error $ "CFToPrinter.rules: no rhs found for: " ++ cons ++ ". " ++ show cat ++ " ::= ?"+        [] -> error $ "CFToPrinter.rules: no rhs found for: " ++ cons ++ ". " ++ catToStr cat ++ " ::= ?"  -- |--- >>> case_fun "Abs" False (Cat "A") [ (npRule "AA" (Cat "AB") [Right "xxx"]) Parsable ]+-- >>> vcat $ case_fun "Abs" False undefined (Cat "A") [ (npRule "AA" (Cat "AB") [Right "xxx"]) Parsable ] -- instance Print Abs.A where --   prt i = \case --     Abs.AA -> prPrec i 0 (concatD [doc (showString "xxx")])-case_fun :: AbsMod -> Bool -> Cat -> [Rule] -> Doc-case_fun absMod functor cat xs =-  -- trace ("case_fun: cat = " ++ show cat) $-  -- trace ("case_fun: xs  = " ++ show xs ) $-  vcat-    [ "instance Print" <+> type_ <+> "where"-    , nest 2 $ if isList cat then "prt = prtList" else vcat+case_fun :: AbsMod -> Bool -> CF -> Cat -> [Rule] -> [Doc]+case_fun absMod functor cf cat rules =+  -- trace ("case_fun: cat   = " ++ catToStr cat) $+  -- trace ("case_fun: rules = " ++ show rules ) $+  [ "instance Print" <+> type_ <+> "where"+  , nest 2 $ vcat $++      -- Special printing of lists (precedence changes concrete syntax!)+      if isList cat then+        map mkPrtListCase $ List.sortBy compareRules $ rulesForNormalizedCat cf cat++      -- Ordinary category+      else         [ "prt i = \\case"-        , nest 2 $ vcat (map (mkPrintCase absMod functor) xs)+        , nest 2 $ vcat $ map (mkPrintCase absMod functor) rules         ]-    ]+  ]   where     type_      | functor   = case cat of@@ -296,6 +343,7 @@   where     pat :: Doc     pat+      | isNilFun  f = text "[]"       | isOneFun  f = text "[" <+> head variables <+> "]"       | isConsFun f = hsep $ List.intersperse (text ":") variables       | otherwise   = text (qualify absMod $ funName f) <+> (if functor then "_" else empty) <+> hsep variables@@ -317,45 +365,33 @@     var (TokenCat "String")  = "str"     var (TokenCat "Char")    = "c"     var (TokenCat "Double")  = "d"-    var xs = map toLower $ show xs--ifList :: CF -> Cat -> [String]-ifList cf cat =-    -- trace ("ifList cf    = " ++ show cf   ) $-    -- trace ("ifList cat   = " ++ show cat  ) $-    -- trace ("ifList rules = " ++ show rules) $-    -- trace ("ifList rulesForCat' cf (ListCat cat) = " ++ show (rulesForCat' cf (ListCat cat))) $-    -- trace "" $-    map (render . nest 2) cases-  where-    rules = List.sortBy compareRules $ rulesForNormalizedCat cf (ListCat cat)-    cases = [ mkPrtListCase r | r <- rules ]+    var xs = map toLower $ catToStr xs  -- | Pattern match on the list constructor and the coercion level -- -- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)--- prtList _ [] = concatD []+-- prt _ [] = concatD [] -- -- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")] Parsable)--- prtList _ [x] = concatD [prt 0 x]+-- prt _ [x] = concatD [prt 0 x] -- -- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)--- prtList _ (x:xs) = concatD [prt 0 x, prt 0 xs]+-- prt _ (x:xs) = concatD [prt 0 x, prt 0 xs] -- -- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)--- prtList 2 [] = concatD []+-- prt 2 [] = concatD [] -- -- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)--- prtList 2 [x] = concatD [prt 2 x]+-- prt 2 [x] = concatD [prt 2 x] -- -- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)--- prtList 2 (x:xs) = concatD [prt 2 x, prt 2 xs]+-- prt 2 (x:xs) = concatD [prt 2 x, prt 2 xs] -- mkPrtListCase :: Rule -> Doc mkPrtListCase (Rule f (WithPosition _ (ListCat c)) rhs _internal)-  | isNilFun f = "prtList" <+> precPattern <+> "[]" <+> "=" <+> body-  | isOneFun f = "prtList" <+> precPattern <+> "[x]" <+> "=" <+> body-  | isConsFun f = "prtList" <+> precPattern <+> "(x:xs)" <+> "=" <+> body+  | 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@@ -371,7 +407,7 @@ -- -- - [] < [_] < _:_ ----- This is desiged to correctly order the rules in the prtList function so that+-- This is desiged to correctly order the rules in the prt function for lists so that -- the pattern matching works as expectd. -- -- >>> compareRules (npRule "[]" (ListCat (CoercCat "Foo" 3)) [] Parsable) (npRule "[]" (ListCat (CoercCat "Foo" 1)) [] Parsable)@@ -424,4 +460,5 @@   mk (arg:args) (Left c  : items)    = (prt c <+> text arg) : mk args items   mk args       (Right s : items)    = ("doc (showString" <+> text (show s) <> ")") : mk args items   mk _          _                    = []+  prt (TokenCat "String") = "printString"   prt c = "prt" <+> integer (precCat c)

@@ -72,7 +72,7 @@                   | otherwise = empty     type_ = qualify $ cat' <> iffunctor "' a"     fname = "trans" <> cat'-    cat' =  text (show cat)+    cat' = pretty cat     mkOne (cons, args) =         let ns = catvars [render fname] args -- names False (map (checkRes .var) args) 1         in  qualify (text cons) <+> iffunctor "_" <+> hsep ns <+> "-> failure x"

@@ -247,4 +247,4 @@ catvars rs = map text . mkNames (rs ++ hsReservedWords) LowerCase . map var   where     var (ListCat c) = var c ++ "s"-    var xs          = show xs+    var c           = catToStr c

@@ -49,10 +49,10 @@     mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod cf     mkfile (printerFile opts)  $ cf2Printer StringToken False True prMod absMod cf     when (hasLayout cf) $ mkfile (layoutFile opts) $-      cf2Layout (tokenText opts) layMod lexMod cf+      cf2Layout layMod lexMod cf     mkfile (tFile opts)        $ Haskell.testfile opts cf     mkfile (errFile opts) $ mkErrM errMod-    Makefile.mkMakefile opts $ Haskell.makefile opts+    Makefile.mkMakefile opts $ Haskell.makefile opts cf     case xml opts of       2 -> makeXML opts True cf       1 -> makeXML opts False cf

@@ -20,23 +20,32 @@  cf2Abstract :: TokenText -> String -> CF -> String -> String cf2Abstract tokenText name cf composOpMod = unlines $ concat $-  [ [ "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}"-    , "{-# LANGUAGE EmptyCase #-}"-    , "{-# LANGUAGE LambdaCase #-}"+  [ [ "-- Haskell module generated by the BNF converter"+    , "-- For GHC version 7.10 or higher"     , ""+    , "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}"+    ]+  , [ "{-# LANGUAGE EmptyCase #-}" | emptyTree ]+  , [ "{-# LANGUAGE LambdaCase #-}"+    , ""+    , "{-# OPTIONS_GHC -fno-warn-unused-binds #-}"+      -- unused-local-binds would be sufficient, but parses only from GHC 8.0     , "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"+    , "{-# OPTIONS_GHC -fno-warn-unused-matches #-}"+    , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"+      -- defects of coverage checker, e.g. in 8.2.2, may lead to warning+      -- about exceeded iterations for pattern match checker     , "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}"     , ""     , "module" +++ name +++ "(" ++ List.intercalate ", " exports ++ ")" +++ "where"     , ""     , "import Prelude (" ++ typeImports ++ ", (.), (>), (&&), (==))"     , "import qualified Prelude as P"-    , ""-    , "import " ++ composOpMod+    -- , "import qualified Data.Kind as K (Type)"     ]   , tokenTextImport tokenText   , [ ""-    , "-- Haskell module generated by the BNF converter"+    , "import " ++ composOpMod     , ""     ]   , prDummyTypes cf@@ -54,8 +63,9 @@   , map ((++ "\n") . show) $ definedRules False cf   ]   where+    emptyTree = null (cf2cons cf)     exports = concat $-      [ [ "Tree(..)" ]+      [ [ if emptyTree then "Tree" else "Tree(..)" ]       , getTreeCats cf       , map mkDefName $ getDefinitions cf       , [ "johnMajorEq"@@ -69,10 +79,10 @@       ]  getTreeCats :: CF -> [String]-getTreeCats cf = List.nub $ map show $ filter (not . isList) $ map consCat $ cf2cons cf+getTreeCats cf = List.nub $ map catToStr $ filter (not . isList) $ map consCat $ cf2cons cf  getDefinitions :: CF -> [String]-getDefinitions cf = [ funName f | FunDef f _ _ <- cfgPragmas cf ]+getDefinitions = map (funName . defName) . definitions  prDummyTypes :: CF -> [String] prDummyTypes cf = prDummyData : map prDummyType cats@@ -97,13 +107,13 @@  prTreeType :: TokenText -> CF -> [String] prTreeType tokenText cf =-  "data Tree :: Tag -> * where" : map (("    " ++) . prTreeCons) (cf2cons cf)+  "data Tree (a :: Tag) where" : map (("    " ++) . prTreeCons) (cf2cons cf)   where   prTreeCons c       | TokenCat tok <- cat, isPositionCat cf tok =           fun +++ ":: ((Int,Int),"++ tokenTextType tokenText ++") -> Tree" +++ mkRealType tok       | otherwise =-          fun +++ "::" +++ concat [show c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType (show cat)+          fun +++ "::" +++ concat [catToStr c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType (catToStr cat)     where     (cat,fun) = (consCat c, consFun c) @@ -126,11 +136,11 @@  prShow :: CF -> [String] prShow cf = ["instance P.Show (Tree c) where",-              "  showsPrec n t = case t of"]+              "  showsPrec n = \\case"]               ++ map (("    "++) .prShowCons) cs-              ++ ["   where",-                  "   opar = if n > 0 then P.showChar '(' else P.id",-                  "   cpar = if n > 0 then P.showChar ')' else P.id"]+              ++ ["    where",+                  "    opar = if n > 0 then P.showChar '(' else P.id",+                  "    cpar = if n > 0 then P.showChar ')' else P.id"]   where     cs = cf2cons cf     prShowCons c | null vars = fun +++ "->" +++ "P.showString" +++ show fun

@@ -46,11 +46,13 @@   where   prCatTrans :: Cat -> [Constructor] -> [String]   prCatTrans cat cs = concat-    [ [ "trans" ++ show cat +++ "::" +++ qualify (show cat) +++ "-> Result"-      , "trans" ++ show cat +++ "t = case t of"+    [ [ "trans" ++ s +++ "::" +++ qualify s +++ "-> Result"+      , "trans" ++ s +++ "t = case t of"       ]     , map prConsCase cs     ]+    where+    s = catToStr cat    prConsCase :: Constructor -> String   prConsCase c =

@@ -25,7 +25,7 @@  import Prelude hiding ((<>)) -import System.FilePath (pathSeparator, isPathSeparator)+import System.FilePath ((</>), (<.>), pathSeparator, isPathSeparator) import Data.Foldable (toList) import Data.List ( intersperse ) @@ -66,7 +66,7 @@         packageAbsyn = packageBase +.+ "Absyn"         dirBase      = pkgToDir packageBase         dirAbsyn     = pkgToDir packageAbsyn-        javaex str   = dirBase ++ str +.+ "java"+        javaex str   = dirBase </> str <.> "java"         bnfcfiles    =           bnfcVisitorsAndTests             packageBase@@ -85,12 +85,9 @@         makebnfcfile x = mkfile (javaex (fst $ x bnfcfiles))                                         (snd $ x bnfcfiles) -    let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf rp-        absynBaseNames = map fst absynFiles-        absynFileNames = map (dirAbsyn ++) absynBaseNames-    let writeAbsyn (filename, contents) =-          mkfile (dirAbsyn ++ filename ++ ".java") contents-    mapM_ writeAbsyn absynFiles+    let absynFiles = remDups $ cf2JavaAbs dirAbsyn packageBase packageAbsyn cf rp+        absynFileNames = map fst absynFiles+    mapM_ (\ (n, s) -> mkfile (n <.> "java") s) absynFiles     makebnfcfile bprettyprinter     makebnfcfile bskel     makebnfcfile bcompos@@ -100,16 +97,16 @@     makebnfcfile btest     let (lex, env) = lexfun packageBase cf     -- Where the lexer file is created. lex is the content!-    mkfile (dirBase ++ inputfile lexmake ) lex+    mkfile (dirBase </> inputfile lexmake ) lex     liftIO $ putStrLn $ "   (Tested with" +++ toolname lexmake                                           +++ toolversion lexmake  ++ ")"     -- where the parser file is created.-    mkfile (dirBase ++ inputfile parmake)+    mkfile (dirBase </> inputfile parmake)           $ parsefun packageBase packageAbsyn cf rp env     liftIO $ putStrLn $       if supportsEntryPoints parmake        then "(Parser created for all categories)"-       else "   (Parser created only for category " ++ show (firstEntry cf) ++ ")"+       else "   (Parser created only for category " ++ prettyShow (firstEntry cf) ++ ")"     liftIO $ putStrLn $ "   (Tested with"  +++ toolname parmake                                            +++ toolversion parmake ++ ")"     Makefile.mkMakefile options $@@ -120,7 +117,7 @@                            Just {} -> remDups as                            Nothing -> (a, b) : remDups as     pkgToDir :: String -> FilePath-    pkgToDir s = replace '.' pathSeparator s ++ [pathSeparator]+    pkgToDir = replace '.' pathSeparator      parselexspec = parserLexerSelector lang javaLexerParser rp     lexfun       = cf2lex $ lexer parselexspec@@ -152,41 +149,41 @@                 ]++     [-- running the lexergen: output of lexer -> input of lexer : calls lexer     let ff = filename lexmake -- name of input file without extension-        dirBaseff = dirBase ++ ff -- prepend directory-        inp = dirBase ++ inputfile lexmake in-        Makefile.mkRule (dirBaseff +.+ "java") [ inp ]+        dirBaseff = dirBase </> ff -- prepend directory+        inp = dirBase </> inputfile lexmake in+        Makefile.mkRule (dirBaseff <.> "java") [ inp ]         [ "${LEXER} ${LEXER_FLAGS} "++ inp ]      -- running the parsergen, these there are its outputs     -- output of parser -> input of parser : calls parser-  , let inp = dirBase ++ inputfile parmake in-        Makefile.mkRule (unwords (map (dirBase++) (dotJava $ results parmake)))+  , let inp = dirBase </> inputfile parmake in+        Makefile.mkRule (unwords (map (dirBase </>) (dotJava $ results parmake)))           [ inp ] $           ("${PARSER} ${PARSER_FLAGS} " ++ inp) :-          ["mv " ++ unwords (dotJava $ results parmake) +++ dirBase+          ["mv " ++ unwords (dotJava $ results parmake) +++ dirBase ++ [pathSeparator]               | moveresults parmake]   -- Class of the output of lexer generator wants java of :   -- output of lexer and parser generator-  , let lexerOutClass = dirBase ++ filename lexmake +.+ "class"-        outname x = dirBase ++ x +.+ "java"+  , let lexerOutClass = dirBase </> filename lexmake <.> "class"+        outname x = dirBase </> x <.> "java"         deps = map outname (results lexmake ++ results parmake) in         Makefile.mkRule lexerOutClass deps []     ]++   reverse [Makefile.mkRule tar dep [] |     (tar,dep) <- partialParserGoals dirBase (results parmake)]-  ++[ Makefile.mkRule (dirBase ++ "PrettyPrinter.class")-        [ dirBase ++ "PrettyPrinter.java" ] []+  ++[ Makefile.mkRule (dirBase </> "PrettyPrinter.class")+        [ dirBase </> "PrettyPrinter.java" ] []     -- Removes all the class files created anywhere-    , Makefile.mkRule "clean" [] [ "rm -f " ++ dirAbsyn ++ "*.class" ++ " "-                                            ++ dirBase ++ "*.class" ]+    , Makefile.mkRule "clean" [] [ "rm -f " ++ dirAbsyn </> "*.class" ++ " "+                                            ++ dirBase </> "*.class" ]     -- Remains the same     , Makefile.mkRule "distclean" [ "vclean" ] []     -- removes everything     , Makefile.mkRule "vclean" []         [ " rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass-        , " rm -f " ++ dirAbsyn ++ "*.class"+        , " rm -f " ++ dirAbsyn </> "*.class"         , " rmdir " ++ dirAbsyn-        , " rm -f " ++ unwords (map (dirBase ++) $+        , " rm -f " ++ unwords (map (dirBase </>) $                     [ inputfile lexmake                     , inputfile parmake                     ]@@ -215,7 +212,7 @@       lexmake           = makelexerdetails (lexer jlexpar)       absynJavaSrc      = unwords (dotJava absynFileNames)       absynJavaClass    = unwords (dotClass absynFileNames)-      classes = prependPath dirBase lst+      classes = map (dirBase </>) lst       lst = dotClass (results lexmake) ++ [ "PrettyPrinter.class", "Test.class"           , "VisitSkel.class"           , "ComposVisitor.class", "AbstractVisitor.class"@@ -479,9 +476,8 @@ antlrmakedetails :: String -> MakeFileDetails antlrmakedetails l = MakeDetails     { executable = runJava "org.antlr.v4.Tool"-    , flags               = \x -> unwords $-                                    let path    = take (length x - 1) x-                                        pointed = map cnv path+    , flags               = \ path -> unwords $+                                    let pointed = map cnv path                                         cnv y   = if isPathSeparator y                                                         then '.'                                                         else y@@ -502,13 +498,9 @@     , moveresults         = False     } -prependPath , appendExtension :: String -> [String] -> [String]-prependPath s fi     = [ s ++ x  | x <- fi ]-appendExtension s fi = [ x +.+ s | x <- fi ]--dotJava,dotClass :: [String] -> [String]-dotJava  = appendExtension "java"-dotClass = appendExtension "class"+dotJava, dotClass :: [String] -> [String]+dotJava  = map (<.> "java")+dotClass = map (<.> "class")  type CFToJava = String -> String -> CF -> String @@ -540,16 +532,16 @@     }   where app x = x pbase pabsyn cf -inputfile x = filename x ++ case fileextension x of-                                "" -> ""-                                a -> '.':a+inputfile x+  | null (fileextension x) = filename x+  | otherwise              = filename x <.> fileextension x  -- |  constructs the rules regarding the parser in the makefile partialParserGoals :: String -> [String] -> [(String, [String])] partialParserGoals _ []          = []-partialParserGoals dbas (x:rest) =-    (dbas ++ x +.+ "class", map (\ y -> dbas ++ y +.+ "java") (x:rest))-        : partialParserGoals dbas rest+partialParserGoals dirBase (x:rest) =+    (dirBase </> x <.> "class", map (\ y -> dirBase </> y <.> "java") (x:rest))+        : partialParserGoals dirBase rest  -- | Creates the Test.java class. javaTest :: JavaTestParams -> TestClass

@@ -25,7 +25,6 @@  import BNFC.Backend.Java.Utils import BNFC.Backend.Common.NamedVariables-import BNFC.Backend.Java.CFtoCup15 ( definedRules )  -- Type declarations @@ -51,10 +50,6 @@ cf2AntlrParse packageBase packageAbsyn cf _ env = unlines $ concat   [ [ header     , tokens-    , "@members {"-    ]-  , map ("  " ++) $ definedRules packageAbsyn cf-  , [ "}"     , ""     -- Generate start rules [#272]     -- _X returns [ dX result ] : x=X EOF { $result = $x.result; }@@ -131,11 +126,12 @@     | isConsFun f = "$result = " ++ p_2 ++ "; "                            ++ "$result." ++ add ++ "(" ++ p_1 ++ ");"     | isCoercion f = "$result = " ++  p_1 ++ ";"-    | isDefinedRule f = "$result = " ++ funName f ++ "_"+    | isDefinedRule f = "$result = " ++ packageAbsyn ++ "Def." ++ sanitize (funName f)                         ++ "(" ++ intercalate "," (map resultvalue ms) ++ ");"     | otherwise = "$result = new " ++ c                   ++ "(" ++ intercalate "," (map resultvalue ms) ++ ");"    where+     sanitize          = getRuleName      c                 = packageAbsyn ++ "." ++                             if isNilFun f || isOneFun f || isConsFun f                             then identCat (normCat nt) else funName f

@@ -14,18 +14,19 @@  -} -module BNFC.Backend.Java.CFtoCup15 ( cf2Cup, definedRules ) where+module BNFC.Backend.Java.CFtoCup15 ( cf2Cup ) where +import Data.Char+import Data.List (intercalate)+ import BNFC.CF-import Data.List-import BNFC.Backend.Common.NamedVariables-import BNFC.Backend.Java.CFtoJavaAbs15 (typename) import BNFC.Options (RecordPositions(..)) import BNFC.Utils ( (+++) )-import BNFC.TypeChecker  -- We need to (re-)typecheck to figure out list instances in-                    -- defined rules.-import Data.Char +import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.Java.CFtoJavaAbs15    ( typename )+import BNFC.Backend.Java.Utils            ( getRuleName )+ type Rules   = [(NonTerminal,[(Pattern,Action)])] type Pattern = String type Action  = String@@ -61,9 +62,6 @@       , ":}"       , "parser code {:"       , parseMethod packageAbsyn (firstEntry cf)-      , "public <B,A extends java.util.LinkedList<? super B>> "-        ++ "A cons_(B x, A xs) { xs.addFirst(x); return xs; }"-      , unlines $ definedRules packageAbsyn cf       , "public void syntax_error(java_cup.runtime.Symbol cur_token)"       , "{"       , "  report_error(\"Syntax Error, trying to recover and continue"@@ -79,56 +77,7 @@       , ":}"       ] -definedRules :: String -> CF -> [String]-definedRules packageAbsyn cf =-    concat [ rule f xs e | FunDef f xs e <- cfgPragmas cf ]-  where-    ctx = buildContext cf -    list = LC (\ t -> "List" ++ unBase t) (const "cons")-      where-         unBase (ListT t) = unBase t-         unBase (BaseT x) = show $ normCat $ strToCat x--    rule f xs e =-        case runTypeChecker $ checkDefinition' list ctx f xs e of-            Left err ->-                error $ "Panic! This should have been caught already:\n"-                    ++ err-            Right (args,(e',t)) ->-                [ "public " ++ javaType t ++ " " ++ funName f ++ "_ (" ++-                    intercalate ", " (map javaArg args) ++ ") {"-                , "  return " ++ javaExp e' ++ ";"-                , "}"-                ]-     where--       javaType :: Base -> String-       javaType (ListT (BaseT x)) = packageAbsyn ++ ".List"-                                   ++ catToStr (normCat $ strToCat x)-       javaType (ListT t)         = javaType t-       javaType (BaseT x)         = typename packageAbsyn (ctxTokens ctx) $-                                      catToStr $ normCat $ strToCat x--       javaArg :: (String, Base) -> String-       javaArg (x,t) = javaType t ++ " " ++ x ++ "_"--       javaExp :: Exp -> String-       javaExp (App "null" []) = "null"-       javaExp (Var x)         = x ++ "_"      -- argument-       javaExp (App t [e])-           | isToken t ctx     = call "new String" [e]-       javaExp (App x es)-           | isUpper (head x)  = call ("new " ++ packageAbsyn ++ "." ++ x) es-           | otherwise         = call (x ++ "_") es-       javaExp (LitInt n)      = "new Integer(" ++ show n ++ ")"-       javaExp (LitDouble x)   = "new Double(" ++ show x ++ ")"-       javaExp (LitChar c)     = "new Character(" ++ show c ++ ")"-       javaExp (LitString s)   = "new String(" ++ show s ++ ")"--       call x es = x ++ "(" ++ intercalate ", " (map javaExp es) ++ ")"-- -- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. prEntryPoint :: CF -> String prEntryPoint cf = unlines ["", "start with " ++ identCat (firstEntry cf) ++ ";", ""]@@ -212,11 +161,12 @@     | isConsFun f     = "RESULT = " ++ p_2 ++ "; "                            ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");"     | isCoercion f    = "RESULT = " ++ p_1 ++ ";"-    | isDefinedRule f = "RESULT = parser." ++ f ++ "_"+    | isDefinedRule f = "RESULT = " ++ packageAbsyn ++ "Def." ++ sanitize f                         ++ "(" ++ intercalate "," ms ++ ");"     | otherwise       = "RESULT = new " ++ c                   ++ "(" ++ intercalate "," ms ++ ");" ++ lineInfo    where+     sanitize = getRuleName      f   = funName fun      c   = packageAbsyn ++ "." ++            if isNilFun f || isOneFun f || isConsFun f

@@ -24,17 +24,22 @@  module BNFC.Backend.Java.CFtoJavaAbs15 (cf2JavaAbs, typename, cat2JavaType) where +import Data.Bifunctor  ( first )+import Data.Char       ( isUpper, toLower )+import Data.Function   ( on )+import Data.List       ( findIndices, intercalate )+import Data.Maybe      ( mapMaybe )+import System.FilePath ( (<.>), (</>) )+import Text.PrettyPrint as P+ import BNFC.CF-import BNFC.Options (RecordPositions(..))-import BNFC.Utils((+++),(++++))-import BNFC.Backend.Common.NamedVariables hiding (IVar, getVars, varName)-import Data.Function (on)-import Data.List-import Data.Char(toLower)-import Data.Maybe (mapMaybe)-import Text.PrettyPrint-import qualified Text.PrettyPrint as P+import BNFC.Options     ( RecordPositions(..) )+import BNFC.TypeChecker ( buildContext, ctxTokens, isToken )+import BNFC.Utils       ( (+++), (++++), uncurry3, unless ) +import BNFC.Backend.Common.NamedVariables ( UserDef, showNum )+import BNFC.Backend.Java.Utils            ( getRuleName )+ --Produces abstract data types in Java. --These follow Appel's "non-object oriented" version. --They also allow users to use the Visitor design pattern.@@ -44,17 +49,85 @@ --   a number unique to that type, --   and an optional name (handles typedefs). --- | The result is a list of files which must be written to disk.+-- | The result is a list of files (without file extension)+--   which must be written to disk. --   The tuple is (FileName, FileContents) -cf2JavaAbs :: String -> String -> CF -> RecordPositions -> [(FilePath, String)]-cf2JavaAbs _ packageAbsyn cf rp =-    concatMap (prData rp header packageAbsyn user) rules- where+cf2JavaAbs :: FilePath  -- ^ Directory for AST without trailing 'pathSeparator'.+  -> String -> String -> CF -> RecordPositions -> [(FilePath, String)]+cf2JavaAbs dirAbsyn packageBase packageAbsyn cf rp = concat+  [ unless (null defs)+    [ (dirAbsyn ++ "Def", unlines deftext) ]+  , map (first mkPath) $ concatMap (prData rp header packageAbsyn user) rules+  ]+  where   header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n"-  user = [n | (n,_) <- tokenPragmas cf]-  rules = getAbstractSyntax cf+  user   = [ n | (n,_) <- tokenPragmas cf ]+  rules  = getAbstractSyntax cf+  defs   = definitions cf+  deftext= concat+   [ [ "package " ++ packageBase ++ "; // Java Package generated by the BNF Converter."+     , ""+     , "public class AbsynDef {"+     , ""+     , "  public static <B,A extends java.util.LinkedList<? super B>> A cons(B x, A xs) {"+     , "    xs.addFirst(x);"+     , "    return xs;"+     , "  }"+     , ""+     ]+   , definedRules defs packageAbsyn cf+   , [ "}"]+   ]+  mkPath :: String -> FilePath+  mkPath s = dirAbsyn </> s +definedRules :: [Define] -> String -> CF -> [String]+definedRules defs packageAbsyn cf = map rule defs+  where+    ctx = buildContext cf++    rule (Define f args e t) =+        unlines $ map ("  " ++) $+                [ "public static " ++ javaType t ++ " " ++ sanitize (funName f) ++ "(" +++                    intercalate ", " (map javaArg args) ++ ") {"+                , "  return " ++ javaExp (map fst args) e ++ ";"+                , "}"+                ]+     where+       sanitize = getRuleName++       javaType :: Base -> String+       javaType = \case+           ListT (BaseT x) -> concat [ packageAbsyn, ".List", x ]+           BaseT x         -> typename packageAbsyn (ctxTokens ctx) x+           -- ListT t         -> javaType t -- undefined++       javaArg :: (String, Base) -> String+       javaArg (x,t) = javaType t ++ " " ++ x++       javaExp :: [String] -> Exp -> String+       javaExp args = \case+           Var x                -> x      -- argument+           App "[]" (FunT _ t) []+                                -> callQ (identType t) []+           App "(:)" _ es       -> call "cons" es+           App t _ [e]+             | isToken t ctx    -> javaExp args e     -- wraps new String+           App x _ es+             | isUpper (head x) -> callQ x es+             | otherwise        -> call (sanitize x) es+            -- -- | x `elem` args    -> call x es+           LitInt n             -> "new Integer(" ++ show n ++ ")"+           LitDouble x          -> "new Double(" ++ show x ++ ")"+           LitChar c            -> "new Character(" ++ show c ++ ")"+           LitString s          -> "new String(" ++ show s ++ ")"+         where+         call x es = x ++ "(" ++ intercalate ", " (map (javaExp args) es) ++ ")"+         callQ     = call . qualify+         qualify x = "new " ++ packageAbsyn ++ "." ++ x++ -- | Generates a (possibly abstract) category class, and classes for all its rules.  prData :: RecordPositions -> String -> String -> [UserDef] -> Data ->[(String, String)]@@ -63,8 +136,8 @@       where       funs = map fst rules       categoryClass-          | show cat `elem` funs = [] -- the catgory is also a function, skip abstract class-          | otherwise = [(identCat cat, header +++++          | catToStr cat `elem` funs = [] -- the catgory is also a function, skip abstract class+          | otherwise = [(cls, header ++++                          unlines [                                   "public abstract class" +++ cls                                     +++ "implements java.io.Serializable {",@@ -115,14 +188,14 @@    where      vs = getVars cats user      fun' = identCat (normCat c)-     isAlsoCategory = fun == show c+     isAlsoCategory = fun == catToStr c      --This handles the case where a LBNF label is the same as the category.      ext = if isAlsoCategory then "" else " extends" +++ identCat c  -- | The standard accept function for the Visitor pattern.  prAccept :: String -> Cat -> String -> String-prAccept pack cat _ = "\n  public <R,A> R accept(" ++ pack ++ "." ++ show cat+prAccept pack cat _ = "\n  public <R,A> R accept(" ++ pack ++ "." ++ catToStr cat                       ++ ".Visitor<R,A> v, A arg) { return v.visit(this, arg); }\n"  -- | Creates the equals() method.

@@ -29,17 +29,20 @@  import Prelude hiding ((<>)) -import BNFC.Backend.Java.CFtoJavaAbs15+import Data.Bifunctor ( second )+import Data.Char      ( toLower, isSpace )+import Data.Either    ( lefts )+import Data.List      ( intersperse )+import Data.Maybe     ( isJust )  import BNFC.CF-import BNFC.Backend.Common (renderListSepByPrecedence)-import BNFC.Backend.Common.NamedVariables-import BNFC.Utils ( (+++) )-import Data.List-import Data.Char ( toLower, isSpace )-import Data.Either (lefts) import BNFC.PrettyPrint+import BNFC.Utils     ( (+++), for, unless, unlessNull, uniqOn ) +import BNFC.Backend.Common ( switchByPrecedence )+import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.Java.CFtoJavaAbs15+ --Produces the PrettyPrinter class. --It will generate two methods "print" and "show" --print is the actual pretty printer for linearization.@@ -81,7 +84,9 @@       "  private static void sh(Double d) { render(String.format(java.util.Locale.ROOT, \"%.15g\", d)); }",       "  private static void sh(Character c) { render(\"'\" + c.toString() + \"'\"); }",       "  private static void sh(String s) { printQuoted(s); }",+      "",       "  private static void printQuoted(String s) { render(\"\\\"\" + s + \"\\\"\"); }",+      "",       "  private static void indent()",       "  {",       "    int n = _n_;",@@ -91,12 +96,14 @@       "      n--;",       "    }",       "  }",+      "",       "  private static void backup()",       "  {",       "    int prev = buf_.length() - 1;",-      "    if (buf_.charAt(prev) == ' ')",+      "    if (prev >= 0 && buf_.charAt(prev) == ' ')",       "      buf_.setLength(prev);",       "  }",+      "",       "  private static void trim()",       "  {",       "    // Trim initial spaces",@@ -106,11 +113,33 @@       "      end++; ",       "    buf_.delete(0, end);",       "    // Trim trailing spaces",-      "    end = buf_.length();",+      "    removeTrailingSpaces();",+      "  }",+      "",+      "  private static void removeTrailingSpaces()",+      "  {",+      "    int end = buf_.length();",       "    while (end > 0 && buf_.charAt(end-1) == ' ')",-      "      end--; ",+      "      end--;",       "    buf_.setLength(end);",       "  }",+      "",+      "  private static void removeTrailingWhitespace()",+      "  {",+      "    int end = buf_.length();",+      "    while (end > 0 && (buf_.charAt(end-1) == ' ' || buf_.charAt(end-1) == '\\n'))",+      "      end--;",+      "    buf_.setLength(end);",+      "  }",+      "",+      "  private static void onEmptyLine()",+      "  {",+      "    removeTrailingSpaces();",+      "    int len = buf_.length();",+      "    if (len > 0 && buf_.charAt(len-1) != '\\n') buf_.append(\"\\n\");",+      "    indent();",+      "  }",+      "",       "  private static int _n_ = 0;",       "  private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);",       "}"@@ -125,8 +154,7 @@       "  {",       "    if (s.equals(\"{\"))",       "    {",-      "       buf_.append(\"\\n\");",-      "       indent();",+      "       onEmptyLine();",       "       buf_.append(s);",       "       _n_ = _n_ + INDENT_WIDTH;",       "       buf_.append(\"\\n\");",@@ -136,30 +164,27 @@       "       buf_.append(s);",       "    else if (s.equals(\")\") || s.equals(\"]\"))",       "    {",-      "       backup();",+      "       removeTrailingWhitespace();",       "       buf_.append(s);",       "       buf_.append(\" \");",       "    }",       "    else if (s.equals(\"}\"))",       "    {",-      "       int t;",       "       _n_ = _n_ - INDENT_WIDTH;",-      "       for(t=0; t<INDENT_WIDTH; t++) {",-      "         backup();",-      "       }",+      "       onEmptyLine();",       "       buf_.append(s);",       "       buf_.append(\"\\n\");",       "       indent();",       "    }",       "    else if (s.equals(\",\"))",       "    {",-      "       backup();",+      "       removeTrailingWhitespace();",       "       buf_.append(s);",       "       buf_.append(\" \");",       "    }",       "    else if (s.equals(\";\"))",       "    {",-      "       backup();",+      "       removeTrailingWhitespace();",       "       buf_.append(s);",       "       buf_.append(\"\\n\");",       "       indent();",@@ -206,24 +231,33 @@     cat' = identCat cat  prData :: String ->  [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = unlines k-    where-      k = if isList cat-           then-           ["  private static void pp(" ++ packageAbsyn ++ "."-                ++ identCat (normCat cat) +++ "foo, int _i_)"-            , "  {"-            , render $ nest 5 $ prList packageAbsyn user cat rules <> "  }"-           ]-           else --not a list-           [-            "  private static void pp(" ++ packageAbsyn ++ "."-                ++ identCat (normCat cat) +++ "foo, int _i_)",-            "  {",-            concat (addElse $ map (prRule packageAbsyn) rules) ++ "  }"-           ]-      addElse = map ("    "++). intersperse "else " . filter (not . null)-        . map (dropWhile isSpace)+prData packageAbsyn user (cat, rules)+  | isList cat = unlines $ concat+      [ [ "  private static void pp(" ++ packageAbsyn ++ "." ++ dat ++ " foo, int _i_)"+        , "  {"+        , "    pp" ++ dat ++ "(foo.iterator(), _i_);"+        , "  }"+        , ""+        , "  private static void pp" ++ dat ++ "(java.util.Iterator<" ++ et ++ "> it, int _i_)"+        , "  {"+        ]+      , map ("    " ++) $ prList dat et rules+      , [ "  }"+        , ""+        ]+      ]+  | otherwise = unlines $+      [ "  private static void pp(" ++ packageAbsyn ++ "."+           ++ dat +++ "foo, int _i_)"+      , "  {"+      , concat (addElse $ map (prRule packageAbsyn) rules)+      , "  }"+      ]+  where+  dat = identCat (normCat cat)+  et  = typename packageAbsyn user $ identCat $ normCatOfList cat+  addElse = map ("    " ++) . intersperse "else " . filter (not . null)+    . map (dropWhile isSpace)   prRule :: String -> Rule -> String@@ -245,58 +279,75 @@         "       if (_i_ > " ++ show p ++ ") render(_R_PAREN);\n")     cats' = case cats of         [] -> ""-        _  -> concatMap (render . prCat (text fnm)) (numVars cats)+        _  -> concatMap (render . prItem (text fnm)) (numVars cats)     fnm = '_' : map toLower fun  prRule _nm _ = "" --- |------ >>> let lfoo = ListCat (Cat "Foo")--- >>> prList "absyn" [] lfoo [npRule "[]" lfoo [] Parsable, npRule "(:)" lfoo [Left (Cat "Foo"), Right ".", Left lfoo] Parsable]--- for (java.util.Iterator<absyn.Foo> it = foo.iterator(); it.hasNext();)--- {---   pp(it.next(), _i_);---   if (it.hasNext()) {---     render(".");---   } else {---     render(".");---   }--- }+prList :: String -> String -> [Rule] -> [String]+prList dat et rules = concat+    [ if null docs0 then+      [ "if (it.hasNext())" ]+      else+      [ "if (!it.hasNext())"+      , "{ /* nil */"+      , render $ nest 4 $ vcat docs0+      , "}"+      , "else"+      ]+    , if null docs1 then+      [ "{ /* cons */"+      , "  " ++ et ++ " el = it.next();"+      ]+      else+      [ "{"+      , "  " ++ et ++ " el = it.next();"+      , "  if (!it.hasNext())"+      , "  { /* last */"+      , render $ nest 4 $ vcat docs1+      , "  }"+      , "  else"+      , "  { /* cons */"+      ]+    , unlessNull (swRules isConsFun) $ \ docs ->+      [ render $ nest (if null docs1 then 2 else 4) $ vcat docs+      ]+    , unless (null docs1) [ "  }" ]+    , [ "}" ]+    ]+  where+  prules      = sortRulesByPrecedence rules+  swRules f   = switchByPrecedence "_i_" $+                  map (second $ sep . map text . prListRule_ dat) $+                    uniqOn fst $ filter f prules+                    -- Discard duplicates, can only handle one rule per precedence.+  docs0       = swRules isNilFun+  docs1       = swRules isOneFun -prList :: String -> [UserDef] -> Cat -> [Rule] -> Doc-prList packageAbsyn user c rules =-    "for (java.util.Iterator<" <> et <> "> it = foo.iterator(); it.hasNext();)"-    $$ codeblock 2-        [ "pp(it.next(), _i_);"-        , "if (it.hasNext()) {"-        , nest 2 (renderListSepByPrecedence "_i_" renderSep-            (getSeparatorByPrecedence rules))-        , "} else {"-        , nest 2 (renderSep optsep <> ";")-        , "}"-        ]-   where-    et = text $ typename packageAbsyn user $ identCat $ normCatOfList c-    sep = escapeChars $ getCons rules-    optsep = if hasOneFunc rules then "" else sep-    renderSep x = "render(\"" <> text x <>"\")"+-- | Only render the rhs (items) of a list rule. +prListRule_ :: IsFun a => String -> Rul a -> [String]+prListRule_ dat (Rule _ _ items _) = for items $ \case+  Right t                  -> "render(\"" ++ escapeChars t ++ "\");"+  Left (TokenCat "String") -> "printQuoted(el);"+  Left (ListCat _)         -> "pp" ++ dat ++ "(it, _i_);"+  Left _                   -> "pp(el, _i_);"+ -- |--- >>> prCat "F" (Right "++")+-- >>> prItem "F" (Right "++") --        render("++"); -- <BLANKLINE>--- >>> prCat "F" (Left (TokenCat "String", "string_"))+-- >>> prItem "F" (Left (TokenCat "String", "string_")) --        printQuoted(F.string_); -- <BLANKLINE>--- >>> prCat "F" (Left (Cat "Abc", "abc_"))+-- >>> prItem "F" (Left (Cat "Abc", "abc_")) --        pp(F.abc_, 0); -- <BLANKLINE>-prCat :: Doc -> Either (Cat, Doc) String -> Doc-prCat _ (Right t) = nest 7 ("render(\"" <> text(escapeChars t) <> "\");\n")-prCat fnm (Left (TokenCat "String", nt))+prItem :: Doc -> Either (Cat, Doc) String -> Doc+prItem _ (Right t) = nest 7 ("render(\"" <> text(escapeChars t) <> "\");\n")+prItem fnm (Left (TokenCat "String", nt))     = nest 7 ("printQuoted(" <> fnm <> "." <> nt <> ");\n")-prCat fnm (Left (cat, nt))+prItem fnm (Left (cat, nt))     = nest 7 ("pp(" <> fnm <> "." <> nt <> ", " <> integer (precCat cat) <> ");\n")  --The following methods generate the Show function.

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ {-     BNF Converter: OCaml Abstract Syntax Generator     Copyright (C) 2005  Author:  Kristofer Johannisson@@ -11,15 +13,47 @@ import Text.PrettyPrint  import BNFC.CF-import BNFC.Utils((+++))-import Data.List(intersperse)+import BNFC.Utils ( (+++), unless, parensIf )+import Data.List  ( intersperse ) import BNFC.Backend.OCaml.OCamlUtil  -- to produce an OCaml module cf2Abstract :: String -> CF -> String-cf2Abstract _ cf = unlines $-  "(* OCaml module generated by the BNF converter *)\n\n" :-  mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf))+cf2Abstract _ cf = unlines $ concat+  [ [ "(* OCaml module generated by the BNF converter *)"+    , ""+    ]+  , mutualRecDefs $ concat+    [ map (prSpecialData cf) (specialCats cf)+    , map prData (cf2data cf)+    ]+  , unless (null defs) $ concat+    [ [ "(* defined constructors *)"+      , ""+      ]+    , defs+    ]+  ]+  where+  defs = definedRules cf++definedRules :: CF -> [String]+definedRules cf = map mkDef $ definitions cf+  where+    mkDef (Define f args e t) =+      "let " ++ sanitizeOcaml (funName f) ++ " " ++ mkTuple (map fst args) ++ " = " ++ ocamlExp False e++    ocamlExp :: Bool -> Exp -> String+    ocamlExp p = \case+      Var s       -> s+      App "(:)" _ [e1, e2] -> parensIf p $ unwords [ ocamlExp True e1, "::", ocamlExp False e2 ]+      App s _ []  -> sanitizeOcaml s+      App s _ [e] -> parensIf p $ sanitizeOcaml s ++ ' ' : ocamlExp True e+      App s _ es  -> parensIf p $ sanitizeOcaml s ++ ' ' : mkTuple (map (ocamlExp False) es)+      LitInt i    -> show i+      LitDouble d -> show d+      LitChar c   -> "\'" ++ c : "\'"+      LitString s -> "\"" ++ s ++ "\""  -- allow mutual recursion so that we do not have to sort the type definitions in -- dependency order