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

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

    Author        : Gabriele Paganelli (gapag@distruzione.org)
    Created       : 15 Oct, 2015

-}

{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.Java.CFtoAntlr4Parser ( cf2AntlrParse ) where

import Data.Foldable ( toList )
import Data.List     ( intercalate )
import Data.Maybe

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

import BNFC.Backend.Java.Utils
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Java.CFtoCup15 ( definedRules )

-- Type declarations

-- | A definition of a non-terminal by all its rhss,
--   together with parse actions.
data PDef = PDef
  { PDef -> Maybe String
_pdNT   :: Maybe String
      -- ^ If given, the name of the lhss.  Usually computed from 'pdCat'.
  , PDef -> Cat
_pdCat  :: Cat
      -- ^ The category to parse.
  , PDef -> [(String, String, Maybe String)]
_pdAlts :: [(Pattern, Action, Maybe Fun)]
      -- ^ The possible rhss with actions.  If 'null', skip this 'PDef'.
      --   Where 'Nothing', skip ANTLR rule label.
  }
type Rules       = [PDef]
type Pattern     = String
type Action      = String
type MetaVar     = (String, Cat)

-- | Creates the ANTLR parser grammar for this CF.
--The environment comes from CFtoAntlr4Lexer
cf2AntlrParse :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String
cf2AntlrParse :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String
cf2AntlrParse String
packageBase String
packageAbsyn CF
cf RecordPositions
_ KeywordEnv
env = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
header
    , String
tokens
    , String
"@members {"
    ]
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> CF -> [String]
definedRules String
packageAbsyn CF
cf
  , [ String
"}"
    , String
""
    -- Generate start rules [#272]
    -- _X returns [ dX result ] : x=X EOF { $result = $x.result; }
    , String -> Rules -> String
prRules String
packageAbsyn (Rules -> String) -> Rules -> String
forall a b. (a -> b) -> a -> b
$ (Cat -> PDef) -> [Cat] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map Cat -> PDef
entrypoint ([Cat] -> Rules) -> [Cat] -> Rules
forall a b. (a -> b) -> a -> b
$ 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
    -- Generate regular rules
    , String -> Rules -> String
prRules String
packageAbsyn (Rules -> String) -> Rules -> String
forall a b. (a -> b) -> a -> b
$ String -> CF -> KeywordEnv -> Rules
rulesForAntlr4 String
packageAbsyn CF
cf KeywordEnv
env
    ]
  ]
  where
    header :: String
    header :: String
header = [String] -> String
unlines
        [ String
"// -*- Java -*- This ANTLRv4 file was machine-generated by BNFC"
        , String
"parser grammar" String -> String -> String
+++ String
identifier String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Parser;"
        ]
    tokens :: String
    tokens :: String
tokens = [String] -> String
unlines
        [ String
"options {"
        , String
"  tokenVocab = "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
identifierString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"Lexer;"
        , String
"}"
        ]
    identifier :: String
identifier = String -> String
getLastInPackage String
packageBase

-- | Generate start rule to help ANTLR.
--
--   @start_X returns [ X result ] : x=X EOF { $result = $x.result; } # Start_X@
--
entrypoint :: Cat -> PDef
entrypoint :: Cat -> PDef
entrypoint Cat
cat =
  Maybe String -> Cat -> [(String, String, Maybe String)] -> PDef
PDef (String -> Maybe String
forall a. a -> Maybe a
Just String
nt) Cat
cat [(String
pat, String
act, Maybe String
forall a. Maybe a
fun)]
  where
  nt :: String
nt  = String -> String
firstLowerCase (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
startSymbol (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat Cat
cat
  pat :: String
pat = String
"x=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
catToNT Cat
cat String -> String -> String
+++ String
"EOF"
  act :: String
act = String
"$result = $x.result;"
  fun :: Maybe a
fun = Maybe a
forall a. Maybe a
Nothing -- No ANTLR Rule label, ("Start_" ++ identCat cat) conflicts with lhs.

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForAntlr4 :: String -> CF -> KeywordEnv -> Rules
rulesForAntlr4 :: String -> CF -> KeywordEnv -> Rules
rulesForAntlr4 String
packageAbsyn CF
cf KeywordEnv
env = ((Cat, [Rule]) -> PDef) -> [(Cat, [Rule])] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map (Cat, [Rule]) -> PDef
mkOne [(Cat, [Rule])]
getrules
  where
    getrules :: [(Cat, [Rule])]
getrules          = CF -> [(Cat, [Rule])]
ruleGroups CF
cf
    mkOne :: (Cat, [Rule]) -> PDef
mkOne (Cat
cat,[Rule]
rules) = String -> CF -> KeywordEnv -> [Rule] -> Cat -> PDef
constructRule String
packageAbsyn CF
cf 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 -> KeywordEnv -> [Rule] -> NonTerminal -> PDef
constructRule :: String -> CF -> KeywordEnv -> [Rule] -> Cat -> PDef
constructRule String
packageAbsyn CF
cf KeywordEnv
env [Rule]
rules Cat
nt =
  Maybe String -> Cat -> [(String, String, Maybe String)] -> PDef
PDef Maybe String
forall a. Maybe a
Nothing Cat
nt ([(String, String, Maybe String)] -> PDef)
-> [(String, String, Maybe String)] -> PDef
forall a b. (a -> b) -> a -> b
$
    [ ( String
p
      , String -> Cat -> RFun -> [MetaVar] -> Bool -> String
forall f.
IsFun f =>
String -> Cat -> f -> [MetaVar] -> Bool -> String
generateAction String
packageAbsyn Cat
nt (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r) [MetaVar]
m Bool
b
      , Maybe String
forall a. Maybe a
Nothing  -- labels not needed for BNFC-generated AST parser
      -- , Just label
      -- -- Did not work:
      -- -- , if firstLowerCase (getLabelName label)
      -- --   == getRuleName (firstLowerCase $ identCat nt) then Nothing else Just label
      )
    | (Int
index, Rule
r0) <- [Int] -> [Rule] -> [(Int, Rule)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Rule]
rules
    , let b :: Bool
b      = 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) (CF -> [Cat]
forall function. CFG function -> [Cat]
cfgReversibleCats CF
cf)
    , let r :: Rule
r      = Bool -> (Rule -> Rule) -> Rule -> Rule
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b Rule -> Rule
forall f. Rul f -> Rul f
revSepListRule Rule
r0
    , let (String
p,[MetaVar]
m0) = Int -> KeywordEnv -> Rule -> (String, [MetaVar])
generatePatterns Int
index KeywordEnv
env Rule
r
    , let m :: [MetaVar]
m      = Bool -> ([MetaVar] -> [MetaVar]) -> [MetaVar] -> [MetaVar]
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b [MetaVar] -> [MetaVar]
forall a. [a] -> [a]
reverse [MetaVar]
m0
    -- , let label  = funRule r
    ]

-- Generates a string containing the semantic action.
generateAction :: IsFun f => String -> NonTerminal -> f -> [MetaVar]
               -> Bool   -- ^ Whether the list should be reversed or not.
                         --   Only used if this is a list rule.
               -> Action
generateAction :: String -> Cat -> f -> [MetaVar] -> Bool -> String
generateAction String
packageAbsyn Cat
nt f
f [MetaVar]
ms Bool
rev
    | f -> Bool
forall a. IsFun a => a -> Bool
isNilFun f
f = String
"$result = new " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"();"
    | f -> Bool
forall a. IsFun a => a -> Bool
isOneFun f
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
");"
    | f -> Bool
forall a. IsFun a => a -> Bool
isConsFun f
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
"$result." 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
");"
    | f -> Bool
forall a. IsFun a => a -> Bool
isCoercion f
f = String
"$result = " String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
p_1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    | f -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule f
f = String
"$result = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ f -> String
forall a. IsFun a => a -> String
funName f
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
"," ((MetaVar -> String) -> [MetaVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> String
resultvalue [MetaVar]
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
"," ((MetaVar -> String) -> [MetaVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> String
resultvalue [MetaVar]
ms) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
   where
     c :: String
c                 = String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            if f -> Bool
forall a. IsFun a => a -> Bool
isNilFun f
f Bool -> Bool -> Bool
|| f -> Bool
forall a. IsFun a => a -> Bool
isOneFun f
f Bool -> Bool -> Bool
|| f -> Bool
forall a. IsFun a => a -> Bool
isConsFun f
f
                            then Cat -> String
identCat (Cat -> Cat
normCat Cat
nt) else f -> String
forall a. IsFun a => a -> String
funName f
f
     p_1 :: String
p_1               = MetaVar -> String
resultvalue (MetaVar -> String) -> MetaVar -> String
forall a b. (a -> b) -> a -> b
$ [MetaVar]
ms[MetaVar] -> Int -> MetaVar
forall a. [a] -> Int -> a
!!Int
0
     p_2 :: String
p_2               = MetaVar -> String
resultvalue (MetaVar -> String) -> MetaVar -> String
forall a b. (a -> b) -> a -> b
$ [MetaVar]
ms[MetaVar] -> Int -> MetaVar
forall a. [a] -> Int -> a
!!Int
1
     add :: String
add               = if Bool
rev then String
"addLast" else String
"addFirst"
     gettext :: String
gettext           = String
"getText()"
     removeQuotes :: String -> String
removeQuotes String
x    = String
"substring(1, "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
+.+ String
gettext String -> String -> String
+.+ String
"length()-1)"
     parseint :: String -> String
parseint String
x        = String
"Integer.parseInt("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"
     parsedouble :: String -> String
parsedouble String
x     = String
"Double.parseDouble("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"
     charat :: String
charat            = String
"charAt(1)"
     resultvalue :: MetaVar -> String
resultvalue (String
n,Cat
c) = case Cat
c of
                          TokenCat String
"Ident"   -> String
n'String -> String -> String
+.+String
gettext
                          TokenCat String
"Integer" -> String -> String
parseint (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
n'String -> String -> String
+.+String
gettext
                          TokenCat String
"Char"    -> String
n'String -> String -> String
+.+String
gettextString -> String -> String
+.+String
charat
                          TokenCat String
"Double"  -> String -> String
parsedouble (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
n'String -> String -> String
+.+String
gettext
                          TokenCat String
"String"  -> String
n'String -> String -> String
+.+String
gettextString -> String -> String
+.+String -> String
removeQuotes String
n'
                          Cat
_         -> String -> String -> String
(+.+) String
n' (if Cat -> Bool
isTokenCat Cat
c then String
gettext else String
"result")
                          where n' :: String
n' = Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
:String
n

-- | Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
-- >>> generatePatterns 2 [] $ npRule "myfun" (Cat "A") [] Parsable
-- (" /* empty */ ",[])
-- >>> generatePatterns 3 [("def", "_SYMB_1")] $ npRule "myfun" (Cat "A") [Right "def", Left (Cat "B")] Parsable
-- ("_SYMB_1 p_3_2=b",[("p_3_2",B)])
generatePatterns :: Int -> KeywordEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns :: Int -> KeywordEnv -> Rule -> (String, [MetaVar])
generatePatterns Int
ind KeywordEnv
env Rule
r =
  case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
    []  -> (String
" /* empty */ ", [])
    SentForm
its -> ( [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, Either Cat String) -> Maybe String)
-> [(Int, Either Cat String)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Int -> Either Cat String -> Maybe String)
-> (Int, Either Cat String) -> Maybe String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Either Cat String -> Maybe String
forall a. Show a => a -> Either Cat String -> Maybe String
mkIt) [(Int, Either Cat String)]
nits
           , [ (Int -> String
forall a. Show a => a -> String
var Int
i, Cat
cat) | (Int
i, Left Cat
cat) <- [(Int, Either Cat String)]
nits ]
           )
      where
      nits :: [(Int, Either Cat String)]
nits   = [Int] -> SentForm -> [(Int, Either Cat String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] SentForm
its
      var :: a -> String
var a
i  = String
"p_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i   -- TODO: is ind needed for ANTLR?
      mkIt :: a -> Either Cat String -> Maybe String
mkIt a
i = \case
        Left  Cat
c -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
var a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
catToNT Cat
c
        Right String
s -> String -> KeywordEnv -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s KeywordEnv
env

catToNT :: Cat -> String
catToNT :: Cat -> String
catToNT = \case
  TokenCat String
"Ident"   -> String
"IDENT"
  TokenCat String
"Integer" -> String
"INTEGER"
  TokenCat String
"Char"    -> String
"CHAR"
  TokenCat String
"Double"  -> String
"DOUBLE"
  TokenCat String
"String"  -> String
"STRING"
  Cat
c | Cat -> Bool
isTokenCat Cat
c   -> Cat -> String
identCat Cat
c
    | Bool
otherwise      -> String -> String
firstLowerCase (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
getRuleName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat Cat
c

-- | Puts together the pattern and actions and returns a string containing all
-- the rules.
prRules :: String -> Rules -> String
prRules :: String -> Rules -> String
prRules String
packabs = (PDef -> String) -> Rules -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((PDef -> String) -> Rules -> String)
-> (PDef -> String) -> Rules -> String
forall a b. (a -> b) -> a -> b
$ \case

  -- No rules: skip.
  PDef Maybe String
_mlhs Cat
_nt []         -> String
""

  -- At least one rule: print!
  PDef Maybe String
mlhs Cat
nt ((String, String, Maybe String)
rhs : [(String, String, Maybe String)]
rhss) -> [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

    -- The definition header: lhs and type.
    [ [ [String] -> String
unwords [ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
nt' Maybe String
mlhs
                , String
"returns" , String
"[" , String
packabsString -> String -> String
+.+String
normcat , String
"result" , String
"]"
                ]
      ]
    -- The first rhs.
    , String -> (String, String, Maybe String) -> [String]
alternative String
"  :" (String, String, Maybe String)
rhs
    -- The other rhss.
    , ((String, String, Maybe String) -> [String])
-> [(String, String, Maybe String)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> (String, String, Maybe String) -> [String]
alternative String
"  |") [(String, String, Maybe String)]
rhss
    -- The definition footer.
    , [ String
"  ;" ]
    ]
    where
    alternative :: String -> (String, String, Maybe String) -> [String]
alternative String
sep (String
p, String
a, Maybe String
label) = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [String] -> String
unwords [ String
sep , String
p ] ]
      , [ [String] -> String
unwords [ String
"    {" , String
a , String
"}" ] ]
      , [ [String] -> String
unwords [ String
"    #" , String -> String
antlrRuleLabel String
l ] | Just String
l <- [Maybe String
label] ]
      ]
    catid :: String
catid              = Cat -> String
identCat Cat
nt
    normcat :: String
normcat            = Cat -> String
identCat (Cat -> Cat
normCat Cat
nt)
    nt' :: String
nt'                = String -> String
getRuleName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
firstLowerCase String
catid
    antlrRuleLabel :: Fun -> String
    antlrRuleLabel :: String -> String
antlrRuleLabel String
fnc
      | String -> Bool
forall a. IsFun a => a -> Bool
isNilFun String
fnc   = String
catid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_Empty"
      | String -> Bool
forall a. IsFun a => a -> Bool
isOneFun String
fnc   = String
catid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_AppendLast"
      | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
fnc  = String
catid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_PrependFirst"
      | String -> Bool
forall a. IsFun a => a -> Bool
isCoercion String
fnc = String
"Coercion_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
catid
      | Bool
otherwise      = String -> String
getLabelName String
fnc