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

-- Type declarations

-- | A definition of a non-terminal by all its rhss,
--   together with parse actions.
data PDef = PDef
  { PDef -> Maybe Fun
_pdNT   :: Maybe String
      -- ^ If given, the name of the lhss.  Usually computed from 'pdCat'.
  , PDef -> Cat
_pdCat  :: Cat
      -- ^ The category to parse.
  , PDef -> [(Fun, Fun, Maybe Fun)]
_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 :: Fun -> Fun -> CF -> RecordPositions -> KeywordEnv -> Fun
cf2AntlrParse Fun
packageBase Fun
packageAbsyn CF
cf RecordPositions
_ KeywordEnv
env = [Fun] -> Fun
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ Fun
header
    , Fun
tokens
    , Fun
""
    -- Generate start rules [#272]
    -- _X returns [ dX result ] : x=X EOF { $result = $x.result; }
    , Fun -> Rules -> Fun
prRules Fun
packageAbsyn forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Cat -> PDef
entrypoint forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> List1 Cat
allEntryPoints CF
cf
    -- Generate regular rules
    , Fun -> Rules -> Fun
prRules Fun
packageAbsyn forall a b. (a -> b) -> a -> b
$ Fun -> CF -> KeywordEnv -> Rules
rulesForAntlr4 Fun
packageAbsyn CF
cf KeywordEnv
env
    ]
  ]
  where
    header :: String
    header :: Fun
header = [Fun] -> Fun
unlines
        [ Fun
"// Parser definition for use with ANTLRv4"
        , Fun
"parser grammar" Fun -> Fun -> Fun
+++ Fun
identifier forall a. [a] -> [a] -> [a]
++ Fun
"Parser;"
        ]
    tokens :: String
    tokens :: Fun
tokens = [Fun] -> Fun
unlines
        [ Fun
"options {"
        , Fun
"  tokenVocab = "forall a. [a] -> [a] -> [a]
++Fun
identifierforall a. [a] -> [a] -> [a]
++Fun
"Lexer;"
        , Fun
"}"
        ]
    identifier :: Fun
identifier = Fun -> Fun
getLastInPackage Fun
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 Fun -> Cat -> [(Fun, Fun, Maybe Fun)] -> PDef
PDef (forall a. a -> Maybe a
Just Fun
nt) Cat
cat [(Fun
pat, Fun
act, forall {a}. Maybe a
fun)]
  where
  nt :: Fun
nt  = Fun -> Fun
firstLowerCase forall a b. (a -> b) -> a -> b
$ Fun -> Fun
startSymbol forall a b. (a -> b) -> a -> b
$ Cat -> Fun
identCat Cat
cat
  pat :: Fun
pat = Fun
"x=" forall a. [a] -> [a] -> [a]
++ Cat -> Fun
catToNT Cat
cat Fun -> Fun -> Fun
+++ Fun
"EOF"
  act :: Fun
act = Fun
"$result = $x.result;"
  fun :: Maybe a
fun = 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 :: Fun -> CF -> KeywordEnv -> Rules
rulesForAntlr4 Fun
packageAbsyn CF
cf KeywordEnv
env = 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) = Fun -> CF -> KeywordEnv -> [Rule] -> Cat -> PDef
constructRule Fun
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 :: Fun -> CF -> KeywordEnv -> [Rule] -> Cat -> PDef
constructRule Fun
packageAbsyn CF
cf KeywordEnv
env [Rule]
rules Cat
nt =
  Maybe Fun -> Cat -> [(Fun, Fun, Maybe Fun)] -> PDef
PDef forall {a}. Maybe a
Nothing Cat
nt forall a b. (a -> b) -> a -> b
$
    [ ( Fun
p
      , forall f. IsFun f => Fun -> Cat -> f -> [MetaVar] -> Bool -> Fun
generateAction Fun
packageAbsyn Cat
nt (forall function. Rul function -> function
funRule Rule
r) [MetaVar]
m Bool
b
      , 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) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Rule]
rules
    , let b :: Bool
b      = 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) (forall function. CFG function -> [Cat]
cfgReversibleCats CF
cf)
    , let r :: Rule
r      = forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b forall f. Rul f -> Rul f
revSepListRule Rule
r0
    , let (Fun
p,[MetaVar]
m0) = Int -> KeywordEnv -> Rule -> (Fun, [MetaVar])
generatePatterns Int
index KeywordEnv
env Rule
r
    , let m :: [MetaVar]
m      = forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b 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 :: forall f. IsFun f => Fun -> Cat -> f -> [MetaVar] -> Bool -> Fun
generateAction Fun
packageAbsyn Cat
nt f
f [MetaVar]
ms Bool
rev
    | forall a. IsFun a => a -> Bool
isNilFun f
f = Fun
"$result = new " forall a. [a] -> [a] -> [a]
++ Fun
c forall a. [a] -> [a] -> [a]
++ Fun
"();"
    | forall a. IsFun a => a -> Bool
isOneFun f
f = Fun
"$result = new " forall a. [a] -> [a] -> [a]
++ Fun
c forall a. [a] -> [a] -> [a]
++ Fun
"(); $result.addLast("
        forall a. [a] -> [a] -> [a]
++ Fun
p_1 forall a. [a] -> [a] -> [a]
++ Fun
");"
    | forall a. IsFun a => a -> Bool
isConsFun f
f = Fun
"$result = " forall a. [a] -> [a] -> [a]
++ Fun
p_2 forall a. [a] -> [a] -> [a]
++ Fun
"; "
                           forall a. [a] -> [a] -> [a]
++ Fun
"$result." forall a. [a] -> [a] -> [a]
++ Fun
add forall a. [a] -> [a] -> [a]
++ Fun
"(" forall a. [a] -> [a] -> [a]
++ Fun
p_1 forall a. [a] -> [a] -> [a]
++ Fun
");"
    | forall a. IsFun a => a -> Bool
isCoercion f
f = Fun
"$result = " forall a. [a] -> [a] -> [a]
++  Fun
p_1 forall a. [a] -> [a] -> [a]
++ Fun
";"
    | forall a. IsFun a => a -> Bool
isDefinedRule f
f = Fun
"$result = " forall a. [a] -> [a] -> [a]
++ Fun
packageAbsyn forall a. [a] -> [a] -> [a]
++ Fun
"Def." forall a. [a] -> [a] -> [a]
++ Fun -> Fun
sanitize (forall a. IsFun a => a -> Fun
funName f
f)
                        forall a. [a] -> [a] -> [a]
++ Fun
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate Fun
"," (forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> Fun
resultvalue [MetaVar]
ms) forall a. [a] -> [a] -> [a]
++ Fun
");"
    | Bool
otherwise = Fun
"$result = new " forall a. [a] -> [a] -> [a]
++ Fun
c
                  forall a. [a] -> [a] -> [a]
++ Fun
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate Fun
"," (forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> Fun
resultvalue [MetaVar]
ms) forall a. [a] -> [a] -> [a]
++ Fun
");"
   where
     sanitize :: Fun -> Fun
sanitize          = Fun -> Fun
getRuleName
     c :: Fun
c                 = Fun
packageAbsyn forall a. [a] -> [a] -> [a]
++ Fun
"." forall a. [a] -> [a] -> [a]
++
                            if forall a. IsFun a => a -> Bool
isNilFun f
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isOneFun f
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConsFun f
f
                            then Cat -> Fun
identCat (Cat -> Cat
normCat Cat
nt) else forall a. IsFun a => a -> Fun
funName f
f
     p_1 :: Fun
p_1               = MetaVar -> Fun
resultvalue forall a b. (a -> b) -> a -> b
$ [MetaVar]
msforall a. [a] -> Int -> a
!!Int
0
     p_2 :: Fun
p_2               = MetaVar -> Fun
resultvalue forall a b. (a -> b) -> a -> b
$ [MetaVar]
msforall a. [a] -> Int -> a
!!Int
1
     add :: Fun
add               = if Bool
rev then Fun
"addLast" else Fun
"addFirst"
     gettext :: Fun
gettext           = Fun
"getText()"
     removeQuotes :: Fun -> Fun
removeQuotes Fun
x    = Fun
"substring(1, "forall a. [a] -> [a] -> [a]
++ Fun
x Fun -> Fun -> Fun
+.+ Fun
gettext Fun -> Fun -> Fun
+.+ Fun
"length()-1)"
     parseint :: Fun -> Fun
parseint Fun
x        = Fun
"Integer.parseInt("forall a. [a] -> [a] -> [a]
++Fun
xforall a. [a] -> [a] -> [a]
++Fun
")"
     parsedouble :: Fun -> Fun
parsedouble Fun
x     = Fun
"Double.parseDouble("forall a. [a] -> [a] -> [a]
++Fun
xforall a. [a] -> [a] -> [a]
++Fun
")"
     charat :: Fun
charat            = Fun
"charAt(1)"
     resultvalue :: MetaVar -> Fun
resultvalue (Fun
n,Cat
c) = case Cat
c of
                          TokenCat Fun
"Ident"   -> Fun
n'Fun -> Fun -> Fun
+.+Fun
gettext
                          TokenCat Fun
"Integer" -> Fun -> Fun
parseint forall a b. (a -> b) -> a -> b
$ Fun
n'Fun -> Fun -> Fun
+.+Fun
gettext
                          TokenCat Fun
"Char"    -> Fun
n'Fun -> Fun -> Fun
+.+Fun
gettextFun -> Fun -> Fun
+.+Fun
charat
                          TokenCat Fun
"Double"  -> Fun -> Fun
parsedouble forall a b. (a -> b) -> a -> b
$ Fun
n'Fun -> Fun -> Fun
+.+Fun
gettext
                          TokenCat Fun
"String"  -> Fun
n'Fun -> Fun -> Fun
+.+Fun
gettextFun -> Fun -> Fun
+.+Fun -> Fun
removeQuotes Fun
n'
                          Cat
_         -> Fun -> Fun -> Fun
(+.+) Fun
n' (if Cat -> Bool
isTokenCat Cat
c then Fun
gettext else Fun
"result")
                          where n' :: Fun
n' = Char
'$'forall a. a -> [a] -> [a]
:Fun
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 -> (Fun, [MetaVar])
generatePatterns Int
ind KeywordEnv
env Rule
r =
  case forall function. Rul function -> SentForm
rhsRule Rule
r of
    []  -> (Fun
" /* empty */ ", [])
    SentForm
its -> ( [Fun] -> Fun
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Show a => a -> Either Cat Fun -> Maybe Fun
mkIt) [(Int, Either Cat Fun)]
nits
           , [ (forall {a}. Show a => a -> Fun
var Int
i, Cat
cat) | (Int
i, Left Cat
cat) <- [(Int, Either Cat Fun)]
nits ]
           )
      where
      nits :: [(Int, Either Cat Fun)]
nits   = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] SentForm
its
      var :: a -> Fun
var a
i  = Fun
"p_" forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> Fun
show Int
ind forall a. [a] -> [a] -> [a]
++Fun
"_"forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> Fun
show a
i   -- TODO: is ind needed for ANTLR?
      mkIt :: a -> Either Cat Fun -> Maybe Fun
mkIt a
i = \case
        Left  Cat
c -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> Fun
var a
i forall a. [a] -> [a] -> [a]
++ Fun
"=" forall a. [a] -> [a] -> [a]
++ Cat -> Fun
catToNT Cat
c
        Right Fun
s -> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Fun
s KeywordEnv
env

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

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

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

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

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