{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# 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.
                    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.C.CFtoBisonC
  ( cf2Bison
  , resultName, typeName, varName
  , specialToks, startSymbol
  , unionBuiltinTokens
  )
  where

import Prelude hiding ((<>))

import Data.Char       ( toLower, isUpper )
import Data.Foldable   ( toList )
import Data.List       ( intercalate, nub )
import qualified Data.Map as Map
import System.FilePath ( (<.>) )

import BNFC.CF
import BNFC.Backend.Common.NamedVariables hiding (varName)
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.

-- Type declarations
type Rules       = [(NonTerminal,[(Pattern,Action)])]
type Pattern     = String
type Action      = String
type MetaVar     = String

--The environment comes from the CFtoFlex
cf2Bison :: RecordPositions -> ParserMode -> CF -> SymMap -> String
cf2Bison :: RecordPositions -> ParserMode -> CF -> SymMap -> String
cf2Bison RecordPositions
rp ParserMode
mode CF
cf SymMap
env = [String] -> String
unlines
    [ ParserMode -> CF -> String
header ParserMode
mode CF
cf
    , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ ParserMode -> [NonTerminal] -> Doc
union ParserMode
mode ([NonTerminal] -> Doc) -> [NonTerminal] -> Doc
forall a b. (a -> b) -> a -> b
$ [NonTerminal]
posCats [NonTerminal] -> [NonTerminal] -> [NonTerminal]
forall a. [a] -> [a] -> [a]
++ CF -> [NonTerminal]
forall f. CFG f -> [NonTerminal]
allParserCatsNorm CF
cf
    , String
""
    , ParserMode -> String
unionDependentCode ParserMode
mode
    , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [[String]] -> [String]
table String
" " ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [[[String]]] -> [[String]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [String
"%token", String
"_ERROR_" ] ]
      , [String] -> SymMap -> [[String]]
tokens (((String, Reg) -> String) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Reg) -> String
forall a b. (a, b) -> a
fst ([(String, Reg)] -> [String]) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf) SymMap
env
      , CF -> [[String]]
specialToks CF
cf
      ]
    , ParserMode -> CF -> String
declarations ParserMode
mode CF
cf
    , CF -> String
startSymbol CF
cf
    , String
""
    , String
"%%"
    , String
""
    , Rules -> String
prRules (Rules -> String) -> Rules -> String
forall a b. (a -> b) -> a -> b
$ RecordPositions -> ParserMode -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp ParserMode
mode CF
cf SymMap
env
    , String
"%%"
    , String
""
    , Maybe String -> String
nsStart Maybe String
inPackage
    , ParserMode -> CF -> String
entryCode ParserMode
mode CF
cf
    , Maybe String -> String
nsEnd Maybe String
inPackage
    ]
  where
  inPackage :: Maybe String
inPackage = ParserMode -> Maybe String
parserPackage ParserMode
mode
  posCats :: [NonTerminal]
posCats
    | ParserMode -> Bool
stlParser ParserMode
mode = (String -> NonTerminal) -> [String] -> [NonTerminal]
forall a b. (a -> b) -> [a] -> [b]
map String -> NonTerminal
TokenCat ([String] -> [NonTerminal]) -> [String] -> [NonTerminal]
forall a b. (a -> b) -> a -> b
$ CF -> [String]
positionCats CF
cf
    | Bool
otherwise      = []

positionCats :: CF -> [String]
positionCats :: CF -> [String]
positionCats CF
cf = [ RFun -> String
forall a. WithPosition a -> a
wpThing RFun
name | TokenReg RFun
name Bool
True Reg
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]

header :: ParserMode -> CF -> String
header :: ParserMode -> CF -> String
header ParserMode
mode CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"/* Parser definition to be used with Bison. */"
    , String
""
    , String
"/* Generate header file for lexer. */"
    , String
"%defines \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
"Bison" String -> String -> String
<.> String
h) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
    ]
  , Maybe String -> (String -> [String]) -> [String]
forall m a. Monoid m => Maybe a -> (a -> m) -> m
whenJust (ParserMode -> Maybe String
parserPackage ParserMode
mode) ((String -> [String]) -> [String])
-> (String -> [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ \ String
ns ->
    [ String
"%name-prefix = \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
    , String
"  /* From Bison 2.6: %define api.prefix {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"} */"
    ]
  , [ String
""
    , String
"/* Reentrant parser */"
    , String
"%pure_parser"
    , String
"  /* 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
    , String
"%lex-param   { yyscan_t scanner }"
    , String
"%parse-param { yyscan_t scanner }"
    , String
""
    , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"/* Turn on line/column tracking in the ", String
name, String
"lloc structure: */" ]
    , String
"%locations"
    , String
""
    , String
"/* Argument to the parser to be filled with the parsed tree. */"
    , String
"%parse-param { YYSTYPE *result }"
    , String
""
    , String
"%{"
    , String
"/* Begin C preamble code */"
    , String
""
    ]
    -- Andreas, 2021-08-26, issue #377:  Some C++ compilers want "algorithm".
    -- Fixing regression introduced in 2.9.2.
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when (ParserMode -> Bool
stlParser ParserMode
mode)
    [ String
"#include <algorithm> /* for std::reverse */"  -- mandatory e.g. with GNU C++ 11
    ]
  , [ String
"#include <stdio.h>"
    , String
"#include <stdlib.h>"
    , String
"#include <string.h>"
    , String
"#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
"Absyn" String -> String -> String
<.> String
h) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
    , String
""
    , String
"#define YYMAXDEPTH 10000000"  -- default maximum stack size is 10000, but right-recursion needs O(n) stack
    , String
""
    , String
"/* The type yyscan_t is defined by flex, but we need it in the parser already. */"
    , String
"#ifndef YY_TYPEDEF_YY_SCANNER_T"
    , String
"#define YY_TYPEDEF_YY_SCANNER_T"
    , String
"typedef void* yyscan_t;"
    , String
"#endif"
    , String
""
    -- , "typedef struct " ++ name ++ "_buffer_state *YY_BUFFER_STATE;"
    , String
"typedef struct yy_buffer_state *YY_BUFFER_STATE;"
    , String
"extern YY_BUFFER_STATE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_scan_string(const char *str, yyscan_t scanner);"
    , String
"extern void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_delete_buffer(YY_BUFFER_STATE buf, yyscan_t scanner);"
    , String
""
    , String
"extern void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"lex_destroy(yyscan_t scanner);"
    , String
"extern char* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"get_text(yyscan_t scanner);"
    , String
""
    , String
"extern yyscan_t " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_initialize_lexer(FILE * inp);"
    , String
""
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless (ParserMode -> Bool
stlParser ParserMode
mode)
    [ String
"/* List reversal functions. */"
    , (NonTerminal -> String) -> [NonTerminal] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ParserMode -> NonTerminal -> String
reverseList ParserMode
mode) ([NonTerminal] -> String) -> [NonTerminal] -> String
forall a b. (a -> b) -> a -> b
$ (NonTerminal -> Bool) -> [NonTerminal] -> [NonTerminal]
forall a. (a -> Bool) -> [a] -> [a]
filter NonTerminal -> Bool
isList ([NonTerminal] -> [NonTerminal]) -> [NonTerminal] -> [NonTerminal]
forall a b. (a -> b) -> a -> b
$ CF -> [NonTerminal]
forall f. CFG f -> [NonTerminal]
allParserCatsNorm CF
cf
    ]
  , [ String
"/* End C preamble code */"
    , String
"%}"
    ]
  ]
  where
  h :: String
h    = ParserMode -> String
parserHExt ParserMode
mode
  name :: String
name = ParserMode -> String
parserName ParserMode
mode

-- | Code that needs the @YYSTYPE@ defined by the @%union@ pragma.
--
unionDependentCode :: ParserMode -> String
unionDependentCode :: ParserMode -> String
unionDependentCode ParserMode
mode = [String] -> String
unlines
  [ String
"%{"
  , String -> String
errorHandler String
name
  , String
"int yyparse(yyscan_t scanner, YYSTYPE *result);"
  , String
""
  , String
"extern int yylex(YYSTYPE *lvalp, YYLTYPE *llocp, yyscan_t scanner);"
  , String
"%}"
  ]
  where
  name :: String
name = ParserMode -> String
parserName ParserMode
mode

errorHandler :: String -> String
errorHandler :: String -> String
errorHandler String
name = [String] -> String
unlines
  [ String
"void yyerror(YYLTYPE *loc, yyscan_t scanner, YYSTYPE *result, const char *msg)"
  , String
"{"
  , String
"  fprintf(stderr, \"error: %d,%d: %s at %s\\n\","
  , String
"    loc->first_line, loc->first_column, msg, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"get_text(scanner));"
  , String
"}"
  ]

-- | Parser entry point code.
--
entryCode :: ParserMode -> CF -> String
entryCode :: ParserMode -> CF -> String
entryCode ParserMode
mode CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (NonTerminal -> String) -> [NonTerminal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ParserMode -> CF -> NonTerminal -> String
parseMethod ParserMode
mode CF
cf) [NonTerminal]
eps
  where
  eps :: [NonTerminal]
eps = NonEmpty NonTerminal -> [NonTerminal]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CF -> NonEmpty NonTerminal
forall f. CFG f -> NonEmpty NonTerminal
allEntryPoints CF
cf)

--This generates a parser method for each entry point.
parseMethod :: ParserMode -> CF -> Cat -> String
parseMethod :: ParserMode -> CF -> NonTerminal -> String
parseMethod ParserMode
mode CF
cf NonTerminal
cat = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ [String] -> String
unwords [ String
"/* Entrypoint: parse", String
dat, String
"from file. */" ]
    , String
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(FILE *inp)"
    ]
  , Bool -> [String]
body Bool
False
  , [ String
""
    , [String] -> String
unwords [ String
"/* Entrypoint: parse", String
dat, String
"from string. */" ]
    , String
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ps" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(const char *str)"
    ]
  , Bool -> [String]
body Bool
True
  ]
  where
  name :: String
name = ParserMode -> String
parserName ParserMode
mode
  body :: Bool -> [String]
body Bool
stringParser = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"{"
      , String
"  YYSTYPE result;"
      , String
"  yyscan_t scanner = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_initialize_lexer(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
      , String
"  if (!scanner) {"
      , String
"    fprintf(stderr, \"Failed to initialize lexer.\\n\");"
      , String
"    return 0;"
      , String
"  }"
      ]
    , [ String
"  YY_BUFFER_STATE buf = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_scan_string(str, scanner);" | Bool
stringParser ]
    , [ String
"  int error = yyparse(scanner, &result);" ]
    , [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_delete_buffer(buf, scanner);" | Bool
stringParser ]
    , [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"lex_destroy(scanner);"
      , String
"  if (error)"
      , String
"  { /* Failure */"
      , String
"    return 0;"
      , String
"  }"
      , String
"  else"
      , String
"  { /* Success */"
      ]
    , [String]
revOpt
    , [ String
"    return" String -> String -> String
+++ String
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
      , String
"  }"
      , String
"}"
      ]
    ]
    where
    file :: String
file | Bool
stringParser = String
"0"
         | Bool
otherwise    = String
"inp"
  stl :: Bool
stl    = ParserMode -> Bool
stlParser ParserMode
mode
  ncat :: NonTerminal
ncat   = NonTerminal -> NonTerminal
normCat NonTerminal
cat
  dat0 :: String
dat0   = NonTerminal -> String
identCat NonTerminal
ncat
  dat :: String
dat    = if ParserMode -> Bool
cParser ParserMode
mode then String
dat0 else String
dat0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*"
  parser :: String
parser = NonTerminal -> String
identCat NonTerminal
cat
  res0 :: String
res0   = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"result.", NonTerminal -> String
varName NonTerminal
ncat ]
  -- Reversing the result
  isReversible :: Bool
isReversible  = NonTerminal
cat NonTerminal -> [NonTerminal] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [NonTerminal]
forall f. CFG f -> [NonTerminal]
cfgReversibleCats CF
cf
  -- C and NoSTL
  res :: String
res
    | Bool -> Bool
not Bool
stl, Bool
isReversible
                = String
"reverse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dat0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
res0 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    | Bool
otherwise = String
res0
  -- STL: Vectors are snoc lists
  revOpt :: [String]
revOpt = Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when (Bool
stl Bool -> Bool -> Bool
&& NonTerminal -> Bool
isList NonTerminal
cat Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isReversible)
             [ String
"std::reverse(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->begin(), " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
res String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"->end());" ]

--This method generates list reversal functions for each list type.
reverseList :: ParserMode -> Cat -> String
reverseList :: ParserMode -> NonTerminal -> String
reverseList ParserMode
mode NonTerminal
c0 = [String] -> String
unlines
    [ String
c' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" reverse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
+++ String
"l)"
    , String
"{"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
+++String
"prev = 0;"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
+++String
"tmp = 0;"
    , String
"  while (l)"
    , String
"  {"
    , String
"    tmp = l->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"    l->" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
+++ String
"= prev;"
    , String
"    prev = l;"
    , String
"    l = tmp;"
    , String
"  }"
    , String
"  return prev;"
    , String
"}"
    ]
  where
  c :: String
c  = NonTerminal -> String
identCat (NonTerminal -> NonTerminal
normCat NonTerminal
c0)
  c' :: String
c' = String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
star
  v :: String
v = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
  star :: String
star = if ParserMode -> Bool
cParser ParserMode
mode then String
"" else String
"*"

-- | 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 :: ParserMode -> [NonTerminal] -> Doc
union ParserMode
mode [NonTerminal]
cats = [Doc] -> Doc
vcat
    [ Doc
"%union"
    , Int -> [Doc] -> Doc
codeblock Int
2 ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
unionBuiltinTokens [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (NonTerminal -> Doc) -> [NonTerminal] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map NonTerminal -> Doc
mkPointer [NonTerminal]
normCats
    ]
  where
  normCats :: [NonTerminal]
normCats = [NonTerminal] -> [NonTerminal]
forall a. Eq a => [a] -> [a]
nub ((NonTerminal -> NonTerminal) -> [NonTerminal] -> [NonTerminal]
forall a b. (a -> b) -> [a] -> [b]
map NonTerminal -> NonTerminal
normCat [NonTerminal]
cats)
  mkPointer :: NonTerminal -> Doc
mkPointer NonTerminal
s = Doc
scope Doc -> Doc -> Doc
<> String -> Doc
text (NonTerminal -> String
identCat NonTerminal
s) Doc -> Doc -> Doc
<> Doc
star Doc -> Doc -> Doc
<+> String -> Doc
text (NonTerminal -> String
varName NonTerminal
s) Doc -> Doc -> Doc
<> Doc
";"
  scope :: Doc
scope = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
nsScope (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ParserMode -> Maybe String
parserPackage ParserMode
mode
  star :: Doc
star = if ParserMode -> Bool
cParser ParserMode
mode then Doc
empty else String -> Doc
text String
"*"

unionBuiltinTokens :: [String]
unionBuiltinTokens :: [String]
unionBuiltinTokens =
  [ String
"int    _int;"
  , String
"char   _char;"
  , String
"double _double;"
  , String
"char*  _string;"
  ]

-- | @%type@ declarations for non-terminal types.
declarations :: ParserMode -> CF -> String
declarations :: ParserMode -> CF -> String
declarations ParserMode
mode CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (NonTerminal -> String) -> [NonTerminal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NonTerminal -> String
typeNT ([NonTerminal] -> [String]) -> [NonTerminal] -> [String]
forall a b. (a -> b) -> a -> b
$
  [NonTerminal]
posCats [NonTerminal] -> [NonTerminal] -> [NonTerminal]
forall a. [a] -> [a] -> [a]
++
  (NonTerminal -> Bool) -> [NonTerminal] -> [NonTerminal]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (NonTerminal -> Bool) -> NonTerminal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Rule] -> Bool) -> (NonTerminal -> [Rule]) -> NonTerminal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> NonTerminal -> [Rule]
rulesForCat CF
cf) (CF -> [NonTerminal]
forall f. CFG f -> [NonTerminal]
allParserCats CF
cf) -- don't define internal rules
  where
  typeNT :: NonTerminal -> String
typeNT NonTerminal
nt = String
"%type <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonTerminal -> String
varName NonTerminal
nt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonTerminal -> String
identCat NonTerminal
nt
  posCats :: [NonTerminal]
posCats
    | ParserMode -> Bool
stlParser ParserMode
mode = (String -> NonTerminal) -> [String] -> [NonTerminal]
forall a b. (a -> b) -> [a] -> [b]
map String -> NonTerminal
TokenCat ([String] -> [NonTerminal]) -> [String] -> [NonTerminal]
forall a b. (a -> b) -> a -> b
$ CF -> [String]
positionCats CF
cf
    | Bool
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 :: [String] -> SymMap -> [[String]]
tokens [String]
user SymMap
env = ((SymKey, String) -> [String]) -> [(SymKey, String)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (SymKey, String) -> [String]
declTok ([(SymKey, String)] -> [[String]])
-> [(SymKey, String)] -> [[String]]
forall a b. (a -> b) -> a -> b
$ SymMap -> [(SymKey, String)]
forall k a. Map k a -> [(k, a)]
Map.toList SymMap
env
  where
  declTok :: (SymKey, String) -> [String]
declTok (Keyword   String
s, String
r) = String -> String -> String -> [String]
tok String
"" String
s String
r
  declTok (Tokentype String
s, String
r) = String -> String -> String -> [String]
tok (if String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
user then String
"<_string>" else String
"") String
s String
r
  tok :: String -> String -> String -> [String]
tok String
t String
s String
r = [ String
"%token" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t, String
r, String
" /* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cStringEscape String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" */" ]

-- | Escape characters inside a C string.
cStringEscape :: String -> String
cStringEscape :: String -> String
cStringEscape = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escChar
  where
    escChar :: Char -> String
escChar Char
c
      | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"\"\\" :: String) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
c]
      | Bool
otherwise = [Char
c]

-- | Produces a table with the built-in token types.
specialToks :: CF -> [[String]]
specialToks :: CF -> [[String]]
specialToks CF
cf = [[[String]]] -> [[String]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String -> [String] -> [[String]]
forall {a}. String -> a -> [a]
ifC String
catString  [ String
"%token<_string>", String
"_STRING_"  ]
  , String -> [String] -> [[String]]
forall {a}. String -> a -> [a]
ifC String
catChar    [ String
"%token<_char>  ", String
"_CHAR_"    ]
  , String -> [String] -> [[String]]
forall {a}. String -> a -> [a]
ifC String
catInteger [ String
"%token<_int>   ", String
"_INTEGER_" ]
  , String -> [String] -> [[String]]
forall {a}. String -> a -> [a]
ifC String
catDouble  [ String
"%token<_double>", String
"_DOUBLE_"  ]
  , String -> [String] -> [[String]]
forall {a}. String -> a -> [a]
ifC String
catIdent   [ String
"%token<_string>", String
"_IDENT_"   ]
  ]
  where
    ifC :: String -> a -> [a]
ifC String
cat a
s = if CF -> NonTerminal -> Bool
forall f. CFG f -> NonTerminal -> Bool
isUsedCat CF
cf (String -> NonTerminal
TokenCat String
cat) then [a
s] else []

-- | Bison only supports a single entrypoint.
startSymbol :: CF -> String
startSymbol :: CF -> String
startSymbol CF
cf = String
"%start" String -> String -> String
+++ NonTerminal -> String
identCat (CF -> NonTerminal
firstEntry CF
cf)

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: RecordPositions -> ParserMode -> CF -> SymMap -> Rules
rulesForBison :: RecordPositions -> ParserMode -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp ParserMode
mode CF
cf SymMap
env = ((NonTerminal, [Rule]) -> (NonTerminal, [(String, String)]))
-> [(NonTerminal, [Rule])] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map (NonTerminal, [Rule]) -> (NonTerminal, [(String, String)])
mkOne (CF -> [(NonTerminal, [Rule])]
ruleGroups CF
cf) Rules -> Rules -> Rules
forall a. [a] -> [a] -> [a]
++ Rules
posRules
  where
  mkOne :: (NonTerminal, [Rule]) -> (NonTerminal, [(String, String)])
mkOne (NonTerminal
cat,[Rule]
rules) = RecordPositions
-> ParserMode
-> CF
-> SymMap
-> [Rule]
-> NonTerminal
-> (NonTerminal, [(String, String)])
constructRule RecordPositions
rp ParserMode
mode CF
cf SymMap
env [Rule]
rules NonTerminal
cat
  posRules :: Rules
  posRules :: Rules
posRules
    | CppParser Maybe String
inPackage String
_ <- ParserMode
mode = [String] -> (String -> (NonTerminal, [(String, String)])) -> Rules
forall a b. [a] -> (a -> b) -> [b]
for (CF -> [String]
positionCats CF
cf) ((String -> (NonTerminal, [(String, String)])) -> Rules)
-> (String -> (NonTerminal, [(String, String)])) -> Rules
forall a b. (a -> b) -> a -> b
$ \ String
n -> (String -> NonTerminal
TokenCat String
n,
      [( String -> SymKey -> SymMap -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault String
n (String -> SymKey
Tokentype String
n) SymMap
env
       , CF -> NonTerminal -> String -> String
addResult CF
cf (String -> NonTerminal
TokenCat String
n) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ String
"$$ = new ", Maybe String -> String
nsScope Maybe String
inPackage, String
n, String
"($1, @$.first_line);" ]
       )])
    | Bool
otherwise = []

-- For every non-terminal, we construct a set of rules.
constructRule
  :: RecordPositions -> ParserMode -> CF -> SymMap
  -> [Rule]                           -- ^ List of alternatives for parsing ...
  -> NonTerminal                      -- ^ ... this non-terminal.
  -> (NonTerminal,[(Pattern,Action)])
constructRule :: RecordPositions
-> ParserMode
-> CF
-> SymMap
-> [Rule]
-> NonTerminal
-> (NonTerminal, [(String, String)])
constructRule RecordPositions
rp ParserMode
mode CF
cf SymMap
env [Rule]
rules NonTerminal
nt = (NonTerminal
nt,) ([(String, String)] -> (NonTerminal, [(String, String)]))
-> [(String, String)] -> (NonTerminal, [(String, String)])
forall a b. (a -> b) -> a -> b
$
    [ (String
p,) (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ CF -> NonTerminal -> String -> String
addResult CF
cf NonTerminal
nt (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ RecordPositions
-> ParserMode
-> String
-> RFun
-> Bool
-> [(String, Bool)]
-> String
forall a.
IsFun a =>
RecordPositions
-> ParserMode -> String -> a -> Bool -> [(String, Bool)] -> String
generateAction RecordPositions
rp ParserMode
mode (NonTerminal -> String
identCat (NonTerminal -> NonTerminal
normCat NonTerminal
nt)) (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r) Bool
b [(String, Bool)]
m
    | Rule
r0 <- [Rule]
rules
    , let (Bool
b,Rule
r) = if RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r0) Bool -> Bool -> Bool
&& Rule -> NonTerminal
forall fun. Rul fun -> NonTerminal
valCat Rule
r0 NonTerminal -> [NonTerminal] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [NonTerminal]
forall f. CFG f -> [NonTerminal]
cfgReversibleCats CF
cf
                  then (Bool
True, Rule -> Rule
forall f. Rul f -> Rul f
revSepListRule Rule
r0)
                  else (Bool
False, Rule
r0)
    , let (String
p,[(String, Bool)]
m) = ParserMode -> CF -> SymMap -> Rule -> (String, [(String, Bool)])
generatePatterns ParserMode
mode CF
cf SymMap
env Rule
r
    ]

-- | Add action if we parse an entrypoint non-terminal:
-- Set field in result record to current parse.
addResult :: CF -> NonTerminal -> Action -> Action
addResult :: CF -> NonTerminal -> String -> String
addResult CF
cf NonTerminal
nt String
a =
  if NonTerminal
nt NonTerminal -> [NonTerminal] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty NonTerminal -> [NonTerminal]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CF -> NonEmpty NonTerminal
forall f. CFG f -> NonEmpty NonTerminal
allEntryPoints CF
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 [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
a, String
" result->", NonTerminal -> String
varName (NonTerminal -> NonTerminal
normCat NonTerminal
nt), String
" = $$;" ]
    else String
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 :: forall a.
IsFun a =>
RecordPositions
-> ParserMode -> String -> a -> Bool -> [(String, Bool)] -> String
generateAction RecordPositions
rp = \case
  CppParser Maybe String
ns String
_ -> RecordPositions
-> Maybe String
-> String
-> a
-> Bool
-> [(String, Bool)]
-> String
forall a.
IsFun a =>
RecordPositions
-> Maybe String
-> String
-> a
-> Bool
-> [(String, Bool)]
-> String
generateActionSTL RecordPositions
rp Maybe String
ns
  CParser   Bool
b  String
_ -> \ String
nt a
f Bool
r -> RecordPositions
-> Bool -> String -> a -> Bool -> [String] -> String
forall a.
IsFun a =>
RecordPositions
-> Bool -> String -> a -> Bool -> [String] -> String
generateActionC RecordPositions
rp (Bool -> Bool
not Bool
b) String
nt a
f Bool
r ([String] -> String)
-> ([(String, Bool)] -> [String]) -> [(String, Bool)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Bool) -> String) -> [(String, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Bool) -> String
forall a b. (a, b) -> a
fst

-- | Generates a string containing the semantic action.
-- >>> 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 :: forall a.
IsFun a =>
RecordPositions
-> Bool -> String -> a -> Bool -> [String] -> String
generateActionC RecordPositions
rp Bool
cParser String
nt a
f Bool
b [String]
ms
  | a -> Bool
forall a. IsFun a => a -> Bool
isCoercion a
f = String
"$$ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
loc
  | a -> Bool
forall a. IsFun a => a -> Bool
isNilFun a
f   = String
"$$ = 0;"
  | a -> Bool
forall a. IsFun a => a -> Bool
isOneFun a
f   = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String -> String
new String
nt, String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms', String
", 0);"]
  | a -> Bool
forall a. IsFun a => a -> Bool
isConsFun a
f  = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String -> String
new String
nt, String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms', String
");"]
  | Bool
otherwise    = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String -> String
new (a -> String
forall a. IsFun a => a -> String
funName a
f), String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms', String
");", String
loc]
 where
  ms' :: [String]
ms' = if Bool
b then [String] -> [String]
forall a. [a] -> [a]
reverse [String]
ms else [String]
ms
  loc :: String
loc | RecordPositions
RecordPositions <- RecordPositions
rp
          = String
" $$->line_number = @$.first_line; $$->char_number = @$.first_column;"
      | Bool
otherwise
          = String
""
  new :: String -> String
  new :: String -> String
new | Bool
cParser   = (String
"make_" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
      | Bool
otherwise = \ String
s -> if Char -> Bool
isUpper (String -> Char
forall a. [a] -> a
head String
s) then String
"new " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s else String -> String
sanitizeCpp String
s

generateActionSTL :: IsFun a => RecordPositions -> InPackage -> String -> a -> Bool -> [(MetaVar,Bool)] -> Action
generateActionSTL :: forall a.
IsFun a =>
RecordPositions
-> Maybe String
-> String
-> a
-> Bool
-> [(String, Bool)]
-> String
generateActionSTL RecordPositions
rp Maybe String
inPackage String
nt a
f Bool
b [(String, Bool)]
mbs = String
reverses String -> String -> String
forall a. [a] -> [a] -> [a]
++
  if | a -> Bool
forall a. IsFun a => a -> Bool
isCoercion a
f    -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", [String] -> String
unwords [String]
ms, String
";", String
loc]
     | a -> Bool
forall a. IsFun a => a -> Bool
isNilFun a
f      -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
"new ", String
scope, String
nt, String
"();"]
     | a -> Bool
forall a. IsFun a => a -> Bool
isOneFun a
f      -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
"new ", String
scope, String
nt, String
"(); $$->push_back(", [String] -> String
forall a. [a] -> a
head [String]
ms, String
");"]
     | a -> Bool
forall a. IsFun a => a -> Bool
isConsFun a
f     -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
lst, String
"->push_back(", String
el, String
"); $$ = ", String
lst, String
";"]
     | a -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule a
f -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
scope, String -> String
sanitizeCpp (a -> String
forall a. IsFun a => a -> String
funName a
f), String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms, String
");" ]
     | Bool
otherwise       -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
"new ", String
scope, a -> String
forall a. IsFun a => a -> String
funName a
f, String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms, String
");", String
loc]
 where
  ms :: [String]
ms        = ((String, Bool) -> String) -> [(String, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Bool) -> String
forall a b. (a, b) -> a
fst [(String, Bool)]
mbs
  -- The following match only happens in the cons case:
  [String
el, String
lst] = Bool -> ([String] -> [String]) -> [String] -> [String]
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b [String] -> [String]
forall a. [a] -> [a]
reverse [String]
ms  -- b: left-recursion transformed?

  loc :: String
loc | RecordPositions
RecordPositions <- RecordPositions
rp
            = String
" $$->line_number = @$.first_line; $$->char_number = @$.first_column;"
      | Bool
otherwise
            = String
""
  reverses :: String
reverses  = [String] -> String
unwords [String
"std::reverse(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"->begin(),"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"->end()) ;" | (String
m, Bool
True) <- [(String, Bool)]
mbs]
  scope :: String
scope     = Maybe String -> String
nsScope Maybe String
inPackage

-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: ParserMode -> CF -> SymMap -> Rule -> (Pattern,[(MetaVar,Bool)])
generatePatterns :: ParserMode -> CF -> SymMap -> Rule -> (String, [(String, Bool)])
generatePatterns ParserMode
mode CF
cf SymMap
env Rule
r = case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
  []  -> (String
"/* empty */",[])
  SentForm
its -> ([String] -> String
unwords ((Either NonTerminal String -> String) -> SentForm -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Either NonTerminal String -> String
mkIt SentForm
its), SentForm -> [(String, Bool)]
forall {b}. [Either NonTerminal b] -> [(String, Bool)]
metas SentForm
its)
 where
   stl :: Bool
stl  = ParserMode -> Bool
stlParser ParserMode
mode
   mkIt :: Either NonTerminal String -> String
mkIt = \case
     Left (TokenCat String
s)
       | Bool
stl Bool -> Bool -> Bool
&& CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
s
                   -> String -> String
typeName String
s
       | Bool
otherwise -> String -> SymKey -> SymMap -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> String
typeName String
s) (String -> SymKey
Tokentype String
s) SymMap
env
     Left NonTerminal
c  -> NonTerminal -> String
identCat NonTerminal
c
     Right String
s -> String -> SymKey -> SymMap -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault String
s (String -> SymKey
Keyword String
s) SymMap
env
   metas :: [Either NonTerminal b] -> [(String, Bool)]
metas [Either NonTerminal b]
its = [(NonTerminal -> String -> String
revIf NonTerminal
c (Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i), NonTerminal -> Bool
revert NonTerminal
c) | (Int
i, Left NonTerminal
c) <- [Int] -> [Either NonTerminal b] -> [(Int, Either NonTerminal b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [Either NonTerminal b]
its]
   -- C and C++/NoSTL: call reverse function
   revIf :: NonTerminal -> String -> String
revIf NonTerminal
c String
m = if Bool -> Bool
not Bool
stl Bool -> Bool -> Bool
&& Bool
isntCons Bool -> Bool -> Bool
&& NonTerminal -> [NonTerminal] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NonTerminal
c [NonTerminal]
revs
                 then String
"reverse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonTerminal -> String
identCat (NonTerminal -> NonTerminal
normCat NonTerminal
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
               else String
m  -- no reversal in the left-recursive Cons rule itself
   -- C++/STL: flag if reversal is necessary
   -- notice: reversibility with push_back vectors is the opposite
   -- of right-recursive lists!
   revert :: NonTerminal -> Bool
revert NonTerminal
c = Bool
isntCons Bool -> Bool -> Bool
&& NonTerminal -> Bool
isList NonTerminal
c Bool -> Bool -> Bool
&& NonTerminal -> [NonTerminal] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem NonTerminal
c [NonTerminal]
revs
   revs :: [NonTerminal]
revs     = CF -> [NonTerminal]
forall f. CFG f -> [NonTerminal]
cfgReversibleCats CF
cf
   isntCons :: Bool
isntCons = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun (RFun -> Bool) -> RFun -> Bool
forall a b. (a -> b) -> a -> b
$ Rule -> RFun
forall function. Rul function -> function
funRule Rule
r

-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.

prRules :: Rules -> String
prRules :: Rules -> String
prRules [] = []
prRules ((NonTerminal
_, []):Rules
rs) = Rules -> String
prRules Rules
rs --internal rule
prRules ((NonTerminal
nt, (String
p,String
a) : [(String, String)]
ls):Rules
rs) =
  [String] -> String
unwords [String
nt', String
":" , String
p, String
"{", String
a, String
"}", Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: [(String, String)] -> String
pr [(String, String)]
ls] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rules -> String
prRules Rules
rs
 where
  nt' :: String
nt' = NonTerminal -> String
identCat NonTerminal
nt
  pr :: [(String, String)] -> String
pr []           = []
  pr ((String
p,String
a):[(String, String)]
ls)   = [String] -> String
unlines [[String] -> String
unwords [String
"  |", String
p, String
"{", String
a , String
"}"]] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
pr [(String, String)]
ls

--Some helper functions.
resultName :: String -> String
resultName :: String -> String
resultName String
s = String
"YY_RESULT_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"

-- | slightly stronger than the NamedVariable version.
-- >>> varName (Cat "Abc")
-- "abc_"
varName :: Cat -> String
varName :: NonTerminal -> String
varName = \case
  TokenCat String
s -> String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s
  NonTerminal
c          -> (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String -> String)
-> (NonTerminal -> String) -> NonTerminal -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String)
-> (NonTerminal -> String) -> NonTerminal -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonTerminal -> String
identCat (NonTerminal -> String)
-> (NonTerminal -> NonTerminal) -> NonTerminal -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonTerminal -> NonTerminal
normCat (NonTerminal -> String) -> NonTerminal -> String
forall a b. (a -> b) -> a -> b
$ NonTerminal
c

typeName :: String -> String
typeName :: String -> String
typeName String
"Ident" = String
"_IDENT_"
typeName String
"String" = String
"_STRING_"
typeName String
"Char" = String
"_CHAR_"
typeName String
"Integer" = String
"_INTEGER_"
typeName String
"Double" = String
"_DOUBLE_"
typeName String
x = String
x