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


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

header :: Maybe String -> String -> CF -> String
header :: Maybe [Char] -> [Char] -> CF -> [Char]
header Maybe [Char]
inPackage [Char]
name CF
cf = [[Char]] -> [Char]
unlines
    [ [Char]
"/* This Bison file was machine-generated by BNFC */"
    , [Char]
"%{"
    , [Char]
"#include <stdlib.h>"
    , [Char]
"#include <stdio.h>"
    , [Char]
"#include <string.h>"
    , [Char]
"#include <algorithm>"
    , [Char]
"#include \"ParserError.H\""
    , [Char]
"#include \"Absyn.H\""
    , [Char]
""
    , [Char]
"#define YYMAXDEPTH 10000000"  -- default maximum stack size is 10000, but right-recursion needs O(n) stack
    , [Char]
""
    , [Char]
"typedef struct yy_buffer_state *YY_BUFFER_STATE;"
    , [Char]
"int yyparse(void);"
    , [Char]
"int yylex(void);"
    , [Char]
"YY_BUFFER_STATE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_scan_string(const char *str);"
    , [Char]
"void " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_delete_buffer(YY_BUFFER_STATE buf);"
    , [Char]
"int " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_mylinenumber;"  --- hack to get line number. AR 2006
    , [Char]
"void " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"initialize_lexer(FILE * inp);"
    , [Char]
"int " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yywrap(void)"
    , [Char]
"{"
    , [Char]
"  return 1;"
    , [Char]
"}"
    , [Char]
"void " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yyerror(const char *str)"
    , [Char]
"{"
    , [Char]
"  throw "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
ns[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"::parse_error("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_mylinenumber,str);"
    , [Char]
"}"
    , [Char]
""
    , Maybe [Char] -> [Char]
nsStart Maybe [Char]
inPackage
    , CF -> [Char]
definedRules CF
cf
    , [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> [Char]
parseResult [Cat]
dats
    , [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> Maybe [Char] -> [Char] -> Cat -> [Char]
parseMethod CF
cf Maybe [Char]
inPackage [Char]
name) [Cat]
eps
    , Maybe [Char] -> [Char]
nsEnd Maybe [Char]
inPackage
    , [Char]
"%}"
    ]
  where
    ns :: [Char]
ns   = Maybe [Char] -> [Char]
nsString Maybe [Char]
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]
++ ([Char] -> Cat) -> [[Char]] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Cat
TokenCat (CF -> [[Char]]
forall {f}. CFG f -> [[Char]]
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 -> [Char]
definedRules CF
cf =
    [[Char]] -> [Char]
unlines [ RFun -> [[Char]] -> Exp -> [Char]
rule RFun
f [[Char]]
xs Exp
e | FunDef RFun
f [[Char]]
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 -> [Char]) -> (Base -> [Char]) -> ListConstructors
LC ([Char] -> Base -> [Char]
forall a b. a -> b -> a
const [Char]
"[]") (\ Base
t -> [Char]
"List" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Base -> [Char]
unBase Base
t)
      where
        unBase :: Base -> [Char]
unBase (ListT Base
t) = Base -> [Char]
unBase Base
t
        unBase (BaseT [Char]
x) = Cat -> [Char]
forall a. Show a => a -> [Char]
show (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ [Char] -> Cat
strToCat [Char]
x

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

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

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

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


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

--This generates a parser method for each entry point.
parseMethod :: CF -> Maybe String -> String -> Cat -> String
parseMethod :: CF -> Maybe [Char] -> [Char] -> Cat -> [Char]
parseMethod CF
cf Maybe [Char]
inPackage [Char]
_ Cat
cat = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ [Char]
cat' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"* p" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
par [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(FILE *inp)"
    , [Char]
"{"
    , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_mylinenumber = 1;"
    , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"initialize_lexer(inp);"
    , [Char]
"  if (yyparse())"
    , [Char]
"  { /* Failure */"
    , [Char]
"    return 0;"
    , [Char]
"  }"
    , [Char]
"  else"
    , [Char]
"  { /* Success */"
    ]
  , [[Char]]
revOpt
  , [ [Char]
"    return" [Char] -> [Char] -> [Char]
+++ [Char]
res [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
    , [Char]
"  }"
    , [Char]
"}"
    , [Char]
cat' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"* p" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
par [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(const char *str)"
    , [Char]
"{"
    , [Char]
"  YY_BUFFER_STATE buf;"
    , [Char]
"  int result;"
    , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_mylinenumber = 1;"
    , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"initialize_lexer(0);"
    , [Char]
"  buf = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_scan_string(str);"
    , [Char]
"  result = yyparse();"
    , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ns [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_delete_buffer(buf);"
    , [Char]
"  if (result)"
    , [Char]
"  { /* Failure */"
    , [Char]
"    return 0;"
    , [Char]
"  }"
    , [Char]
"  else"
    , [Char]
"  { /* Success */"
    ]
  , [[Char]]
revOpt
  , [ [Char]
"    return" [Char] -> [Char] -> [Char]
+++ [Char]
res [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
    , [Char]
"  }"
    , [Char]
"}"
    ]
  ]
  where
  cat' :: [Char]
cat' = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)
  par :: [Char]
par  = Cat -> [Char]
identCat Cat
cat
  ns :: [Char]
ns   = Maybe [Char] -> [Char]
nsString Maybe [Char]
inPackage
  res :: [Char]
res  = [Char] -> [Char]
resultName [Char]
cat'
  -- Vectors are snoc lists
  revOpt :: [[Char]]
revOpt = Bool -> [[Char]] -> [[Char]]
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)
             [ [Char]
"std::reverse(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
res [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->begin(), " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
res [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"->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 [Char] -> [Cat] -> Doc
union Maybe [Char]
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
$ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text [[Char]]
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
<> [Char] -> Doc
text (Cat -> [Char]
identCat Cat
s) Doc -> Doc -> Doc
<> Doc
"*" Doc -> Doc -> Doc
<+> [Char] -> Doc
text (Cat -> [Char]
varName Cat
s) Doc -> Doc -> Doc
<> Doc
";"
    scope :: Doc
scope = [Char] -> Doc
text (Maybe [Char] -> [Char]
nsScope Maybe [Char]
inPackage)

--declares non-terminal types.
declarations :: CF -> String
declarations :: CF -> [Char]
declarations CF
cf = (Cat -> [Char]) -> [Cat] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> [Char]
typeNT ([Cat] -> [Char]) -> [Cat] -> [Char]
forall a b. (a -> b) -> a -> b
$
  ([Char] -> Cat) -> [[Char]] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Cat
TokenCat (CF -> [[Char]]
forall {f}. CFG f -> [[Char]]
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 -> [Char]
typeNT Cat
nt = [Char]
"%type <" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
varName Cat
nt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
identCat Cat
nt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

--declares terminal types.
tokens :: [UserDef] -> SymMap -> String
tokens :: [[Char]] -> SymMap -> [Char]
tokens [[Char]]
user SymMap
env = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((SymKey, [Char]) -> [Char]) -> [(SymKey, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (SymKey, [Char]) -> [Char]
declTok ([(SymKey, [Char])] -> [[Char]]) -> [(SymKey, [Char])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ SymMap -> [(SymKey, [Char])]
forall k a. Map k a -> [(k, a)]
Map.toList SymMap
env
  where
  declTok :: (SymKey, [Char]) -> [Char]
declTok (Keyword   [Char]
s, [Char]
r) = [Char] -> [Char] -> [Char] -> [Char]
tok [Char]
"" [Char]
s [Char]
r
  declTok (Tokentype [Char]
s, [Char]
r) = [Char] -> [Char] -> [Char] -> [Char]
tok (if [Char]
s [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
user then [Char]
"<_string>" else [Char]
"") [Char]
s [Char]
r
  tok :: [Char] -> [Char] -> [Char] -> [Char]
tok [Char]
t [Char]
s [Char]
r = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
"%token", [Char]
t, [Char]
" ", [Char]
r, [Char]
"    //   ", [Char]
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 [Char] -> CF -> SymMap -> Rules
rulesForBison RecordPositions
rp Maybe [Char]
inPackage CF
cf SymMap
env = ((Cat, [Rule]) -> (Cat, [([Char], [Char])]))
-> [(Cat, [Rule])] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map (Cat, [Rule]) -> (Cat, [([Char], [Char])])
mkOne (CF -> [(Cat, [Rule])]
ruleGroups CF
cf) Rules -> Rules -> Rules
forall a. [a] -> [a] -> [a]
++ Rules
posRules
  where
  mkOne :: (Cat, [Rule]) -> (Cat, [([Char], [Char])])
mkOne (Cat
cat,[Rule]
rules) = RecordPositions
-> Maybe [Char]
-> CF
-> SymMap
-> [Rule]
-> Cat
-> (Cat, [([Char], [Char])])
constructRule RecordPositions
rp Maybe [Char]
inPackage CF
cf SymMap
env [Rule]
rules Cat
cat
  posRules :: Rules
posRules = (([Char] -> (Cat, [([Char], [Char])])) -> [[Char]] -> Rules
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [[Char]]
forall {f}. CFG f -> [[Char]]
positionCats CF
cf) (([Char] -> (Cat, [([Char], [Char])])) -> Rules)
-> ([Char] -> (Cat, [([Char], [Char])])) -> Rules
forall a b. (a -> b) -> a -> b
$ \ [Char]
n -> ([Char] -> Cat
TokenCat [Char]
n,
    [( [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
n (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> SymKey
Tokentype [Char]
n) SymMap
env
     , [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ [Char]
"$$ = new ", Maybe [Char] -> [Char]
nsScope Maybe [Char]
inPackage, [Char]
n, [Char]
"($1, ", Maybe [Char] -> [Char]
nsString Maybe [Char]
inPackage, [Char]
"yy_mylinenumber); "
         , Maybe [Char] -> [Char]
nsScope Maybe [Char]
inPackage, [Char]
"YY_RESULT_", [Char]
n, [Char]
"_= $$;"
         ]
     )])

-- For every non-terminal, we construct a set of rules.
constructRule ::
  RecordPositions -> Maybe String -> CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule :: RecordPositions
-> Maybe [Char]
-> CF
-> SymMap
-> [Rule]
-> Cat
-> (Cat, [([Char], [Char])])
constructRule RecordPositions
rp Maybe [Char]
inPackage CF
cf SymMap
env [Rule]
rules Cat
nt =
  (Cat
nt,[([Char]
p, RecordPositions
-> Maybe [Char]
-> Cat
-> [Char]
-> Bool
-> [([Char], Bool)]
-> [Char]
generateAction RecordPositions
rp Maybe [Char]
inPackage Cat
nt (RFun -> [Char]
forall a. IsFun a => a -> [Char]
funName (RFun -> [Char]) -> RFun -> [Char]
forall a b. (a -> b) -> a -> b
$ Rule -> RFun
forall {function}. Rul function -> function
ruleName Rule
r) Bool
b [([Char], Bool)]
m [Char] -> [Char] -> [Char]
+++ [Char]
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 ([Char]
p,[([Char], Bool)]
m) = CF -> SymMap -> Rule -> Bool -> ([Char], [([Char], 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 :: [Char]
result = if Cat -> Bool
isEntry Cat
nt then (Maybe [Char] -> [Char]
nsScope Maybe [Char]
inPackage [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
resultName (Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
nt))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"= $$;" else [Char]
""

-- Generates a string containing the semantic action.
generateAction :: RecordPositions -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action
generateAction :: RecordPositions
-> Maybe [Char]
-> Cat
-> [Char]
-> Bool
-> [([Char], Bool)]
-> [Char]
generateAction RecordPositions
rp Maybe [Char]
inPackage Cat
cat [Char]
f Bool
b [([Char], Bool)]
mbs =
  [Char]
reverses [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  if [Char] -> Bool
forall a. IsFun a => a -> Bool
isCoercion [Char]
f
  then [Char]
"$$ = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
ms [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
  else if [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"[]"
  then [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"$$ = ",[Char]
"new ", [Char]
scope, Cat -> [Char]
identCatV Cat
cat, [Char]
"();"]
  else if [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"(:[])"
  then [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"$$ = ",[Char]
"new ", [Char]
scope, Cat -> [Char]
identCatV Cat
cat, [Char]
"() ; $$->push_back($1);"]
  else if [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"(:)" Bool -> Bool -> Bool
&& Bool
b
  then [Char]
"$1->push_back("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lastms [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") ; $$ = $1 ;"
  else if [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"(:)"
  then [Char]
lastms [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->push_back(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. [a] -> a
head [[Char]]
ms [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") ; $$ = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lastms [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ;" ---- not left rec
  else if [Char] -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule [Char]
f
  then [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"$$ = ", [Char]
scope, [Char]
f, [Char]
"_", [Char]
"(", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
ms, [Char]
");" ]
  else [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [[Char]
"$$ = ", [Char]
"new ", [Char]
scope, [Char]
f, [Char]
"(", [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
ms, [Char]
");" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RecordPositions -> [Char]
addLn RecordPositions
rp]
 where
  ms :: [[Char]]
ms = (([Char], Bool) -> [Char]) -> [([Char], Bool)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Bool) -> [Char]
forall a b. (a, b) -> a
fst [([Char], Bool)]
mbs
  lastms :: [Char]
lastms = [[Char]] -> [Char]
forall a. [a] -> a
last [[Char]]
ms
  addLn :: RecordPositions -> [Char]
addLn RecordPositions
rp = if RecordPositions
rp RecordPositions -> RecordPositions -> Bool
forall a. Eq a => a -> a -> Bool
== RecordPositions
RecordPositions then [Char]
" $$->line_number = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
nsString Maybe [Char]
inPackage [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"yy_mylinenumber;" else [Char]
""  -- O.F.
  identCatV :: Cat -> [Char]
identCatV = Cat -> [Char]
identCat (Cat -> [Char]) -> (Cat -> Cat) -> Cat -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat
  reverses :: [Char]
reverses = [[Char]] -> [Char]
unwords [
    [Char]
"std::reverse(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"->begin(),"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
m[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"->end()) ;" |
       ([Char]
m,Bool
True) <- [([Char], Bool)]
mbs]
  scope :: [Char]
scope = Maybe [Char] -> [Char]
nsScope Maybe [Char]
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 -> ([Char], [([Char], Bool)])
generatePatterns CF
cf SymMap
env Rule
r Bool
_ = case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
  []  -> ([Char]
"/* empty */",[])
  SentForm
its -> ([[Char]] -> [Char]
unwords ((Either Cat [Char] -> [Char]) -> SentForm -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Either Cat [Char] -> [Char]
mkIt SentForm
its), SentForm -> [([Char], Bool)]
forall {b}. [Either Cat b] -> [([Char], Bool)]
metas SentForm
its)
 where
   mkIt :: Either Cat [Char] -> [Char]
mkIt = \case
     Left (TokenCat [Char]
s)
       | CF -> [Char] -> Bool
forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf [Char]
s -> [Char] -> [Char]
typeName [Char]
s
       | Bool
otherwise -> [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
typeName [Char]
s) (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> SymKey
Tokentype [Char]
s) SymMap
env
     Left Cat
c  -> Cat -> [Char]
identCat Cat
c
     Right [Char]
s -> [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
s (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> SymKey
Keyword [Char]
s) SymMap
env
   metas :: [Either Cat b] -> [([Char], Bool)]
metas [Either Cat b]
its = [(Char
'$'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char]
prRules [] = []
prRules ((Cat
_, []):Rules
rs) = Rules -> [Char]
prRules Rules
rs --internal rule
prRules ((Cat
nt, ([Char]
p, [Char]
a) : [([Char], [Char])]
ls):Rules
rs) =
    [[Char]] -> [Char]
unwords [[Char]
nt', [Char]
":" , [Char]
p, [Char]
"{ ", [Char]
a, [Char]
"}", [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
pr [([Char], [Char])]
ls] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Rules -> [Char]
prRules Rules
rs
 where
  nt' :: [Char]
nt' = Cat -> [Char]
identCat Cat
nt
  pr :: [([Char], [Char])] -> [Char]
pr []           = []
  pr (([Char]
p,[Char]
a):[([Char], [Char])]
ls)   = [[Char]] -> [Char]
unlines [[[Char]] -> [Char]
unwords [[Char]
"  |", [Char]
p, [Char]
"{ ", [Char]
a , [Char]
"}"]] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
pr [([Char], [Char])]
ls