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


--Traverses a category based on its type.
prData :: String -> [UserDef] -> (Cat, [Rule]) -> String
prData :: [Char] -> [[Char]] -> (Cat, [Rule]) -> [Char]
prData [Char]
packageAbsyn [[Char]]
user (Cat
cat, [Rule]
rules)
    | Cat -> Bool
isList Cat
cat = [Char]
""
    | Bool
otherwise = [[Char]] -> [Char]
unlines
        [[Char]
"  public class " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
identCat Cat
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Visitor<R,A> implements "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
qual (Cat -> [Char]
identCat Cat
cat) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".Visitor<R,A>"
        , [Char]
"  {"
        , Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
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
. [Char] -> [[Char]] -> Rule -> Doc
forall f. IsFun f => [Char] -> [[Char]] -> Rul f -> Doc
prRule [Char]
packageAbsyn [[Char]]
user) [Rule]
rules
        , [Char]
"  }"
        ]
  where
  qual :: [Char] -> [Char]
qual [Char]
x = [Char]
packageAbsyn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 :: forall f. IsFun f => [Char] -> [[Char]] -> Rul f -> Doc
prRule [Char]
packageAbsyn [[Char]]
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.<> [Char] -> Doc
text [Char]
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 ([Char] -> [[Char]] -> (Cat, Doc) -> Doc
prCat [Char]
packageAbsyn [[Char]]
user) [(Cat, Doc)]
cats'
        , Doc
"return null;"
        ]
    , Doc
"}"
    ]
  where
    fname :: Doc
fname = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ f -> [Char]
forall a. IsFun a => a -> [Char]
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) [Char]] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts ([Either (Cat, Doc) [Char]] -> [(Cat, Doc)])
-> [Either (Cat, Doc) [Char]] -> [(Cat, Doc)]
forall a b. (a -> b) -> a -> b
$ SentForm -> [Either (Cat, Doc) [Char]]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars SentForm
cats  -- non-terminals in the rhs
prRule [Char]
_ [[Char]]
_ 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 :: [Char] -> [[Char]] -> (Cat, Doc) -> Doc
prCat [Char]
packageAbsyn [[Char]]
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 ([Char] -> Doc
text [Char]
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
$ [Char] -> [[Char]] -> (Cat, Doc) -> Doc
prCat [Char]
packageAbsyn [[Char]]
user (Cat
cat', Doc
"x")
      , Doc
"}"
      ]
    Cat
_ -> Doc
var Doc -> Doc -> Doc
P.<> Doc
".accept(new " Doc -> Doc -> Doc
P.<> [Char] -> Doc
text [Char]
varType Doc -> Doc -> Doc
P.<> Doc
"Visitor<R,A>(), arg);"
  where
    varType :: [Char]
varType = [Char] -> [[Char]] -> [Char] -> [Char]
typename [Char]
"" [[Char]]
user ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> [Char]
identCat (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat    -- no qualification here!
    et :: [Char]
et      = [Char] -> [[Char]] -> [Char] -> [Char]
typename [Char]
packageAbsyn [[Char]]
user ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> [Char]
identCat (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCatOfList Cat
cat