{-# 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 forall a b. (a -> b) -> a -> b
$ ParserMode -> [NonTerminal] -> Doc
union ParserMode
mode forall a b. (a -> b) -> a -> b
$ [NonTerminal]
posCats forall a. [a] -> [a] -> [a]
++ forall f. CFG f -> [NonTerminal]
allParserCatsNorm CF
cf
    , String
""
    , ParserMode -> String
unionDependentCode ParserMode
mode
    , [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ String -> [[String]] -> [String]
table String
" " forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [String
"%token", String
"_ERROR_" ] ]
      , [String] -> SymMap -> [[String]]
tokens (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ 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 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 = forall a b. (a -> b) -> [a] -> [b]
map String -> NonTerminal
TokenCat forall a b. (a -> b) -> a -> b
$ CF -> [String]
positionCats CF
cf
    | Bool
otherwise      = []

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

header :: ParserMode -> CF -> String
header :: ParserMode -> CF -> String
header ParserMode
mode CF
cf = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ 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 \"" forall a. [a] -> [a] -> [a]
++ (String
"Bison" String -> String -> String
<.> String
h) forall a. [a] -> [a] -> [a]
++ String
"\""
    ]
  , forall m a. Monoid m => Maybe a -> (a -> m) -> m
whenJust (ParserMode -> Maybe String
parserPackage ParserMode
mode) forall a b. (a -> b) -> a -> b
$ \ String
ns ->
    [ String
"%name-prefix = \"" forall a. [a] -> [a] -> [a]
++ String
ns forall a. [a] -> [a] -> [a]
++ String
"\""
    , String
"  /* From Bison 2.6: %define api.prefix {" forall a. [a] -> [a] -> [a]
++ String
ns 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
""
    , 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.
  , 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 \"" forall a. [a] -> [a] -> [a]
++ (String
"Absyn" String -> String -> String
<.> String
h) 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 " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"_scan_string(const char *str, yyscan_t scanner);"
    , String
"extern void " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"_delete_buffer(YY_BUFFER_STATE buf, yyscan_t scanner);"
    , String
""
    , String
"extern void " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"lex_destroy(yyscan_t scanner);"
    , String
"extern char* " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"get_text(yyscan_t scanner);"
    , String
""
    , String
"extern yyscan_t " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"_initialize_lexer(FILE * inp);"
    , String
""
    ]
  , forall m. Monoid m => Bool -> m -> m
unless (ParserMode -> Bool
stlParser ParserMode
mode)
    [ String
"/* List reversal functions. */"
    , forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ParserMode -> NonTerminal -> String
reverseList ParserMode
mode) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter NonTerminal -> Bool
isList forall a b. (a -> b) -> a -> b
$ 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, " forall a. [a] -> [a] -> [a]
++ String
name 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ParserMode -> CF -> NonTerminal -> String
parseMethod ParserMode
mode CF
cf) [NonTerminal]
eps
  where
  eps :: [NonTerminal]
eps = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall f. CFG f -> List1 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ [String] -> String
unwords [ String
"/* Entrypoint: parse", String
dat, String
"from file. */" ]
    , String
dat forall a. [a] -> [a] -> [a]
++ String
" p" forall a. [a] -> [a] -> [a]
++ String
parser 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 forall a. [a] -> [a] -> [a]
++ String
" ps" forall a. [a] -> [a] -> [a]
++ String
parser 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"{"
      , String
"  YYSTYPE result;"
      , String
"  yyscan_t scanner = " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"_initialize_lexer(" forall a. [a] -> [a] -> [a]
++ String
file 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 = " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"_scan_string(str, scanner);" | Bool
stringParser ]
    , [ String
"  int error = yyparse(scanner, &result);" ]
    , [ String
"  " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"_delete_buffer(buf, scanner);" | Bool
stringParser ]
    , [ String
"  " forall a. [a] -> [a] -> [a]
++ String
name 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 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 forall a. [a] -> [a] -> [a]
++ String
"*"
  parser :: String
parser = NonTerminal -> String
identCat NonTerminal
cat
  res0 :: String
res0   = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"result.", NonTerminal -> String
varName NonTerminal
ncat ]
  -- Reversing the result
  isReversible :: Bool
isReversible  = NonTerminal
cat forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall f. CFG f -> [NonTerminal]
cfgReversibleCats CF
cf
  -- C and NoSTL
  res :: String
res
    | Bool -> Bool
not Bool
stl, Bool
isReversible
                = String
"reverse" forall a. [a] -> [a] -> [a]
++ String
dat0 forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
res0 forall a. [a] -> [a] -> [a]
++ String
")"
    | Bool
otherwise = String
res0
  -- STL: Vectors are snoc lists
  revOpt :: [String]
revOpt = 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(" forall a. [a] -> [a] -> [a]
++ String
res forall a. [a] -> [a] -> [a]
++ String
"->begin(), " forall a. [a] -> [a] -> [a]
++ String
res 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' forall a. [a] -> [a] -> [a]
++ String
" reverse" forall a. [a] -> [a] -> [a]
++ String
c forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
+++ String
"l)"
    , String
"{"
    , String
"  " forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
+++String
"prev = 0;"
    , String
"  " forall a. [a] -> [a] -> [a]
++ String
c' String -> String -> String
+++String
"tmp = 0;"
    , String
"  while (l)"
    , String
"  {"
    , String
"    tmp = l->" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"    l->" 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 forall a. [a] -> [a] -> [a]
++ String
star
  v :: String
v = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
unionBuiltinTokens forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map NonTerminal -> Doc
mkPointer [NonTerminal]
normCats
    ]
  where
  normCats :: [NonTerminal]
normCats = forall a. Eq a => [a] -> [a]
nub (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 forall a b. (a -> b) -> a -> b
$ Maybe String -> String
nsScope 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map NonTerminal -> String
typeNT forall a b. (a -> b) -> a -> b
$
  [NonTerminal]
posCats forall a. [a] -> [a] -> [a]
++
  forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> NonTerminal -> [Rule]
rulesForCat CF
cf) (forall f. CFG f -> [NonTerminal]
allParserCats CF
cf) -- don't define internal rules
  where
  typeNT :: NonTerminal -> String
typeNT NonTerminal
nt = String
"%type <" forall a. [a] -> [a] -> [a]
++ NonTerminal -> String
varName NonTerminal
nt forall a. [a] -> [a] -> [a]
++ String
"> " forall a. [a] -> [a] -> [a]
++ NonTerminal -> String
identCat NonTerminal
nt
  posCats :: [NonTerminal]
posCats
    | ParserMode -> Bool
stlParser ParserMode
mode = forall a b. (a -> b) -> [a] -> [b]
map String -> NonTerminal
TokenCat 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 = forall a b. (a -> b) -> [a] -> [b]
map (SymKey, String) -> [String]
declTok forall a b. (a -> b) -> a -> b
$ 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 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" forall a. [a] -> [a] -> [a]
++ String
t, String
r, String
" /* " forall a. [a] -> [a] -> [a]
++ String -> String
cStringEscape String
s forall a. [a] -> [a] -> [a]
++ String
" */" ]

-- | Escape characters inside a C string.
cStringEscape :: String -> String
cStringEscape :: String -> String
cStringEscape = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escChar
  where
    escChar :: Char -> String
escChar Char
c
      | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"\"\\" :: String) = Char
'\\'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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ forall {a}. String -> a -> [a]
ifC String
catString  [ String
"%token<_string>", String
"_STRING_"  ]
  , forall {a}. String -> a -> [a]
ifC String
catChar    [ String
"%token<_char>  ", String
"_CHAR_"    ]
  , forall {a}. String -> a -> [a]
ifC String
catInteger [ String
"%token<_int>   ", String
"_INTEGER_" ]
  , forall {a}. String -> a -> [a]
ifC String
catDouble  [ String
"%token<_double>", String
"_DOUBLE_"  ]
  , forall {a}. String -> a -> [a]
ifC String
catIdent   [ String
"%token<_string>", String
"_IDENT_"   ]
  ]
  where
    ifC :: String -> a -> [a]
ifC String
cat a
s = if 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 = forall a b. (a -> b) -> [a] -> [b]
map (NonTerminal, [Rule]) -> (NonTerminal, [(String, String)])
mkOne (CF -> [(NonTerminal, [Rule])]
ruleGroups CF
cf) 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 = forall a b. [a] -> (a -> b) -> [b]
for (CF -> [String]
positionCats CF
cf) forall a b. (a -> b) -> a -> b
$ \ String
n -> (String -> NonTerminal
TokenCat String
n,
      [( 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) forall a b. (a -> b) -> a -> b
$ 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,) forall a b. (a -> b) -> a -> b
$
    [ (String
p,) forall a b. (a -> b) -> a -> b
$ CF -> NonTerminal -> String -> String
addResult CF
cf NonTerminal
nt forall a b. (a -> b) -> a -> b
$ 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)) (forall function. Rul function -> function
funRule Rule
r) Bool
b [(String, Bool)]
m
    | Rule
r0 <- [Rule]
rules
    , let (Bool
b,Rule
r) = if forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rule
r0) Bool -> Bool -> Bool
&& forall fun. Rul fun -> NonTerminal
valCat Rule
r0 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall f. CFG f -> [NonTerminal]
cfgReversibleCats CF
cf
                  then (Bool
True, 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall f. CFG f -> List1 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 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
_ -> 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 -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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
  | forall a. IsFun a => a -> Bool
isCoercion a
f = String
"$$ = " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ms forall a. [a] -> [a] -> [a]
++ String
";" forall a. [a] -> [a] -> [a]
++ String
loc
  | forall a. IsFun a => a -> Bool
isNilFun a
f   = String
"$$ = 0;"
  | forall a. IsFun a => a -> Bool
isOneFun a
f   = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String -> String
new String
nt, String
"(", forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms', String
", 0);"]
  | forall a. IsFun a => a -> Bool
isConsFun a
f  = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String -> String
new String
nt, String
"(", forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms', String
");"]
  | Bool
otherwise    = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String -> String
new (forall a. IsFun a => a -> String
funName a
f), String
"(", forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms', String
");", String
loc]
 where
  ms' :: [String]
ms' = if Bool
b then 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_" forall a. [a] -> [a] -> [a]
++)
      | Bool
otherwise = \ String
s -> if Char -> Bool
isUpper (forall a. [a] -> a
head String
s) then String
"new " 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 forall a. [a] -> [a] -> [a]
++
  if | forall a. IsFun a => a -> Bool
isCoercion a
f    -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", [String] -> String
unwords [String]
ms, String
";", String
loc]
     | forall a. IsFun a => a -> Bool
isNilFun a
f      -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
"new ", String
scope, String
nt, String
"();"]
     | forall a. IsFun a => a -> Bool
isOneFun a
f      -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
"new ", String
scope, String
nt, String
"(); $$->push_back(", forall a. [a] -> a
head [String]
ms, String
");"]
     | forall a. IsFun a => a -> Bool
isConsFun a
f     -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
lst, String
"->push_back(", String
el, String
"); $$ = ", String
lst, String
";"]
     | forall a. IsFun a => a -> Bool
isDefinedRule a
f -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
scope, String -> String
sanitizeCpp (forall a. IsFun a => a -> String
funName a
f), String
"(", forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms, String
");" ]
     | Bool
otherwise       -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
"new ", String
scope, forall a. IsFun a => a -> String
funName a
f, String
"(", forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms, String
");", String
loc]
 where
  ms :: [String]
ms        = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, Bool)]
mbs
  -- The following match only happens in the cons case:
  [String
el, String
lst] = forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b 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(" forall a. [a] -> [a] -> [a]
++ String
m forall a. [a] -> [a] -> [a]
++String
"->begin(),"forall a. [a] -> [a] -> [a]
++String
mforall 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 forall function. Rul function -> SentForm
rhsRule Rule
r of
  []  -> (String
"/* empty */",[])
  SentForm
its -> ([String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map Either NonTerminal String -> String
mkIt SentForm
its), 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
&& forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
s
                   -> String -> String
typeName String
s
       | Bool
otherwise -> 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 -> 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
'$'forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
i), NonTerminal -> Bool
revert NonTerminal
c) | (Int
i, Left NonTerminal
c) <- 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
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NonTerminal
c [NonTerminal]
revs
                 then String
"reverse" forall a. [a] -> [a] -> [a]
++ NonTerminal -> String
identCat (NonTerminal -> NonTerminal
normCat NonTerminal
c) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
m 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
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem NonTerminal
c [NonTerminal]
revs
   revs :: [NonTerminal]
revs     = forall f. CFG f -> [NonTerminal]
cfgReversibleCats CF
cf
   isntCons :: Bool
isntCons = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. IsFun a => a -> Bool
isConsFun forall a b. (a -> b) -> a -> b
$ 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' forall a. a -> [a] -> [a]
: [(String, String)] -> String
pr [(String, String)]
ls] forall a. [a] -> [a] -> [a]
++ String
";\n" 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
"}"]] 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_" forall a. [a] -> [a] -> [a]
++ String
s 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
"_" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s
  NonTerminal
c          -> (forall a. [a] -> [a] -> [a]
++ String
"_") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonTerminal -> String
identCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonTerminal -> NonTerminal
normCat 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