{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

{-
    BNF Converter: C++ Bison generator
    Copyright (C) 2004  Author:  Michael Pellauer

    Description   : This module generates the Bison input file using
                    STL. The main difference to CFtoBison is in handling
                    lists: by using std::vector and push_back, our rules
                    for reverting lists are the opposite to linked lists.
                    Note that because of the way bison stores results
                    the programmer can increase performance by limiting
                    the number of entry points in their grammar.

    Author        : Michael Pellauer
    Created       : 6 August, 2003
    Modified      : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se)

-}

module BNFC.Backend.CPP.STL.CFtoBisonSTL
  ( cf2Bison
  , tokens, union
  , definedRules
  ) where

import Prelude hiding ((<>))

import Data.Char  ( isUpper )
import Data.Foldable (toList)
import Data.List  ( nub, intercalate )
import Data.Maybe ( fromMaybe )
import qualified Data.Map as Map

import BNFC.Backend.C.CFtoBisonC
  ( resultName, specialToks, startSymbol, typeName, unionBuiltinTokens, varName )
import BNFC.Backend.CPP.STL.STLUtils
import BNFC.Backend.Common.NamedVariables hiding (varName)
import BNFC.CF
import BNFC.Options (RecordPositions(..))
import BNFC.PrettyPrint
import BNFC.TypeChecker
import BNFC.Utils ((+++), when)

--This follows the basic structure of CFtoHappy.

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

--The environment comes from the CFtoFlex
cf2Bison :: RecordPositions -> Maybe String -> String -> CF -> SymMap -> String
cf2Bison :: RecordPositions -> Maybe String -> String -> CF -> SymMap -> String
cf2Bison RecordPositions
rp Maybe String
inPackage String
name CF
cf SymMap
env
 = [String] -> String
unlines
    [Maybe String -> String -> CF -> String
header Maybe String
inPackage String
name CF
cf,
     Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Maybe String -> [Cat] -> Doc
union Maybe String
inPackage ((String -> Cat) -> [String] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map String -> Cat
TokenCat (CF -> [String]
forall f. CFG f -> [String]
positionCats CF
cf) [Cat] -> [Cat] -> [Cat]
forall a. [a] -> [a] -> [a]
++ CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf),
     String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
ns -> String
"%define api.prefix {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy}") Maybe String
inPackage,
     String
"%token _ERROR_",
     [String] -> SymMap -> String
tokens [String]
user SymMap
env,
     CF -> String
declarations CF
cf,
     CF -> String
startSymbol CF
cf,
     CF -> String
specialToks CF
cf,
     String
"%%",
     Rules -> String
prRules (RecordPositions -> Maybe String -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp Maybe String
inPackage CF
cf SymMap
env)
    ]
  where
   user :: [String]
user = ([String], [Reg]) -> [String]
forall a b. (a, b) -> a
fst ([(String, Reg)] -> ([String], [Reg])
forall a b. [(a, b)] -> ([a], [b])
unzip (CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf))


positionCats :: CFG f -> [String]
positionCats CFG f
cf = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (CFG f -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CFG f
cf) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], [Reg]) -> [String]
forall a b. (a, b) -> a
fst ([(String, Reg)] -> ([String], [Reg])
forall a b. [(a, b)] -> ([a], [b])
unzip (CFG f -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf))

header :: Maybe String -> String -> CF -> String
header :: Maybe String -> String -> CF -> String
header Maybe String
inPackage String
name CF
cf = [String] -> String
unlines
    [ String
"/* This Bison file was machine-generated by BNFC */"
    , String
"%{"
    , String
"#include <stdlib.h>"
    , String
"#include <stdio.h>"
    , String
"#include <string.h>"
    , String
"#include <algorithm>"
    , String
"#include \"ParserError.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 yy_buffer_state *YY_BUFFER_STATE;"
    , String
"int yyparse(void);"
    , String
"int yylex(void);"
    , String
"YY_BUFFER_STATE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_scan_string(const char *str);"
    , String
"void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_delete_buffer(YY_BUFFER_STATE buf);"
    , String
"int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber;"  --- hack to get line number. AR 2006
    , String
"void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"initialize_lexer(FILE * inp);"
    , String
"int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yywrap(void)"
    , String
"{"
    , String
"  return 1;"
    , String
"}"
    , String
"void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yyerror(const char *str)"
    , String
"{"
    , String
"  throw "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nsString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"::parse_error("String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber,str);"
    , String
"}"
    , String
""
    , Maybe String -> String
nsStart Maybe String
inPackage
    , CF -> String
definedRules CF
cf
    , [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]
dats
    , [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 -> Maybe String -> String -> Cat -> String
parseMethod CF
cf Maybe String
inPackage String
name) [Cat]
eps
    , Maybe String -> String
nsEnd Maybe String
inPackage
    , String
"%}"
    ]
  where
    ns :: String
ns   = Maybe String -> String
nsString Maybe String
inPackage
    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) [Cat] -> [Cat] -> [Cat]
forall a. [a] -> [a] -> [a]
++ (String -> Cat) -> [String] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map String -> Cat
TokenCat (CF -> [String]
forall f. CFG f -> [String]
positionCats CF
cf)
    dats :: [Cat]
dats = [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

definedRules :: CF -> String
definedRules :: CF -> String
definedRules CF
cf =
    [String] -> String
unlines [ RFun -> [String] -> Exp -> String
rule RFun
f [String]
xs Exp
e | FunDef RFun
f [String]
xs Exp
e <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  where
    ctx :: Context
ctx = CF -> Context
buildContext CF
cf

    list :: ListConstructors
list = (Base -> String) -> (Base -> String) -> ListConstructors
LC (String -> Base -> String
forall a b. a -> b -> a
const String
"[]") (\ Base
t -> String
"List" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Base -> String
unBase Base
t)
      where
        unBase :: Base -> String
unBase (ListT Base
t) = Base -> String
unBase Base
t
        unBase (BaseT String
x) = Cat -> String
forall a. Show a => a -> String
show (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
x

    rule :: RFun -> [String] -> Exp -> String
rule RFun
f [String]
xs Exp
e =
        case Err (Telescope, (Exp, Base))
-> Either String (Telescope, (Exp, Base))
forall a. Err a -> Either String a
runTypeChecker (Err (Telescope, (Exp, Base))
 -> Either String (Telescope, (Exp, Base)))
-> Err (Telescope, (Exp, Base))
-> Either String (Telescope, (Exp, Base))
forall a b. (a -> b) -> a -> b
$ ListConstructors
-> Context
-> RFun
-> [String]
-> Exp
-> Err (Telescope, (Exp, Base))
checkDefinition' ListConstructors
list Context
ctx RFun
f [String]
xs Exp
e of
        Left String
err -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Panic! This should have been caught already:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
        Right (Telescope
args,(Exp
e',Base
t)) -> [String] -> String
unlines
            [ Base -> String
cppType Base
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RFun -> String
forall a. IsFun a => a -> String
funName RFun
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_ (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((String, Base) -> String) -> Telescope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Base) -> String
cppArg Telescope
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") {"
            , String
"  return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp -> String
cppExp Exp
e' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
            , String
"}"
            ]
      where
        cppType :: Base -> String
        cppType :: Base -> String
cppType (ListT (BaseT String
x)) = String
"List" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
forall a. Show a => a -> String
show (Cat -> Cat
normCat (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" *"
        cppType (ListT Base
t)         = Base -> String
cppType Base
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" *"
        cppType (BaseT String
x)
            | String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
baseTokenCatNames = String
x
            | String -> Context -> Bool
isToken String
x Context
ctx = String
"String"
            | Bool
otherwise     = Cat -> String
forall a. Show a => a -> String
show (Cat -> Cat
normCat (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" *"

        cppArg :: (String, Base) -> String
        cppArg :: (String, Base) -> String
cppArg (String
x,Base
t) = Base -> String
cppType Base
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"

        cppExp :: Exp -> String
        cppExp :: Exp -> String
cppExp (App String
"[]" [])    = String
"0"
        cppExp (Var String
x)          = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"  -- argument
        cppExp (App String
t [Exp
e])
            | String -> Context -> Bool
isToken String
t Context
ctx     = Exp -> String
cppExp Exp
e
        cppExp (App String
x [Exp]
es)
            | Char -> Bool
isUpper (String -> Char
forall a. [a] -> a
head String
x)  = String -> [Exp] -> String
call (String
"new " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) [Exp]
es
            | Bool
otherwise         = String -> [Exp] -> String
call (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") [Exp]
es
        cppExp (LitInt Integer
n)       = Integer -> String
forall a. Show a => a -> String
show Integer
n
        cppExp (LitDouble Double
x)    = Double -> String
forall a. Show a => a -> String
show Double
x
        cppExp (LitChar Char
c)      = Char -> String
forall a. Show a => a -> String
show Char
c
        cppExp (LitString String
s)    = String -> String
forall a. Show a => a -> String
show String
s

        call :: String -> [Exp] -> String
call String
x [Exp]
es = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Exp -> String) -> [Exp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> String
cppExp [Exp]
es) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"


-- | 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
"static " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*" String -> String -> String
+++ String -> String
resultName String
cat' String -> String -> String
+++ String
"= 0;"
  where
  cat' :: String
cat' = Cat -> String
identCat Cat
cat

--This generates a parser method for each entry point.
parseMethod :: CF -> Maybe String -> String -> Cat -> String
parseMethod :: CF -> Maybe String -> String -> Cat -> String
parseMethod CF
cf Maybe String
inPackage String
_ Cat
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
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"* p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
par String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(FILE *inp)"
    , String
"{"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber = 1;"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"initialize_lexer(inp);"
    , String
"  if (yyparse())"
    , 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
"}"
    , String
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"* p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
par String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(const char *str)"
    , String
"{"
    , String
"  YY_BUFFER_STATE buf;"
    , String
"  int result;"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber = 1;"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"initialize_lexer(0);"
    , String
"  buf = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_scan_string(str);"
    , String
"  result = yyparse();"
    , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_delete_buffer(buf);"
    , String
"  if (result)"
    , 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
  cat' :: String
cat' = Cat -> String
identCat (Cat -> Cat
normCat Cat
cat)
  par :: String
par  = Cat -> String
identCat Cat
cat
  ns :: String
ns   = Maybe String -> String
nsString Maybe String
inPackage
  res :: String
res  = String -> String
resultName String
cat'
  -- Vectors are snoc lists
  revOpt :: [String]
revOpt = Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when (Cat -> Bool
isList Cat
cat Bool -> Bool -> Bool
&& Cat
cat Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` CF -> [Cat]
forall f. CFG f -> [Cat]
cfgReversibleCats CF
cf)
             [ 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());" ]

-- | The union declaration is special to Bison/Yacc and gives the type of
-- yylval.  For efficiency, we may want to only include used categories here.
--
-- >>> let foo = Cat "Foo"
-- >>> union Nothing [foo, ListCat foo]
-- %union
-- {
--   int    _int;
--   char   _char;
--   double _double;
--   char*  _string;
--   Foo* foo_;
--   ListFoo* listfoo_;
-- }
--
-- If the given list of categories is contains coerced categories, those should
-- be normalized and duplicate removed
-- E.g. if there is both [Foo] and [Foo2] we should only print one pointer:
--    ListFoo* listfoo_;
--
-- >>> let foo2 = CoercCat "Foo" 2
-- >>> union Nothing [foo, ListCat foo, foo2, ListCat foo2]
-- %union
-- {
--   int    _int;
--   char   _char;
--   double _double;
--   char*  _string;
--   Foo* foo_;
--   ListFoo* listfoo_;
-- }
union :: Maybe String -> [Cat] -> Doc
union :: Maybe String -> [Cat] -> Doc
union Maybe String
inPackage [Cat]
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]
++ (Cat -> Doc) -> [Cat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Doc
mkPointer [Cat]
normCats
    ]
  where
    normCats :: [Cat]
normCats = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ((Cat -> Cat) -> [Cat] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat [Cat]
cats)
    mkPointer :: Cat -> Doc
mkPointer Cat
s = Doc
scope Doc -> Doc -> Doc
<> String -> Doc
text (Cat -> String
identCat Cat
s) Doc -> Doc -> Doc
<> Doc
"*" Doc -> Doc -> Doc
<+> String -> Doc
text (Cat -> String
varName Cat
s) Doc -> Doc -> Doc
<> Doc
";"
    scope :: Doc
scope = String -> Doc
text (Maybe String -> String
nsScope Maybe String
inPackage)

--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 Cat -> String
typeNT ([Cat] -> String) -> [Cat] -> String
forall a b. (a -> b) -> a -> b
$
  (String -> Cat) -> [String] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map String -> Cat
TokenCat (CF -> [String]
forall f. CFG f -> [String]
positionCats CF
cf) [Cat] -> [Cat] -> [Cat]
forall a. [a] -> [a] -> [a]
++
  (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Cat -> Bool) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Rule] -> Bool) -> (Cat -> [Rule]) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Cat -> [Rule]
rulesForCat CF
cf) (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf) -- don't define internal rules
  where
  typeNT :: Cat -> String
typeNT Cat
nt = String
"%type <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
varName 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"

--declares terminal types.
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] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"%token", String
t, String
" ", String
r, String
"    //   ", String
s ]

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs

rulesForBison :: RecordPositions -> Maybe String -> CF -> SymMap -> Rules
rulesForBison :: RecordPositions -> Maybe String -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp Maybe String
inPackage 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 (CF -> [(Cat, [Rule])]
ruleGroups CF
cf) Rules -> Rules -> Rules
forall a. [a] -> [a] -> [a]
++ Rules
posRules
  where
  mkOne :: (Cat, [Rule]) -> (Cat, [(String, String)])
mkOne (Cat
cat,[Rule]
rules) = RecordPositions
-> Maybe String
-> CF
-> SymMap
-> [Rule]
-> Cat
-> (Cat, [(String, String)])
constructRule RecordPositions
rp Maybe String
inPackage CF
cf SymMap
env [Rule]
rules Cat
cat
  posRules :: Rules
posRules = ((String -> (Cat, [(String, String)])) -> [String] -> Rules
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [String]
forall f. CFG f -> [String]
positionCats CF
cf) ((String -> (Cat, [(String, String)])) -> Rules)
-> (String -> (Cat, [(String, String)])) -> Rules
forall a b. (a -> b) -> a -> b
$ \ String
n -> (String -> Cat
TokenCat String
n,
    [( String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
n (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
n) SymMap
env
     , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ String
"$$ = new ", Maybe String -> String
nsScope Maybe String
inPackage, String
n, String
"($1, ", Maybe String -> String
nsString Maybe String
inPackage, String
"yy_mylinenumber); "
         , Maybe String -> String
nsScope Maybe String
inPackage, String
"YY_RESULT_", String
n, String
"_= $$;"
         ]
     )])

-- For every non-terminal, we construct a set of rules.
constructRule ::
  RecordPositions -> Maybe String -> CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule :: RecordPositions
-> Maybe String
-> CF
-> SymMap
-> [Rule]
-> Cat
-> (Cat, [(String, String)])
constructRule RecordPositions
rp Maybe String
inPackage CF
cf SymMap
env [Rule]
rules Cat
nt =
  (Cat
nt,[(String
p, RecordPositions
-> Maybe String
-> Cat
-> String
-> Bool
-> [(String, Bool)]
-> String
generateAction RecordPositions
rp Maybe String
inPackage Cat
nt (RFun -> String
forall a. IsFun a => a -> String
funName (RFun -> String) -> RFun -> String
forall a b. (a -> b) -> a -> b
$ Rule -> RFun
forall function. Rul function -> function
ruleName Rule
r) Bool
b [(String, Bool)]
m String -> String -> String
+++ String
result) |
     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
&& Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r0) [Cat]
revs
                   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) = CF -> SymMap -> Rule -> Bool -> (String, [(String, Bool)])
generatePatterns CF
cf SymMap
env Rule
r Bool
b])
 where
   ruleName :: Rul function -> function
ruleName Rul function
r = case Rul function -> function
forall function. Rul function -> function
funRule Rul function
r of
     ---- "(:)" -> identCat nt
     ---- "(:[])" -> identCat nt
     function
z -> function
z
   revs :: [Cat]
revs = CF -> [Cat]
forall f. CFG f -> [Cat]
cfgReversibleCats CF
cf
   eps :: [Cat]
eps = NonEmpty Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Cat -> [Cat]) -> NonEmpty Cat -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf
   isEntry :: Cat -> Bool
isEntry Cat
nt = Cat
nt Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cat]
eps
   result :: String
result = if Cat -> Bool
isEntry Cat
nt then (Maybe String -> String
nsScope Maybe String
inPackage String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
resultName (Cat -> String
identCat (Cat -> Cat
normCat Cat
nt))) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"= $$;" else String
""

-- Generates a string containing the semantic action.
generateAction :: RecordPositions -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action
generateAction :: RecordPositions
-> Maybe String
-> Cat
-> String
-> Bool
-> [(String, Bool)]
-> String
generateAction RecordPositions
rp Maybe String
inPackage Cat
cat String
f Bool
b [(String, Bool)]
mbs =
  String
reverses String -> String -> String
forall a. [a] -> [a] -> [a]
++
  if String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
f
  then String
"$$ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
  else if String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"[]"
  then [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ",String
"new ", String
scope, Cat -> String
identCatV Cat
cat, String
"();"]
  else if String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(:[])"
  then [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ",String
"new ", String
scope, Cat -> String
identCatV Cat
cat, String
"() ; $$->push_back($1);"]
  else if String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(:)" Bool -> Bool -> Bool
&& Bool
b
  then String
"$1->push_back("String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lastms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ; $$ = $1 ;"
  else if String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(:)"
  then String
lastms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->push_back(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ; $$ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lastms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ;" ---- not left rec
  else if String -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule String
f
  then [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"$$ = ", String
scope, String
f, String
"_", String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms, String
");" ]
  else [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [String
"$$ = ", String
"new ", String
scope, String
f, String
"(", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
ms, String
");" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RecordPositions -> String
addLn RecordPositions
rp]
 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
  lastms :: String
lastms = [String] -> String
forall a. [a] -> a
last [String]
ms
  addLn :: RecordPositions -> String
addLn RecordPositions
rp = if RecordPositions
rp RecordPositions -> RecordPositions -> Bool
forall a. Eq a => a -> a -> Bool
== RecordPositions
RecordPositions then String
" $$->line_number = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
nsString Maybe String
inPackage String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber;" else String
""  -- O.F.
  identCatV :: Cat -> String
identCatV = Cat -> String
identCat (Cat -> String) -> (Cat -> Cat) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat
  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 :: CF -> SymMap -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])
generatePatterns :: CF -> SymMap -> Rule -> Bool -> (String, [(String, Bool)])
generatePatterns CF
cf SymMap
env Rule
r Bool
_ = 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, Bool)]
forall b. [Either Cat b] -> [(String, Bool)]
metas SentForm
its)
 where
   mkIt :: Either Cat String -> String
mkIt = \case
     Left (TokenCat String
s)
       | CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
s -> String -> String
typeName String
s
       | Bool
otherwise -> 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, Bool)]
metas [Either Cat b]
its = [(Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i,Cat -> Bool
revert Cat
c) | (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]

   -- notice: reversibility with push_back vectors is the opposite
   -- of right-recursive lists!
   revert :: Cat -> Bool
revert Cat
c = Cat -> Bool
isList Cat
c Bool -> Bool -> Bool
&& 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
notElem Cat
c [Cat]
revs
   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
"}", String
"\n" String -> 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