{-
    BNF Converter: Java Vistor skeleton generator
    Copyright (C) 2004  Author:  Michael Pellauer, Bjorn Bringert

    Description   : This module generates a Skeleton function
                    which uses the Visitor Design Pattern, which
                    users may find more familiar than Appel's
                    method.

    Author        : Michael Pellauer
                    Bjorn Bringert
    Created       : 4 August, 2003
    Modified      : 16 June, 2004

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Java.CFtoVisitSkel15 (cf2VisitSkel) where

import Data.Bifunctor   ( second )
import Data.Either      ( lefts  )
import Text.PrettyPrint
import qualified Text.PrettyPrint as P

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

import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Java.CFtoJavaAbs15    ( typename )

--Produces a Skeleton using the Visitor Design Pattern.
--Thus the user can choose which Skeleton to use.

cf2VisitSkel :: String -> String -> CF -> String
cf2VisitSkel :: String -> String -> CF -> String
cf2VisitSkel String
packageBase String
packageAbsyn CF
cf =
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
    String
header,
    ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> [String] -> (Cat, [Rule]) -> String
prData String
packageAbsyn [String]
user) [(Cat, [Rule])]
groups,
    String
"}"]
  where
    user :: [String]
user   = ([String], [Reg]) -> [String]
forall a b. (a, b) -> a
fst (([String], [Reg]) -> [String]) -> ([String], [Reg]) -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, Reg)] -> ([String], [Reg])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, Reg)] -> ([String], [Reg]))
-> [(String, Reg)] -> ([String], [Reg])
forall a b. (a -> b) -> a -> b
$ CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf
    groups :: [(Cat, [Rule])]
groups = [(Cat, [Rule])] -> [(Cat, [Rule])]
fixCoercions ([(Cat, [Rule])] -> [(Cat, [Rule])])
-> [(Cat, [Rule])] -> [(Cat, [Rule])]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroupsInternals CF
cf
    header :: String
header = [String] -> String
unlines [
      String
"package" String -> String -> String
+++ String
packageBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";",
      String
"",
      String
"/*** Visitor Design Pattern Skeleton. ***/",
      String
"",
      String
"/* This implements the common visitor design pattern.",
      String
"   Tests show it to be slightly less efficient than the",
      String
"   instanceof method, but easier to use. ",
      String
"   Replace the R and A parameters with the desired return",
      String
"   and context types.*/",
      String
"",
      String
"public class VisitSkel",
      String
"{"
      ]


--Traverses a category based on its type.
prData :: String -> [UserDef] -> (Cat, [Rule]) -> String
prData :: String -> [String] -> (Cat, [Rule]) -> String
prData String
packageAbsyn [String]
user (Cat
cat, [Rule]
rules)
    | Cat -> Bool
isList Cat
cat = String
""
    | Bool
otherwise = [String] -> String
unlines
        [String
"  public class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Visitor<R,A> implements "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
qual (Cat -> String
identCat Cat
cat) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".Visitor<R,A>"
        , String
"  {"
        , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Rule -> Doc) -> [Rule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> (Rule -> Doc) -> Rule -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> Rule -> Doc
forall f. IsFun f => String -> [String] -> Rul f -> Doc
prRule String
packageAbsyn [String]
user) [Rule]
rules
        , String
"  }"
        ]
  where
  qual :: String -> String
qual String
x = String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x

-- | traverses a standard rule.
-- >>> prRule "ABSYN" [] $ Rule "EInt" undefined [Left (TokenCat "Integer"), Left (Cat "NT")] Parsable
-- public R visit(ABSYN.EInt p, A arg)
-- { /* Code for EInt goes here */
--   //p.integer_;
--   p.nt_.accept(new NTVisitor<R,A>(), arg);
--   return null;
-- }
--
-- It skips the internal category (indicating that a rule is not parsable)
-- >>> prRule "ABSYN" [] $ Rule "EInt" undefined [Left (TokenCat "Integer")] Internal
-- public R visit(ABSYN.EInt p, A arg)
-- { /* Code for EInt goes here */
--   //p.integer_;
--   return null;
-- }
prRule :: IsFun f => String -> [UserDef] -> Rul f -> Doc
prRule :: String -> [String] -> Rul f -> Doc
prRule String
packageAbsyn [String]
user (Rule f
fun RCat
_ SentForm
cats InternalRule
_)
  | Bool -> Bool
not (f -> Bool
forall a. IsFun a => a -> Bool
isCoercion f
fun Bool -> Bool -> Bool
|| f -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule f
fun) = [Doc] -> Doc
vcat
    [ Doc
"public R visit(" Doc -> Doc -> Doc
P.<> String -> Doc
text String
packageAbsyn Doc -> Doc -> Doc
P.<> Doc
"." Doc -> Doc -> Doc
P.<> Doc
fname Doc -> Doc -> Doc
P.<> Doc
" p, A arg)"
    , Doc
"{"
    , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
        [ Doc
"/* Code for " Doc -> Doc -> Doc
P.<> Doc
fname Doc -> Doc -> Doc
P.<> Doc
" goes here */"
        , [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((Cat, Doc) -> Doc) -> [(Cat, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> (Cat, Doc) -> Doc
prCat String
packageAbsyn [String]
user) [(Cat, Doc)]
cats'
        , Doc
"return null;"
        ]
    , Doc
"}"
    ]
  where
    fname :: Doc
fname = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ f -> String
forall a. IsFun a => a -> String
funName f
fun              -- function name
    cats' :: [(Cat, Doc)]
cats' = ((Cat, Doc) -> (Cat, Doc)) -> [(Cat, Doc)] -> [(Cat, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc) -> (Cat, Doc) -> (Cat, Doc)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Doc
"p." Doc -> Doc -> Doc
P.<>)) ([(Cat, Doc)] -> [(Cat, Doc)]) -> [(Cat, Doc)] -> [(Cat, Doc)]
forall a b. (a -> b) -> a -> b
$ [Either (Cat, Doc) String] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts ([Either (Cat, Doc) String] -> [(Cat, Doc)])
-> [Either (Cat, Doc) String] -> [(Cat, Doc)]
forall a b. (a -> b) -> a -> b
$ SentForm -> [Either (Cat, Doc) String]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars SentForm
cats  -- non-terminals in the rhs
prRule String
_ [String]
_ Rul f
_ = Doc
empty

-- | Traverses a class's instance variables.
--
-- >>> prCat "ABSYN" [] (Cat "A", "p.a_")
-- p.a_.accept(new AVisitor<R,A>(), arg);
--
-- >>> prCat "" [] (TokenCat "Integer", "p.integer_")
-- //p.integer_;
--
-- >>> prCat "" ["A"] (TokenCat "A", "p.a_")
-- //p.a_;
--
-- >>> prCat "" ["A"] (TokenCat "A", "p.a_2")
-- //p.a_2;
--
-- >>> prCat "ABSYN" [] (ListCat (Cat "A"), "p.lista_")
-- for (ABSYN.A x: p.lista_) {
--   x.accept(new AVisitor<R,A>(), arg);
-- }
prCat :: String       -- ^ absyn package name.
      -> [UserDef]    -- ^ User defined tokens.
      -> (Cat, Doc)   -- ^ Variable category and name.
      -> Doc          -- ^ Code for visiting the variable.
prCat :: String -> [String] -> (Cat, Doc) -> Doc
prCat String
packageAbsyn [String]
user (Cat
cat, Doc
var) =
  case Cat
cat of
    TokenCat{}   -> Doc
"//" Doc -> Doc -> Doc
P.<> Doc
var Doc -> Doc -> Doc
P.<> Doc
";"
    ListCat Cat
cat' -> [Doc] -> Doc
vcat
      [ Doc
"for" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text String
et Doc -> Doc -> Doc
<+> Doc
"x:" Doc -> Doc -> Doc
<+> Doc
var) Doc -> Doc -> Doc
<+> Doc
"{"
      , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [String] -> (Cat, Doc) -> Doc
prCat String
packageAbsyn [String]
user (Cat
cat', Doc
"x")
      , Doc
"}"
      ]
    Cat
_ -> Doc
var Doc -> Doc -> Doc
P.<> Doc
".accept(new " Doc -> Doc -> Doc
P.<> String -> Doc
text String
varType Doc -> Doc -> Doc
P.<> Doc
"Visitor<R,A>(), arg);"
  where
    varType :: String
varType = String -> [String] -> String -> String
typename String
"" [String]
user (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat    -- no qualification here!
    et :: String
et      = String -> [String] -> String -> String
typename String
packageAbsyn [String]
user (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCatOfList Cat
cat