{-# LANGUAGE OverloadedStrings #-}
module BNFC.Backend.CPP.NoSTL.CFtoBison (cf2Bison) where
import Data.Char ( toLower )
import Data.Foldable ( toList )
import Data.List ( intersperse, nub )
import Data.Maybe ( fromMaybe )
import qualified Data.Map as Map
import BNFC.CF
import BNFC.Backend.Common.NamedVariables hiding (varName)
import BNFC.Backend.C.CFtoBisonC
( resultName, specialToks, startSymbol, typeName, varName )
import BNFC.Backend.CPP.STL.CFtoBisonSTL ( tokens, union, definedRules )
import BNFC.PrettyPrint
import BNFC.Utils ( (+++) )
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
cf2Bison :: String -> CF -> SymMap -> String
cf2Bison :: [Char] -> CF -> SymMap -> [Char]
cf2Bison [Char]
name CF
cf SymMap
env
= [[Char]] -> [Char]
unlines
[[Char] -> CF -> [Char]
header [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]
forall a. Maybe a
Nothing (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf),
[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 ([Char] -> CF -> SymMap -> Rules
rulesForBison [Char]
name 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))
header :: String -> CF -> String
[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 \"Absyn.H\""
, [Char]
""
, [Char]
"#define YYMAXDEPTH 10000000"
, [Char]
""
, [Char]
"int yyparse(void);"
, [Char]
"int yylex(void);"
, [Char]
"int yy_mylinenumber;"
, [Char]
"void initialize_lexer(FILE * inp);"
, [Char]
"int yywrap(void)"
, [Char]
"{"
, [Char]
" return 1;"
, [Char]
"}"
, [Char]
"void yyerror(const char *str)"
, [Char]
"{"
, [Char]
" extern char *yytext;"
, [Char]
" fprintf(stderr,\"error: line %d: %s at %s\\n\", "
, [Char]
" yy_mylinenumber + 1, str, yytext);"
, [Char]
"}"
, [Char]
""
, CF -> [Char]
definedRules CF
cf
, (Cat -> [Char]) -> [Cat] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> [Char]
reverseList ([Cat] -> [Char]) -> [Cat] -> [Char]
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
, [[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 -> [Char] -> Cat -> [Char]
parseMethod CF
cf [Char]
name) [Cat]
eps
, [Char]
"%}"
]
where
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
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
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
parseMethod :: CF -> String -> Cat -> String
parseMethod :: CF -> [Char] -> Cat -> [Char]
parseMethod CF
cf [Char]
_ Cat
cat = [[Char]] -> [Char]
unlines
[
[Char]
dat [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]
" initialize_lexer(inp);",
[Char]
" if (yyparse())",
[Char]
" { /* Failure */",
[Char]
" return 0;",
[Char]
" }",
[Char]
" else",
[Char]
" { /* Success */",
[Char]
" return" [Char] -> [Char] -> [Char]
+++ [Char]
res [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";",
[Char]
" }",
[Char]
"}"
]
where
dat :: [Char]
dat = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)
par :: [Char]
par = Cat -> [Char]
identCat Cat
cat
res0 :: [Char]
res0 = [Char] -> [Char]
resultName [Char]
dat
revRes :: [Char]
revRes = [Char]
"reverse" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
res0 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
res :: [Char]
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 [Char]
revRes else [Char]
res0
reverseList :: Cat -> String
reverseList :: Cat -> [Char]
reverseList Cat
c = [[Char]] -> [Char]
unlines
[
[Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"* reverse" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
+++ [Char]
"*l)",
[Char]
"{",
[Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
+++[Char]
"*prev = 0;",
[Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c' [Char] -> [Char] -> [Char]
+++[Char]
"*tmp = 0;",
[Char]
" while (l)",
[Char]
" {",
[Char]
" tmp = l->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";",
[Char]
" l->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v [Char] -> [Char] -> [Char]
+++ [Char]
"= prev;",
[Char]
" prev = l;",
[Char]
" l = tmp;",
[Char]
" }",
[Char]
" return prev;",
[Char]
"}"
]
where
c' :: [Char]
c' = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
c)
v :: [Char]
v = ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
c') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
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 (CF -> Cat -> [Char]
typeNT CF
cf) (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf)
where
typeNT :: CF -> Cat -> [Char]
typeNT CF
cf Cat
nt | CF -> Cat -> [Rule]
rulesForCat CF
cf Cat
nt [Rule] -> [Rule] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] = [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"
typeNT CF
_ Cat
_ = [Char]
""
rulesForBison :: String -> CF -> SymMap -> Rules
rulesForBison :: [Char] -> CF -> SymMap -> Rules
rulesForBison [Char]
_ 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 ([(Cat, [Rule])] -> Rules) -> [(Cat, [Rule])] -> Rules
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf where
mkOne :: (Cat, [Rule]) -> (Cat, [([Char], [Char])])
mkOne (Cat
cat,[Rule]
rules) = CF -> SymMap -> [Rule] -> Cat -> (Cat, [([Char], [Char])])
constructRule CF
cf SymMap
env [Rule]
rules Cat
cat
constructRule :: CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule :: CF -> SymMap -> [Rule] -> Cat -> (Cat, [([Char], [Char])])
constructRule CF
cf SymMap
env [Rule]
rules Cat
nt = (Cat
nt,[([Char]
p,([Char] -> Bool -> [[Char]] -> [Char]
generateAction (Rule -> [Char]
forall {a}. IsFun a => Rul a -> [Char]
ruleName Rule
r) Bool
b [[Char]]
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]]
m) = CF -> SymMap -> Rule -> ([Char], [[Char]])
generatePatterns CF
cf SymMap
env Rule
r])
where
ruleName :: Rul a -> [Char]
ruleName Rul a
r = case a -> [Char]
forall a. IsFun a => a -> [Char]
funName (a -> [Char]) -> a -> [Char]
forall a b. (a -> b) -> a -> b
$ Rul a -> a
forall function. Rul function -> function
funRule Rul a
r of
[Char]
"(:)" -> Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
nt)
[Char]
"(:[])" -> Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
nt)
[Char]
z -> [Char]
z
revs :: [Cat]
revs = CF -> [Cat]
forall f. CFG f -> [Cat]
cfgReversibleCats CF
cf
eps :: NonEmpty Cat
eps = CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf
isEntry :: Cat -> Bool
isEntry Cat
nt = if Cat -> NonEmpty Cat -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Cat
nt NonEmpty Cat
eps then Bool
True else Bool
False
result :: [Char]
result = if Cat -> Bool
isEntry Cat
nt then ([Char] -> [Char]
resultName (Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
nt))) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"= $$;" else [Char]
""
generateAction :: Fun -> Bool -> [MetaVar] -> Action
generateAction :: [Char] -> Bool -> [[Char]] -> [Char]
generateAction [Char]
f Bool
b [[Char]]
ms =
if [Char] -> Bool
forall a. IsFun a => a -> Bool
isCoercion [Char]
f
then ([[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]
"0;"
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]
f, [Char]
"_", [Char]
"(", [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
", " [[Char]]
ms', [Char]
");" ]
else [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"new ", [Char]
f, [Char]
"(", ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
", " [[Char]]
ms')), [Char]
");"]
where
ms' :: [[Char]]
ms' = if Bool
b then [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
ms else [[Char]]
ms
generatePatterns :: CF -> SymMap -> Rule -> (Pattern,[MetaVar])
generatePatterns :: CF -> SymMap -> Rule -> ([Char], [[Char]])
generatePatterns CF
cf SymMap
env Rule
r = 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]]
forall {b}. [Either Cat b] -> [[Char]]
metas SentForm
its)
where
mkIt :: Either Cat [Char] -> [Char]
mkIt Either Cat [Char]
i = case Either Cat [Char]
i of
Left (TokenCat [Char]
s) -> [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]]
metas [Either Cat b]
its = [Cat -> [Char] -> [Char]
revIf Cat
c (Char
'$'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char] -> [Char]
revIf Cat
c [Char]
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 ([Char]
"reverse" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
c)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
else [Char]
m
revs :: [Cat]
revs = CF -> [Cat]
forall f. CFG f -> [Cat]
cfgReversibleCats CF
cf
prRules :: Rules -> String
prRules :: Rules -> [Char]
prRules [] = []
prRules ((Cat
_, []):Rules
rs) = Rules -> [Char]
prRules Rules
rs
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]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
" " [[Char]
" |", [Char]
p, [Char]
"{ $$ =", [Char]
a , [Char]
"}"])]) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
pr [([Char], [Char])]
ls