{-
    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
-}

{-# 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 qualified Data.Map as Map

import BNFC.CF
import BNFC.Backend.Common.NamedVariables hiding (varName)
import BNFC.Options (RecordPositions(..))
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 :: RecordPositions -> String -> CF -> SymMap -> String
cf2Bison :: RecordPositions -> String -> CF -> SymMap -> String
cf2Bison RecordPositions
rp String
name CF
cf SymMap
env = [String] -> String
unlines
    [ String -> CF -> String
header String
name CF
cf
    , [Cat] -> String
union (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCatsNorm CF
cf)
    , String
"%token _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
declarations CF
cf
    , CF -> String
specialToks CF
cf
    , CF -> String
startSymbol CF
cf
    , String
""
    , String
"%%"
    , String
""
    , Rules -> String
prRules (RecordPositions -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp CF
cf SymMap
env)
    , String
"%%"
    , String
""
    , String -> String
errorHandler String
name
    ]

header :: String -> CF -> String
header :: String -> CF -> String
header String
name CF
cf = [String] -> String
unlines
    [ String
"/* This Bison file was machine-generated by BNFC */"
    , 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
"%{"
    , String
"/* Begin C preamble code */"
    , String
""
    , String
"#include <stdlib.h>"
    , String
"#include <stdio.h>"
    , String
"#include <string.h>"
    , String
"#include \"Absyn.h\""
    , String
""
    , String
"#define YYMAXDEPTH 10000000"  -- default maximum stack size is 10000, but right-recursion needs O(n) stack
    , String
""
    , String
"typedef struct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_buffer_state *YY_BUFFER_STATE;"
    , String
"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);"
    , String
"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);"
    , String
"extern int yyparse(void);"
    , String
"extern int yylex(void);"
    , String
"extern int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_init_lexer(FILE * inp);"
      -- this must be deferred until yylloc is defined
    , String
"extern void yyerror(const char *str);"
    , String
""
    , (Cat -> String) -> [Cat] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> String
reverseList ([Cat] -> String) -> [Cat] -> String
forall a b. (a -> b) -> a -> b
$ (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
isList ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCatsNorm CF
cf
    , String
"/* Global variables holding parse results for entrypoints. */"
    , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
parseResult ([Cat] -> [String]) -> [Cat] -> [String]
forall a b. (a -> b) -> a -> b
$ [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ (Cat -> Cat) -> [Cat] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat [Cat]
eps
    , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> String -> Cat -> String
parseMethod CF
cf String
name) [Cat]
eps
    , String
"/* End C preamble code */"
    , String
"%}"
    ]
  where
  eps :: [Cat]
eps = NonEmpty Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
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.

-- | 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 -> String
parseResult Cat
cat =
  String
dat String -> String -> String
+++ String -> String
resultName String
dat String -> String -> String
+++ String
"= 0;"
  where
  dat :: String
dat = Cat -> String
identCat Cat
cat

errorHandler :: String -> String
errorHandler :: String -> String
errorHandler String
name = [String] -> String
unlines
  [ String
"void yyerror(const char *str)"
  , String
"{"
  , String
"  extern char *" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"text;"
  , String
"  fprintf(stderr,\"error: %d,%d: %s at %s\\n\","
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"lloc.first_line, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"lloc.first_column, str, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"text);"
  , String
"}"
  ]

--This generates a parser method for each entry point.
parseMethod :: CF -> String -> Cat -> String
parseMethod :: CF -> String -> Cat -> String
parseMethod CF
cf String
name Cat
cat = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [ [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)"
  , String
"{"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_init_lexer(inp);"
  , String
"  int result = yyparse();"
  , String
"  if (result)"
  , String
"  { /* Failure */"
  , String
"    return 0;"
  , String
"  }"
  , String
"  else"
  , String
"  { /* Success */"
  , String
"    return" String -> String -> String
+++ String
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
  , String
"  }"
  , String
"}"
  , 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)"
  , String
"{"
  , String
"  YY_BUFFER_STATE buf;"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_init_lexer(0);"
  , String
"  buf = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_scan_string(str);"
  , String
"  int result = yyparse();"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_delete_buffer(buf);"
  , String
"  if (result)"
  , String
"  { /* Failure */"
  , String
"    return 0;"
  , String
"  }"
  , String
"  else"
  , String
"  { /* Success */"
  , String
"    return" String -> String -> String
+++ String
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
  , String
"  }"
  , String
"}"
  ]
  where
  dat :: String
dat    = Cat -> String
identCat (Cat -> Cat
normCat Cat
cat)
  parser :: String
parser = Cat -> String
identCat Cat
cat
  res0 :: String
res0   = String -> String
resultName String
dat
  revRes :: String
revRes = String
"reverse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dat 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
")"
  res :: String
res    = if Cat
cat Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [Cat]
forall f. CFG f -> [Cat]
cfgReversibleCats CF
cf then String
revRes else String
res0

--This method generates list reversal functions for each list type.
reverseList :: Cat -> String
reverseList :: Cat -> String
reverseList Cat
c = [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' = Cat -> String
identCat (Cat -> Cat
normCat Cat
c)
  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
"_"

--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 :: [Cat] -> String
union [Cat]
cats = [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
"/* The type of a parse result (yylval). */" ]
  , [ String
"%union"
    , String
"{"
    ]
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
unionBuiltinTokens
  , (Cat -> [String]) -> [Cat] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> [String]
mkPointer [Cat]
cats
  , [ String
"}"
    ]
  ]
--This is a little weird because people can make [Exp2] etc.
mkPointer :: Cat -> [String]
mkPointer :: Cat -> [String]
mkPointer Cat
c
  | Cat -> String
identCat Cat
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Cat -> String
forall a. Show a => a -> String
show Cat
c  --list. add it even if it refers to a coercion.
    Bool -> Bool -> Bool
|| Cat -> Cat
normCat Cat
c Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
c     --normal cat
    = [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
normCat Cat
c) String -> String -> String
+++ Cat -> String
varName (Cat -> Cat
normCat Cat
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" ]
  | Bool
otherwise = []

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

--declares non-terminal types.
declarations :: CF -> String
declarations :: CF -> String
declarations CF
cf = (Cat -> String) -> [Cat] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CF -> Cat -> String
typeNT CF
cf) (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf)
 where --don't define internal rules
   typeNT :: CF -> Cat -> String
typeNT CF
cf Cat
nt | CF -> Cat -> [Rule]
rulesForCat CF
cf Cat
nt [Rule] -> [Rule] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] = String
"%type <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
varName (Cat -> Cat
normCat Cat
nt) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat Cat
nt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
   typeNT CF
_ Cat
_ = String
""

--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 = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ 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]

specialToks :: CF -> String
specialToks :: CF -> String
specialToks 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 -> String -> [String]
forall a. String -> a -> [a]
ifC String
catString  String
"%token<_string> _STRING_"
  , String -> String -> [String]
forall a. String -> a -> [a]
ifC String
catChar    String
"%token<_char>   _CHAR_"
  , String -> String -> [String]
forall a. String -> a -> [a]
ifC String
catInteger String
"%token<_int>    _INTEGER_"
  , String -> String -> [String]
forall a. String -> a -> [a]
ifC String
catDouble  String
"%token<_double> _DOUBLE_"
  , String -> String -> [String]
forall a. String -> a -> [a]
ifC String
catIdent   String
"%token<_string> _IDENT_"
  ]
  where
    ifC :: String -> a -> [a]
ifC String
cat a
s = if CF -> Cat -> Bool
forall f. CFG f -> Cat -> Bool
isUsedCat CF
cf (String -> Cat
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
+++ Cat -> String
identCat (CF -> Cat
firstEntry CF
cf)

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: RecordPositions -> CF -> SymMap -> Rules
rulesForBison :: RecordPositions -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp CF
cf SymMap
env = ((Cat, [Rule]) -> (Cat, [(String, String)]))
-> [(Cat, [Rule])] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map (Cat, [Rule]) -> (Cat, [(String, String)])
mkOne ([(Cat, [Rule])] -> Rules) -> [(Cat, [Rule])] -> Rules
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf where
  mkOne :: (Cat, [Rule]) -> (Cat, [(String, String)])
mkOne (Cat
cat,[Rule]
rules) = RecordPositions
-> CF -> SymMap -> [Rule] -> Cat -> (Cat, [(String, String)])
constructRule RecordPositions
rp CF
cf SymMap
env [Rule]
rules Cat
cat

-- For every non-terminal, we construct a set of rules.
constructRule
  :: RecordPositions -> CF -> SymMap
  -> [Rule]                           -- ^ List of alternatives for parsing ...
  -> NonTerminal                      -- ^ ... this non-terminal.
  -> (NonTerminal,[(Pattern,Action)])
constructRule :: RecordPositions
-> CF -> SymMap -> [Rule] -> Cat -> (Cat, [(String, String)])
constructRule RecordPositions
rp CF
cf SymMap
env [Rule]
rules Cat
nt = (Cat
nt,) ([(String, String)] -> (Cat, [(String, String)]))
-> [(String, String)] -> (Cat, [(String, String)])
forall a b. (a -> b) -> a -> b
$
    [ (String
p,) (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
addResult (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ RecordPositions -> String -> RFun -> Bool -> [String] -> String
forall a.
IsFun a =>
RecordPositions -> String -> a -> Bool -> [String] -> String
generateAction RecordPositions
rp (Cat -> String
identCat (Cat -> Cat
normCat Cat
nt)) (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r) Bool
b [String]
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 -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r0 Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [Cat]
forall f. CFG f -> [Cat]
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]
m) = CF -> SymMap -> Rule -> (String, [String])
generatePatterns CF
cf SymMap
env Rule
r
    ]
  where
    -- Add action if we parse an entrypoint non-terminal:
    -- Set field in result record to current parse.
    addResult :: String -> String
addResult String
a =
      if Cat
nt Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf)
      -- Note: Bison has only a single entrypoint,
      -- but BNFC works around this by adding dedicated parse methods for all entrypoints.
        then String
a String -> String -> String
+++ String -> String
resultName (Cat -> String
identCat (Cat -> Cat
normCat Cat
nt)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"= $$;"
        else String
a

-- | 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 :: RecordPositions -> String -> a -> Bool -> [String] -> String
generateAction RecordPositions
rp String
nt a
f Bool
b [String]
ms
  | a -> Bool
forall a. IsFun a => a -> Bool
isCoercion a
f = [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
"make_", 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
"make_", 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
"make_", 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 = if RecordPositions
rp RecordPositions -> RecordPositions -> Bool
forall a. Eq a => a -> a -> Bool
== RecordPositions
RecordPositions then String
" $$->line_number = @$.first_line; $$->char_number = @$.first_column;" else String
""

-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymMap -> Rule -> (Pattern,[MetaVar])
generatePatterns :: CF -> SymMap -> Rule -> (String, [String])
generatePatterns 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 Cat String -> String) -> SentForm -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Either Cat String -> String
mkIt SentForm
its), SentForm -> [String]
forall b. [Either Cat b] -> [String]
metas SentForm
its)
 where
   mkIt :: Either Cat String -> String
mkIt Either Cat String
i = case Either Cat String
i of
     Left (TokenCat String
s) -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
typeName String
s) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> SymKey
Tokentype String
s) SymMap
env
     Left Cat
c  -> Cat -> String
identCat Cat
c
     Right String
s -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
s (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> SymKey
Keyword String
s) SymMap
env
   metas :: [Either Cat b] -> [String]
metas [Either Cat b]
its = [Cat -> String -> String
revIf Cat
c (Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i) | (Int
i,Left Cat
c) <- [Int] -> [Either Cat b] -> [(Int, Either Cat b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [Either Cat b]
its]
   revIf :: Cat -> String -> String
revIf Cat
c String
m = if Bool -> Bool
not (RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r)) Bool -> Bool -> Bool
&& Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Cat
c [Cat]
revs
                 then String
"reverse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (Cat -> Cat
normCat Cat
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
   revs :: [Cat]
revs = CF -> [Cat]
forall f. CFG f -> [Cat]
cfgReversibleCats CF
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 :: Rules -> String
prRules [] = []
prRules ((Cat
_, []):Rules
rs) = Rules -> String
prRules Rules
rs --internal rule
prRules ((Cat
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' = Cat -> String
identCat Cat
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 :: Cat -> 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
  Cat
c          -> (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String -> String) -> (Cat -> String) -> Cat -> 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) -> (Cat -> String) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> String
identCat (Cat -> String) -> (Cat -> Cat) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ Cat
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