{-
    BNF Converter: Java 1.5 Cup Generator
    Copyright (C) 2004  Author:  Markus Forsberg, Michael Pellauer,
                                 Bjorn Bringert

    Description   : This module generates the CUP input file. It
                    follows the same basic structure of CFtoHappy.

    Author        : Michael Pellauer
                    Bjorn Bringert

    Created       : 26 April, 2003
    Modified      : 5 Aug, 2004

-}

module BNFC.Backend.Java.CFtoCup15 ( cf2Cup ) where

import Data.List (intercalate)

import BNFC.CF
import BNFC.Options (RecordPositions(..))
import BNFC.Utils ( (+++) )

import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Java.Utils            ( getRuleName )

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

--The environment comes from the CFtoJLex
cf2Cup :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String
cf2Cup :: [Char] -> [Char] -> CF -> RecordPositions -> KeywordEnv -> [Char]
cf2Cup [Char]
packageBase [Char]
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env = [[Char]] -> [Char]
unlines
    [ [Char]
header
    , [Char] -> [Cat] -> [Char]
declarations [Char]
packageAbsyn (forall f. CFG f -> [Cat]
allParserCats CF
cf)
    , KeywordEnv -> [Char]
tokens KeywordEnv
env
    , CF -> [Char]
specialToks CF
cf
    , CF -> [Char]
specialRules CF
cf
    , CF -> [Char]
prEntryPoint CF
cf
    , Rules -> [Char]
prRules ([Char] -> CF -> RecordPositions -> KeywordEnv -> Rules
rulesForCup [Char]
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env)
    ]
  where
    header :: String
    header :: [Char]
header = [[Char]] -> [Char]
unlines
      [ [Char]
"// Parser definition for use with Java Cup"
      , [Char]
"package" [Char] -> [Char] -> [Char]
+++ [Char]
packageBase forall a. [a] -> [a] -> [a]
++ [Char]
";"
      , [Char]
""
      , [Char]
"action code {:"
      , [Char]
"public java_cup.runtime.ComplexSymbolFactory.Location getLeftLocation("
      , [Char]
"    java_cup.runtime.ComplexSymbolFactory.Location ... locations) {"
      , [Char]
"  for (java_cup.runtime.ComplexSymbolFactory.Location l : locations) {"
      , [Char]
"    if (l != null) {"
      , [Char]
"      return l;"
      , [Char]
"    }"
      , [Char]
"  }"
      , [Char]
"  return null;"
      , [Char]
"}"
      , [Char]
":}"
      , [Char]
"parser code {:"
      , [Char] -> Cat -> [Char]
parseMethod [Char]
packageAbsyn (CF -> Cat
firstEntry CF
cf)
      , [Char]
"public void syntax_error(java_cup.runtime.Symbol cur_token)"
      , [Char]
"{"
      , [Char]
"  report_error(\"Syntax Error, trying to recover and continue"
        forall a. [a] -> [a] -> [a]
++ [Char]
" parse...\", cur_token);"
      , [Char]
"}"
      , [Char]
""
      , [Char]
"public void unrecovered_syntax_error(java_cup.runtime.Symbol "
        forall a. [a] -> [a] -> [a]
++ [Char]
"cur_token) throws java.lang.Exception"
      , [Char]
"{"
      , [Char]
"  throw new Exception(\"Unrecoverable Syntax Error\");"
      , [Char]
"}"
      , [Char]
""
      , [Char]
":}"
      ]


-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.
prEntryPoint :: CF -> String
prEntryPoint :: CF -> [Char]
prEntryPoint CF
cf = [[Char]] -> [Char]
unlines [[Char]
"", [Char]
"start with " forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
identCat (CF -> Cat
firstEntry CF
cf) forall a. [a] -> [a] -> [a]
++ [Char]
";", [Char]
""]
--                  [ep]  -> unlines ["", "start with " ++ ep ++ ";", ""]
--                  eps   -> error $ "FIXME multiple entry points." ++ show eps

--This generates a parser method for each entry point.
parseMethod :: String -> Cat -> String
parseMethod :: [Char] -> Cat -> [Char]
parseMethod [Char]
packageAbsyn Cat
cat = [[Char]] -> [Char]
unlines
             [ [Char]
"  public" [Char] -> [Char] -> [Char]
+++ [Char]
packageAbsyn forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
dat [Char] -> [Char] -> [Char]
+++ [Char]
"p" forall a. [a] -> [a] -> [a]
++ [Char]
cat' forall a. [a] -> [a] -> [a]
++ [Char]
"()"
                 forall a. [a] -> [a] -> [a]
++ [Char]
" throws Exception"
             , [Char]
"  {"
             , [Char]
"    java_cup.runtime.Symbol res = parse();"
             , [Char]
"    return (" forall a. [a] -> [a] -> [a]
++ [Char]
packageAbsyn forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
dat forall a. [a] -> [a] -> [a]
++ [Char]
") res.value;"
             , [Char]
"  }"
             ]
    where
    dat :: [Char]
dat  = Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat)
    cat' :: [Char]
cat' = Cat -> [Char]
identCat Cat
cat

--non-terminal types
declarations :: String -> [Cat] -> String
declarations :: [Char] -> [Cat] -> [Char]
declarations [Char]
packageAbsyn [Cat]
ns = [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map (forall {p}. p -> Cat -> [Char]
typeNT [Char]
packageAbsyn) [Cat]
ns)
 where
   typeNT :: p -> Cat -> [Char]
typeNT p
_nm Cat
nt = [Char]
"nonterminal" [Char] -> [Char] -> [Char]
+++ [Char]
packageAbsyn forall a. [a] -> [a] -> [a]
++ [Char]
"."
                    forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
nt) [Char] -> [Char] -> [Char]
+++ Cat -> [Char]
identCat Cat
nt forall a. [a] -> [a] -> [a]
++ [Char]
";"

--terminal types
tokens :: KeywordEnv -> String
tokens :: KeywordEnv -> [Char]
tokens KeywordEnv
ts = [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
declTok KeywordEnv
ts)
 where
  declTok :: ([Char], [Char]) -> [Char]
declTok ([Char]
s,[Char]
r) = [Char]
"terminal" [Char] -> [Char] -> [Char]
+++ [Char]
r forall a. [a] -> [a] -> [a]
++ [Char]
";    //   " forall a. [a] -> [a] -> [a]
++ [Char]
s

specialToks :: CF -> String
specialToks :: CF -> [Char]
specialToks CF
cf = [[Char]] -> [Char]
unlines
  [ forall {p}. IsString p => [Char] -> p -> p
ifC [Char]
catString  [Char]
"terminal String _STRING_;"
  , forall {p}. IsString p => [Char] -> p -> p
ifC [Char]
catChar    [Char]
"terminal Character _CHAR_;"
  , forall {p}. IsString p => [Char] -> p -> p
ifC [Char]
catInteger [Char]
"terminal Integer _INTEGER_;"
  , forall {p}. IsString p => [Char] -> p -> p
ifC [Char]
catDouble  [Char]
"terminal Double _DOUBLE_;"
  , forall {p}. IsString p => [Char] -> p -> p
ifC [Char]
catIdent   [Char]
"terminal String _IDENT_;"
  ]
   where
    ifC :: [Char] -> p -> p
ifC [Char]
cat p
s = if forall f. CFG f -> Cat -> Bool
isUsedCat CF
cf ([Char] -> Cat
TokenCat [Char]
cat) then p
s else p
""

specialRules:: CF -> String
specialRules :: CF -> [Char]
specialRules CF
cf =
    [[Char]] -> [Char]
unlines [[Char]
"terminal String " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
";" | [Char]
name <- forall f. CFG f -> [[Char]]
tokenNames CF
cf]

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

-- | For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed.
constructRule :: String -> CF -> RecordPositions -> KeywordEnv -> [Rule] -> NonTerminal
    -> (NonTerminal,[(Pattern,Action)])
constructRule :: [Char]
-> CF
-> RecordPositions
-> KeywordEnv
-> [Rule]
-> Cat
-> (Cat, KeywordEnv)
constructRule [Char]
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env [Rule]
rules Cat
nt =
    (Cat
nt, [ ([Char]
p, [Char]
-> Cat -> [Char] -> [[Char]] -> Bool -> RecordPositions -> [Char]
generateAction [Char]
packageAbsyn Cat
nt (forall a. IsFun a => a -> [Char]
funName forall a b. (a -> b) -> a -> b
$ forall function. Rul function -> function
funRule Rule
r) (forall {a}. Bool -> [a] -> [a]
revM Bool
b [[Char]]
m) Bool
b RecordPositions
rp)
          | Rule
r0 <- [Rule]
rules,
          let (Bool
b,Rule
r) = if forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rule
r0) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall fun. Rul fun -> Cat
valCat Rule
r0) [Cat]
revs
                          then (Bool
True, forall f. Rul f -> Rul f
revSepListRule Rule
r0)
                          else (Bool
False, Rule
r0)
              ([Char]
p,[[Char]]
m) = KeywordEnv -> Rule -> ([Char], [[Char]])
generatePatterns KeywordEnv
env Rule
r])
 where
   revM :: Bool -> [a] -> [a]
revM Bool
False = forall a. a -> a
id
   revM Bool
True  = forall a. [a] -> [a]
reverse
   revs :: [Cat]
revs       = forall f. CFG f -> [Cat]
cfgReversibleCats CF
cf

-- Generates a string containing the semantic action.
generateAction :: String -> NonTerminal -> Fun -> [MetaVar]
               -> Bool   -- ^ Whether the list should be reversed or not.
                         --   Only used if this is a list rule.
               -> RecordPositions   -- ^ Record line and column info.
               -> Action
generateAction :: [Char]
-> Cat -> [Char] -> [[Char]] -> Bool -> RecordPositions -> [Char]
generateAction [Char]
packageAbsyn Cat
nt [Char]
fun [[Char]]
ms Bool
rev RecordPositions
rp
    | forall a. IsFun a => a -> Bool
isNilFun [Char]
f      = [Char]
"RESULT = new " forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
"();"
    | forall a. IsFun a => a -> Bool
isOneFun [Char]
f      = [Char]
"RESULT = new " forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
"(); RESULT.addLast("
                           forall a. [a] -> [a] -> [a]
++ [Char]
p_1 forall a. [a] -> [a] -> [a]
++ [Char]
");"
    | forall a. IsFun a => a -> Bool
isConsFun [Char]
f     = [Char]
"RESULT = " forall a. [a] -> [a] -> [a]
++ [Char]
p_2 forall a. [a] -> [a] -> [a]
++ [Char]
"; "
                           forall a. [a] -> [a] -> [a]
++ [Char]
p_2 forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
add forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ [Char]
p_1 forall a. [a] -> [a] -> [a]
++ [Char]
");"
    | forall a. IsFun a => a -> Bool
isCoercion [Char]
f    = [Char]
"RESULT = " forall a. [a] -> [a] -> [a]
++ [Char]
p_1 forall a. [a] -> [a] -> [a]
++ [Char]
";"
    | forall a. IsFun a => a -> Bool
isDefinedRule [Char]
f = [Char]
"RESULT = " forall a. [a] -> [a] -> [a]
++ [Char]
packageAbsyn forall a. [a] -> [a] -> [a]
++ [Char]
"Def." forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
sanitize [Char]
f
                        forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]]
ms forall a. [a] -> [a] -> [a]
++ [Char]
");"
    | Bool
otherwise       = [Char]
"RESULT = new " forall a. [a] -> [a] -> [a]
++ [Char]
c
                  forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]]
ms forall a. [a] -> [a] -> [a]
++ [Char]
");" forall a. [a] -> [a] -> [a]
++ [Char]
lineInfo
   where
     sanitize :: [Char] -> [Char]
sanitize = [Char] -> [Char]
getRuleName
     f :: [Char]
f   = forall a. IsFun a => a -> [Char]
funName [Char]
fun
     c :: [Char]
c   = [Char]
packageAbsyn forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++
           if forall a. IsFun a => a -> Bool
isNilFun [Char]
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isOneFun [Char]
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConsFun [Char]
f
             then Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
nt) else [Char]
f
     p_1 :: [Char]
p_1 = [[Char]]
ms forall a. [a] -> Int -> a
!! Int
0
     p_2 :: [Char]
p_2 = [[Char]]
ms forall a. [a] -> Int -> a
!! Int
1
     add :: [Char]
add = if Bool
rev then [Char]
"addLast" else [Char]
"addFirst"
     lineInfo :: [Char]
lineInfo =
        if RecordPositions
rp forall a. Eq a => a -> a -> Bool
== RecordPositions
RecordPositions
          then case [[Char]]
ms of
            [] -> [Char]
"\n((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).line_num = -1;" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).col_num = -1;" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).offset = -1;"
            [[Char]]
_  -> [Char]
"\njava_cup.runtime.ComplexSymbolFactory.Location leftLoc = getLeftLocation(" forall a. [a] -> [a] -> [a]
++
                  forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++[Char]
"xleft") [[Char]]
ms) forall a. [a] -> [a] -> [a]
++ [Char]
");" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\nif (leftLoc != null) {" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n  ((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).line_num = leftLoc.getLine();" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n  ((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).col_num = leftLoc.getColumn();" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n  ((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).offset = leftLoc.getOffset();" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n} else {" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n  ((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).line_num = -1;" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n  ((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).col_num = -1;" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n  ((" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")RESULT).offset = -1;" forall a. [a] -> [a] -> [a]
++
                  [Char]
"\n}"
          else [Char]
""


-- | Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal.
--
-- >>> generatePatterns [] (npRule "myfun" (Cat "A") [] Parsable)
-- (" /* empty */ ",[])
--
-- >>> generatePatterns [("def", "_SYMB_1")] (npRule "myfun" (Cat "A") [Right "def", Left (Cat "B")] Parsable)
-- ("_SYMB_1:p_1 B:p_2 ",["p_2"])

generatePatterns :: KeywordEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns :: KeywordEnv -> Rule -> ([Char], [[Char]])
generatePatterns KeywordEnv
env Rule
r = case forall function. Rul function -> SentForm
rhsRule Rule
r of
    []  -> ([Char]
" /* empty */ ", [])
    SentForm
its -> (Int -> SentForm -> [Char]
mkIt Int
1 SentForm
its, forall {a} {b}. [Either a b] -> [[Char]]
metas SentForm
its)
 where
    mkIt :: Int -> SentForm -> [Char]
mkIt Int
_ [] = []
    mkIt Int
n (Either Cat [Char]
i:SentForm
is) =
      case Either Cat [Char]
i of
        Left Cat
c -> [Char]
c' forall a. [a] -> [a] -> [a]
++ [Char]
":p_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
n :: Int) [Char] -> [Char] -> [Char]
+++ Int -> SentForm -> [Char]
mkIt (Int
nforall a. Num a => a -> a -> a
+Int
1) SentForm
is
          where
              c' :: [Char]
c' = case Cat
c of
                  TokenCat [Char]
"Ident"   -> [Char]
"_IDENT_"
                  TokenCat [Char]
"Integer" -> [Char]
"_INTEGER_"
                  TokenCat [Char]
"Char"    -> [Char]
"_CHAR_"
                  TokenCat [Char]
"Double"  -> [Char]
"_DOUBLE_"
                  TokenCat [Char]
"String"  -> [Char]
"_STRING_"
                  Cat
_ -> Cat -> [Char]
identCat Cat
c
        Right [Char]
s -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
s KeywordEnv
env of
            Just [Char]
x  -> ([Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
":p_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
n :: Int)) [Char] -> [Char] -> [Char]
+++ Int -> SentForm -> [Char]
mkIt (Int
nforall a. Num a => a -> a -> a
+Int
1) SentForm
is
            Maybe [Char]
Nothing -> Int -> SentForm -> [Char]
mkIt Int
n SentForm
is
    metas :: [Either a b] -> [[Char]]
metas [Either a b]
its = [[Char]
"p_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i | (Int
i,Left a
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [Either a b]
its]

-- 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):KeywordEnv
ls) : Rules
rs) =
    [[Char]] -> [Char]
unwords [ [Char]
nt', [Char]
"::=", [Char]
p, [Char]
"{:", [Char]
a, [Char]
":}", Char
'\n' forall a. a -> [a] -> [a]
: KeywordEnv -> [Char]
pr KeywordEnv
ls ] forall a. [a] -> [a] -> [a]
++ [Char]
";\n" forall a. [a] -> [a] -> [a]
++ Rules -> [Char]
prRules Rules
rs
  where
    nt' :: [Char]
nt' = Cat -> [Char]
identCat Cat
nt
    pr :: KeywordEnv -> [Char]
pr []           = []
    pr (([Char]
p,[Char]
a):KeywordEnv
ls)   = [[Char]] -> [Char]
unlines [ [[Char]] -> [Char]
unwords [ [Char]
"  |", [Char]
p, [Char]
"{:", [Char]
a , [Char]
":}" ] ] forall a. [a] -> [a] -> [a]
++ KeywordEnv -> [Char]
pr KeywordEnv
ls