{-
    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, definedRules ) where

import BNFC.CF
import Data.List
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Java.CFtoJavaAbs15 (typename)
import BNFC.Options (RecordPositions(..))
import BNFC.Utils ( (+++) )
import BNFC.TypeChecker  -- We need to (re-)typecheck to figure out list instances in
                    -- defined rules.
import Data.Char

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 :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String
cf2Cup String
packageBase String
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env = [String] -> String
unlines
    [ String
header
    , String -> [Cat] -> String
declarations String
packageAbsyn (CF -> [Cat]
forall f. CFG f -> [Cat]
allParserCats CF
cf)
    , KeywordEnv -> String
tokens KeywordEnv
env
    , CF -> String
specialToks CF
cf
    , CF -> String
specialRules CF
cf
    , CF -> String
prEntryPoint CF
cf
    , Rules -> String
prRules (String -> CF -> RecordPositions -> KeywordEnv -> Rules
rulesForCup String
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env)
    ]
  where
    header :: String
    header :: String
header = [String] -> String
unlines
      [ String
"// -*- Java -*- This Cup file was machine-generated by BNFC"
      , String
"package" String -> String -> String
+++ String
packageBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
      , String
""
      , String
"action code {:"
      , String
"public java_cup.runtime.ComplexSymbolFactory.Location getLeftLocation("
      , String
"    java_cup.runtime.ComplexSymbolFactory.Location ... locations) {"
      , String
"  for (java_cup.runtime.ComplexSymbolFactory.Location l : locations) {"
      , String
"    if (l != null) {"
      , String
"      return l;"
      , String
"    }"
      , String
"  }"
      , String
"  return null;"
      , String
"}"
      , String
":}"
      , String
"parser code {:"
      , String -> Cat -> String
parseMethod String
packageAbsyn (CF -> Cat
firstEntry CF
cf)
      , String
"public <B,A extends java.util.LinkedList<? super B>> "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"A cons_(B x, A xs) { xs.addFirst(x); return xs; }"
      , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> CF -> [String]
definedRules String
packageAbsyn CF
cf
      , String
"public void syntax_error(java_cup.runtime.Symbol cur_token)"
      , String
"{"
      , String
"  report_error(\"Syntax Error, trying to recover and continue"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" parse...\", cur_token);"
      , String
"}"
      , String
""
      , String
"public void unrecovered_syntax_error(java_cup.runtime.Symbol "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"cur_token) throws java.lang.Exception"
      , String
"{"
      , String
"  throw new Exception(\"Unrecoverable Syntax Error\");"
      , String
"}"
      , String
""
      , String
":}"
      ]

definedRules :: String -> CF -> [String]
definedRules :: String -> CF -> [String]
definedRules String
packageAbsyn CF
cf =
    [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ 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 (\ Base
t -> String
"List" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Base -> String
unBase Base
t) (String -> Base -> String
forall a b. a -> b -> a
const String
"cons")
      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
"public " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Base -> String
javaType 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
javaArg Telescope
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") {"
                , String
"  return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp -> String
javaExp Exp
e' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
                , String
"}"
                ]
     where

       javaType :: Base -> String
       javaType :: Base -> String
javaType (ListT (BaseT String
x)) = String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".List"
                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
catToStr (Cat -> Cat
normCat (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ String -> Cat
strToCat String
x)
       javaType (ListT Base
t)         = Base -> String
javaType Base
t
       javaType (BaseT String
x)         = String -> [String] -> String -> String
typename String
packageAbsyn (Context -> [String]
ctxTokens Context
ctx) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                                      Cat -> String
catToStr (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

       javaArg :: (String, Base) -> String
       javaArg :: (String, Base) -> String
javaArg (String
x,Base
t) = Base -> String
javaType 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
"_"

       javaExp :: Exp -> String
       javaExp :: Exp -> String
javaExp (App String
"null" []) = String
"null"
       javaExp (Var String
x)         = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"      -- argument
       javaExp (App String
t [Exp
e])
           | String -> Context -> Bool
isToken String
t Context
ctx     = String -> [Exp] -> String
call String
"new String" [Exp
e]
       javaExp (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
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." 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
       javaExp (LitInt Integer
n)      = String
"new Integer(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
       javaExp (LitDouble Double
x)   = String
"new Double(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
       javaExp (LitChar Char
c)     = String
"new Character(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
       javaExp (LitString String
s)   = String
"new String(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

       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
javaExp [Exp]
es) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"


-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.
prEntryPoint :: CF -> String
prEntryPoint :: CF -> String
prEntryPoint CF
cf = [String] -> String
unlines [String
"", String
"start with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat (CF -> Cat
firstEntry CF
cf) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";", String
""]
--                  [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 :: String -> Cat -> String
parseMethod String
packageAbsyn Cat
cat = [String] -> String
unlines
             [ String
"  public" String -> String -> String
+++ String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dat String -> String -> String
+++ String
"p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"()"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" throws Exception"
             , String
"  {"
             , String
"    java_cup.runtime.Symbol res = parse();"
             , String
"    return (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") res.value;"
             , String
"  }"
             ]
    where
    dat :: String
dat  = Cat -> String
identCat (Cat -> Cat
normCat Cat
cat)
    cat' :: String
cat' = Cat -> String
identCat Cat
cat

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

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

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

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

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForCup :: String -> CF -> RecordPositions -> KeywordEnv -> Rules
rulesForCup :: String -> CF -> RecordPositions -> KeywordEnv -> Rules
rulesForCup String
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env = ((Cat, [Rule]) -> (Cat, KeywordEnv)) -> [(Cat, [Rule])] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map (Cat, [Rule]) -> (Cat, KeywordEnv)
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, KeywordEnv)
mkOne (Cat
cat,[Rule]
rules) = String
-> CF
-> RecordPositions
-> KeywordEnv
-> [Rule]
-> Cat
-> (Cat, KeywordEnv)
constructRule String
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 :: String
-> CF
-> RecordPositions
-> KeywordEnv
-> [Rule]
-> Cat
-> (Cat, KeywordEnv)
constructRule String
packageAbsyn CF
cf RecordPositions
rp KeywordEnv
env [Rule]
rules Cat
nt =
    (Cat
nt, [ (String
p, String
-> Cat -> String -> [String] -> Bool -> RecordPositions -> String
generateAction String
packageAbsyn 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
funRule Rule
r) (Bool -> [String] -> [String]
forall a. Bool -> [a] -> [a]
revM Bool
b [String]
m) Bool
b RecordPositions
rp)
          | 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)
              (String
p,[String]
m) = KeywordEnv -> Rule -> (String, [String])
generatePatterns KeywordEnv
env Rule
r])
 where
   revM :: Bool -> [a] -> [a]
revM Bool
False = [a] -> [a]
forall a. a -> a
id
   revM Bool
True  = [a] -> [a]
forall a. [a] -> [a]
reverse
   revs :: [Cat]
revs       = CF -> [Cat]
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 :: String
-> Cat -> String -> [String] -> Bool -> RecordPositions -> String
generateAction String
packageAbsyn Cat
nt String
fun [String]
ms Bool
rev RecordPositions
rp
    | String -> Bool
forall a. IsFun a => a -> Bool
isNilFun String
f      = String
"RESULT = new " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"();"
    | String -> Bool
forall a. IsFun a => a -> Bool
isOneFun String
f      = String
"RESULT = new " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(); RESULT.addLast("
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p_1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
    | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
f     = String
"RESULT = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p_2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; "
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p_2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
add String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p_1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
    | String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
f    = String
"RESULT = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p_1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    | String -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule String
f = String
"RESULT = parser." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
                        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]
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
    | Bool
otherwise       = String
"RESULT = new " 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 -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lineInfo
   where
     f :: String
f   = String -> String
forall a. IsFun a => a -> String
funName String
fun
     c :: String
c   = String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++
           if String -> Bool
forall a. IsFun a => a -> Bool
isNilFun String
f Bool -> Bool -> Bool
|| String -> Bool
forall a. IsFun a => a -> Bool
isOneFun String
f Bool -> Bool -> Bool
|| String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
f
             then Cat -> String
identCat (Cat -> Cat
normCat Cat
nt) else String
f
     p_1 :: String
p_1 = [String]
ms [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
0
     p_2 :: String
p_2 = [String]
ms [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
1
     add :: String
add = if Bool
rev then String
"addLast" else String
"addFirst"
     lineInfo :: String
lineInfo =
        if RecordPositions
rp RecordPositions -> RecordPositions -> Bool
forall a. Eq a => a -> a -> Bool
== RecordPositions
RecordPositions
          then case [String]
ms of
            [] -> String
"\n((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).line_num = -1;" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).col_num = -1;" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).offset = -1;"
            [String]
_  -> String
"\njava_cup.runtime.ComplexSymbolFactory.Location leftLoc = getLeftLocation(" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"xleft") [String]
ms) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\nif (leftLoc != null) {" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n  ((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).line_num = leftLoc.getLine();" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n  ((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).col_num = leftLoc.getColumn();" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n  ((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).offset = leftLoc.getOffset();" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n} else {" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n  ((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).line_num = -1;" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n  ((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).col_num = -1;" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n  ((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")RESULT).offset = -1;" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n}"
          else String
""


-- | 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 -> (String, [String])
generatePatterns KeywordEnv
env Rule
r = case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
    []  -> (String
" /* empty */ ", [])
    SentForm
its -> (Int -> SentForm -> String
mkIt Int
1 SentForm
its, SentForm -> [String]
forall a b. [Either a b] -> [String]
metas SentForm
its)
 where
    mkIt :: Int -> SentForm -> String
mkIt Int
_ [] = []
    mkIt Int
n (Either Cat String
i:SentForm
is) =
      case Either Cat String
i of
        Left Cat
c -> String
c' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":p_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n :: Int) String -> String -> String
+++ Int -> SentForm -> String
mkIt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SentForm
is
          where
              c' :: String
c' = case Cat
c of
                  TokenCat "Ident"   -> String
"_IDENT_"
                  TokenCat "Integer" -> String
"_INTEGER_"
                  TokenCat "Char"    -> String
"_CHAR_"
                  TokenCat "Double"  -> String
"_DOUBLE_"
                  TokenCat "String"  -> String
"_STRING_"
                  Cat
_ -> Cat -> String
identCat Cat
c
        Right String
s -> case String -> KeywordEnv -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s KeywordEnv
env of
            Just String
x  -> (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":p_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n :: Int)) String -> String -> String
+++ Int -> SentForm -> String
mkIt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SentForm
is
            Maybe String
Nothing -> Int -> SentForm -> String
mkIt Int
n SentForm
is
    metas :: [Either a b] -> [String]
metas [Either a b]
its = [String
"p_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | (Int
i,Left a
_) <- [Int] -> [Either a b] -> [(Int, Either a b)]
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 -> String
prRules []                    = []
prRules ((Cat
_ , []      ) : Rules
rs) = Rules -> String
prRules Rules
rs --internal rule
prRules ((Cat
nt, (String
p,String
a):KeywordEnv
ls) : Rules
rs) =
    [String] -> String
unwords [ String
nt', String
"::=", String
p, String
"{:", String
a, String
":}", Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: KeywordEnv -> String
pr KeywordEnv
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 :: KeywordEnv -> String
pr []           = []
    pr ((String
p,String
a):KeywordEnv
ls)   = [String] -> String
unlines [ [String] -> String
unwords [ String
"  |", String
p, String
"{:", String
a , String
":}" ] ] String -> String -> String
forall a. [a] -> [a] -> [a]
++ KeywordEnv -> String
pr KeywordEnv
ls