{-
    BNF Converter: Java 1.5 Compositional Vistor generator
    Copyright (C) 2006 Bjorn Bringert
    Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006  Michael Pellauer

-}

{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Java.CFtoComposVisitor (cf2ComposVisitor) where

import Prelude hiding ((<>))

import Data.List   (intercalate)
import Data.Either (lefts)

import BNFC.CF
import BNFC.Backend.Java.CFtoJavaAbs15 (typename)
import BNFC.Utils ((+++))
import BNFC.Backend.Common.NamedVariables
import BNFC.PrettyPrint

cf2ComposVisitor :: String -> String -> CF -> String
cf2ComposVisitor :: String -> String -> CF -> String
cf2ComposVisitor String
packageBase String
packageAbsyn CF
cf = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
header
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> (Cat, [Rule]) -> String
prData String
packageAbsyn [String]
user) [(Cat, [Rule])]
groups
  , String
"}"
  ]
  where
    user :: [String]
user   = ((String, Reg) -> String) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Reg) -> String
forall a b. (a, b) -> a
fst ([(String, Reg)] -> [String]) -> [(String, Reg)] -> [String]
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])
g
        | g :: (Cat, [Rule])
g@(Cat
c,[Rule]
_) <- [(Cat, [Rule])] -> [(Cat, [Rule])]
fixCoercions (CF -> [(Cat, [Rule])]
ruleGroupsInternals CF
cf)
        , Bool -> Bool
not (Cat -> Bool
isList Cat
c)
        ]
    is :: [String]
is     = ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (Cat, [Rule]) -> String
prInterface String
packageAbsyn) [(Cat, [Rule])]
groups
    header :: String
header = [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
"package" String -> String -> String
+++ String
packageBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"/** BNFC-Generated Composition Visitor"
        , String
"*/"
        , String
""
        , String
"public class ComposVisitor<A>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
is then String
"" else String
" implements"
        ]
      , [ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
",\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
is | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
is ]
      , [ String
"{" ]
      ]


prInterface :: String -> (Cat, [Rule]) -> String
prInterface :: String -> (Cat, [Rule]) -> String
prInterface String
packageAbsyn (Cat
cat, [Rule]
_) =
    String
q String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".Visitor<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
q String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",A>"
  where q :: String
q = String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat Cat
cat

-- | 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) = [String] -> String
unlines
    [ String
"    /* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
identCat Cat
cat String -> String -> String
forall a. [a] -> [a] -> [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 (String -> [String] -> Cat -> Rule -> Doc
forall f. IsFun f => String -> [String] -> Cat -> Rul f -> Doc
prRule String
packageAbsyn [String]
user Cat
cat) [Rule]
rules
    ]

-- | Traverses a standard rule.
--
-- >>> prRule "lang.absyn" ["A"] (Cat "B") $ npRule "F" (Cat "B") [Left (Cat "A"), Right "+", Left (ListCat (Cat "B"))] Parsable
--     public lang.absyn.B visit(lang.absyn.F p, A arg)
--     {
--       String a_ = p.a_;
--       lang.absyn.ListB listb_ = new lang.absyn.ListB();
--       for (lang.absyn.B x : p.listb_)
--       {
--         listb_.add(x.accept(this,arg));
--       }
--       return new lang.absyn.F(a_, listb_);
--     }

prRule :: IsFun f => String -> [UserDef] -> Cat -> Rul f -> Doc
prRule :: forall f. IsFun f => String -> [String] -> Cat -> Rul f -> Doc
prRule String
packageAbsyn [String]
user Cat
cat (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) = Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
    [ Doc
"public " Doc -> Doc -> Doc
<> String -> Doc
qual (Cat -> String
identCat Cat
cat) Doc -> Doc -> Doc
<> Doc
" visit(" Doc -> Doc -> Doc
<> Doc
cls Doc -> Doc -> Doc
<> Doc
" p, A arg)"
    , Int -> [Doc] -> Doc
codeblock Int
2
        [ [Doc] -> Doc
vcat (((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 new" Doc -> Doc -> Doc
<+> Doc
cls Doc -> Doc -> Doc
<> Doc -> Doc
parens ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
"," [Doc]
vnames)) Doc -> Doc -> Doc
<> Doc
";"
        ]
    ]
  where
    cats' :: [(Cat, Doc)]
cats'  = [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
    cls :: Doc
cls    = String -> Doc
qual (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ f -> String
forall a. IsFun a => a -> String
funName f
fun
    qual :: String -> Doc
qual String
s = String -> Doc
text (String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
    vnames :: [Doc]
vnames = ((Cat, Doc) -> Doc) -> [(Cat, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, Doc) -> Doc
forall a b. (a, b) -> b
snd [(Cat, Doc)]
cats'
prRule  String
_ [String]
_ Cat
_ Rul f
_ = Doc
empty

-- | Traverses a class's instance variables.
--
-- >>> prCat "lang.absyn" ["A"] (Cat "A", "a_")
-- String a_ = p.a_;
--
-- >>> prCat "lang.absyn" [] (ListCat (Cat "Integer"), "listinteger_")
-- lang.absyn.ListInteger listinteger_ = p.listinteger_;
--
-- >>> prCat "lang.absyn" [] (ListCat (Cat "N"), "listn_")
-- lang.absyn.ListN listn_ = new lang.absyn.ListN();
-- for (lang.absyn.N x : p.listn_)
-- {
--   listn_.add(x.accept(this,arg));
-- }
--
-- >>> prCat "lang.absyn" [] (Cat "N", "n_")
-- lang.absyn.N n_ = p.n_.accept(this, arg);

prCat :: String     -- ^ Name of package for abstract syntax.
      -> [UserDef]  -- ^ User defined token categories.
      -> (Cat, Doc) -- ^ Variable category and names.
      -> Doc        -- ^ Code for visiting the variable.
prCat :: String -> [String] -> (Cat, Doc) -> Doc
prCat String
packageAbsyn [String]
user (Cat
cat, Doc
nt)
  | [String] -> String -> Bool
isBasicType [String]
user String
varType Bool -> Bool -> Bool
|| (Cat -> Bool
isList Cat
cat Bool -> Bool -> Bool
&& [String] -> String -> Bool
isBasicType [String]
user String
et) = Doc -> Doc
decl Doc
var
  | Cat -> Bool
isList Cat
cat = [Doc] -> Doc
vcat
      [ Doc -> Doc
decl (Doc
"new" Doc -> Doc -> Doc
<+> String -> Doc
text String
varType Doc -> Doc -> Doc
<> Doc
"()")
      , Doc
"for (" Doc -> Doc -> Doc
<> String -> Doc
text String
et Doc -> Doc -> Doc
<> Doc
" x : " Doc -> Doc -> Doc
<> Doc
var Doc -> Doc -> Doc
<> Doc
")"
      , Int -> [Doc] -> Doc
codeblock Int
2 [ Doc
nt Doc -> Doc -> Doc
<> Doc
".add(x.accept(this,arg));" ]
      ]
  | Bool
otherwise = Doc -> Doc
decl (Doc
var Doc -> Doc -> Doc
<> Doc
".accept(this, arg)")
  where
    var :: Doc
var     = Doc
"p." Doc -> Doc -> Doc
<> Doc
nt
    varType :: String
varType = 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
normCat Cat
cat
    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
    decl :: Doc -> Doc
decl Doc
v  = String -> Doc
text String
varType Doc -> Doc -> Doc
<+> Doc
nt Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
v Doc -> Doc -> Doc
<> Doc
";"
    -- qual s  = text (packageAbsyn ++ "." ++ s)

-- | Just checks if something is a basic or user-defined type.

isBasicType :: [UserDef] -> String -> Bool
isBasicType :: [String] -> String -> Bool
isBasicType [String]
user String
v =
    String
v String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([String]
user [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Integer",String
"Character",String
"String",String
"Double"])