{-# LANGUAGE OverloadedStrings #-}

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

    Description   : This module generates the Bison input file.
                    Note that because of the way bison stores results
                    the programmer can increase performance by limiting
                    the number of entry points in their grammar.

    Author        : Michael Pellauer
    Created       : 6 August, 2003
-}

module BNFC.Backend.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 ( (+++) )

--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 :: String -> CF -> SymMap -> String
cf2Bison :: String -> CF -> SymMap -> String
cf2Bison String
name CF
cf SymMap
env
 = [String] -> String
unlines
    [String -> CF -> String
header 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
forall a. Maybe a
Nothing (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf),
     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 (String -> CF -> SymMap -> Rules
rulesForBison String
name 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))

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
"#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
"int yyparse(void);"
    , String
"int yylex(void);"
    , String
"int yy_mylinenumber;"  --- hack to get line number. AR 2006
    , String
"void initialize_lexer(FILE * inp);"
    , String
"int yywrap(void)"
    , String
"{"
    , String
"  return 1;"
    , String
"}"
    , String
"void yyerror(const char *str)"
    , String
"{"
    , String
"  extern char *yytext;"
    , String
"  fprintf(stderr,\"error: line %d: %s at %s\\n\", "
    , String
"    yy_mylinenumber + 1, str, yytext);"
    , String
"}"
    , String
""
    , CF -> String
definedRules CF
cf
    , (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] -> 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 -> String -> Cat -> String
parseMethod CF
cf String
name) [Cat]
eps
    , String
"%}"
    ]
  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



-- | 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 -> String -> Cat -> String
parseMethod :: CF -> String -> Cat -> String
parseMethod CF
cf String
_ Cat
cat = [String] -> String
unlines
  [
   String
dat 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
"  initialize_lexer(inp);",
   String
"  if (yyparse())",
   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)
  par :: String
par  = 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
"_"

--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
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
""

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: String -> CF -> SymMap -> Rules
rulesForBison :: String -> CF -> SymMap -> Rules
rulesForBison String
_ 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) = CF -> SymMap -> [Rule] -> Cat -> (Cat, [(String, String)])
constructRule CF
cf SymMap
env [Rule]
rules Cat
cat

-- For every non-terminal, we construct a set of rules.
constructRule :: CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule :: CF -> SymMap -> [Rule] -> Cat -> (Cat, [(String, String)])
constructRule CF
cf SymMap
env [Rule]
rules Cat
nt = (Cat
nt,[(String
p,(String -> Bool -> [String] -> String
generateAction (Rule -> String
forall a. IsFun a => Rul a -> String
ruleName Rule
r) Bool
b [String]
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]
m) = CF -> SymMap -> Rule -> (String, [String])
generatePatterns CF
cf SymMap
env Rule
r])
 where
   ruleName :: Rul a -> String
ruleName Rul a
r = case a -> String
forall a. IsFun a => a -> String
funName (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ Rul a -> a
forall function. Rul function -> function
funRule Rul a
r of
     String
"(:)" -> Cat -> String
identCat (Cat -> Cat
normCat Cat
nt)
     String
"(:[])" -> Cat -> String
identCat (Cat -> Cat
normCat Cat
nt)
     String
z -> String
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 :: String
result = if Cat -> Bool
isEntry Cat
nt then (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 :: Fun -> Bool -> [MetaVar] -> Action
generateAction :: String -> Bool -> [String] -> String
generateAction String
f Bool
b [String]
ms =
  if String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
f
  then ([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
"0;"
  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
f, String
"_", String
"(", [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " [String]
ms', String
");" ]
  else [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"new ", String
f, String
"(", ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " [String]
ms')), String
");"]
 where
  ms' :: [String]
ms' = if Bool
b then [String] -> [String]
forall a. [a] -> [a]
reverse [String]
ms else [String]
ms

-- 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
"}", 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
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" " [String
"  |", String
p, String
"{ $$ =", String
a , String
"}"])]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
pr [(String, String)]
ls