{-
    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
  { _pdNT   :: Maybe String
      -- ^ If given, the name of the lhss.  Usually computed from 'pdCat'.
  , _pdCat  :: Cat
      -- ^ The category to parse.
  , _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 lang packageAbsyn cf _ env = unlines $ concat
  [ [ header
    , tokens
    , ""
    -- Generate start rules [#272]
    -- _X returns [ dX result ] : x=X EOF { $result = $x.result; }
    , prRules packageAbsyn $ map entrypoint $ toList $ allEntryPoints cf
    -- Generate regular rules
    , prRules packageAbsyn $ rulesForAntlr4 packageAbsyn cf env
    ]
  ]
  where
    header :: String
    header = unlines
        [ "// Parser definition for use with ANTLRv4"
        , "parser grammar" +++ lang ++ "Parser;"
        ]
    tokens :: String
    tokens = unlines
        [ "options {"
        , "  tokenVocab = " ++ lang ++ "Lexer;"
        , "}"
        ]

-- | 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 (Just nt) cat [(pat, act, fun)]
  where
  nt  = firstLowerCase $ startSymbol $ identCat cat
  pat = "x=" ++ catToNT cat +++ "EOF"
  act = "$result = $x.result;"
  fun = 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 packageAbsyn cf env = map mkOne getrules
  where
    getrules          = ruleGroups cf
    mkOne (cat,rules) = constructRule packageAbsyn cf env rules 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 packageAbsyn cf env rules nt =
  PDef Nothing nt $
    [ ( p
      , generateAction packageAbsyn nt (funRule r) m b
      , 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
      )
    | (index, r0) <- zip [1..] rules
    , let b      = isConsFun (funRule r0) && elem (valCat r0) (cfgReversibleCats cf)
    , let r      = applyWhen b revSepListRule r0
    , let (p,m0) = generatePatterns index env r
    , let m      = applyWhen b reverse 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 packageAbsyn nt f ms rev
    | isNilFun f = "$result = new " ++ c ++ "();"
    | isOneFun f = "$result = new " ++ c ++ "(); $result.addLast("
        ++ p_1 ++ ");"
    | isConsFun f = "$result = " ++ p_2 ++ "; "
                           ++ "$result." ++ add ++ "(" ++ p_1 ++ ");"
    | isCoercion f = "$result = " ++  p_1 ++ ";"
    | isDefinedRule f = "$result = " ++ packageAbsyn ++ "Def." ++ sanitize (funName f)
                        ++ "(" ++ intercalate "," (map resultvalue ms) ++ ");"
    | otherwise = "$result = new " ++ c
                  ++ "(" ++ intercalate "," (map resultvalue ms) ++ ");"
   where
     sanitize          = getRuleName
     c                 = packageAbsyn ++ "." ++
                            if isNilFun f || isOneFun f || isConsFun f
                            then identCat (normCat nt) else funName f
     p_1               = resultvalue $ ms!!0
     p_2               = resultvalue $ ms!!1
     add               = if rev then "addLast" else "addFirst"
     removeQuotes x    = x +.+ "substring(1, " ++ x +.+ "length()-1)"
     unescape x        = removeQuotes x +.+ "translateEscapes()"  -- Java 15 and higher
     resultvalue (n,c) = case c of
                          TokenCat "Double"  -> concat [ "Double.parseDouble(", txt, ")" ]
                          TokenCat "Integer" -> concat [ "Integer.parseInt("  , txt, ")" ]
                          TokenCat "Char"    -> unescape txt +.+ "charAt(0)"
                          TokenCat "String"  -> unescape txt
                          TokenCat "Ident"   -> txt
                          c | isTokenCat c   -> txt
                            | otherwise      -> concat [ "$", n, ".result" ]
                          where txt = '$':n +.+ "getText()"

-- | 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 ind env r =
  case rhsRule r of
    []  -> (" /* empty */ ", [])
    its -> ( unwords $ mapMaybe (uncurry mkIt) nits
           , [ (var i, cat) | (i, Left cat) <- nits ]
           )
      where
      nits   = zip [1 :: Int ..] its
      var i  = "p_" ++ show ind ++"_"++ show i   -- TODO: is ind needed for ANTLR?
      mkIt i = \case
        Left  c -> Just $ var i ++ "=" ++ catToNT c
        Right s -> lookup s env

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

-- | Puts together the pattern and actions and returns a string containing all
-- the rules.
prRules :: String -> Rules -> String
prRules packabs = concatMap $ \case

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

  -- At least one rule: print!
  PDef mlhs nt (rhs : rhss) -> unlines $ concat

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