content: {-
      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 packageBase packageAbsyn cf = concat
    [ header
    , intercalate "\n" $ map (prData packageAbsyn user) groups
    , "}"
    ]
    where
      user   = map fst $ tokenPragmas cf
      groups =
          [ g
          | g@(c,_) <- fixCoercions (ruleGroupsInternals cf)
          , not (isList c)
          ]
      is     = map (prInterface packageAbsyn) groups
      header = unlines $ concat
        [ [ "package" +++ packageBase ++ ";"
          , "/** Composition Visitor"
          , "*/"
          , ""
          , "public class ComposVisitor<A>" ++ if null is then "" else " implements"
          ]
        , [ intercalate ",\n" $ map ("  " ++) is | not $ null is ]
        , [ "{" ]
        ]
  
  
  prInterface :: String -> (Cat, [Rule]) -> String
  prInterface packageAbsyn (cat, _) =
      q ++ ".Visitor<" ++ q ++ ",A>"
    where q = packageAbsyn ++ "." ++ identCat cat
  
  -- | Traverses a category based on its type.
  
  prData :: String -> [UserDef] -> (Cat, [Rule]) -> String
  prData packageAbsyn user (cat, rules) = unlines
      [ "    /* " ++ identCat cat ++ " */"
      , render $ vcat $ map (prRule packageAbsyn user cat) 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 packageAbsyn user cat (Rule fun _ cats _)
    | not (isCoercion fun || isDefinedRule fun) = nest 4 $ vcat
      [ "public " <> qual (identCat cat) <> " visit(" <> cls <> " p, A arg)"
      , codeblock 2
          [ vcat (map (prCat packageAbsyn user) cats')
          , "return new" <+> cls <> parens (hsep (punctuate "," vnames)) <> ";"
          ]
      ]
    where
      cats'  = lefts $ numVars cats
      cls    = qual $ funName fun
      qual s = text (packageAbsyn ++ "." ++ s)
      vnames = map snd cats'
  prRule  _ _ _ _ = 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 packageAbsyn user (cat, nt)
    | isBasicType user varType || (isList cat && isBasicType user et) = decl var
    | isList cat = vcat
        [ decl ("new" <+> text varType <> "()")
        , "for (" <> text et <> " x : " <> var <> ")"
        , codeblock 2 [ nt <> ".add(x.accept(this,arg));" ]
        ]
    | otherwise = decl (var <> ".accept(this, arg)")
    where
      var     = "p." <> nt
      varType = typename packageAbsyn user $ identCat $ normCat cat
      et      = typename packageAbsyn user $ identCat $ normCatOfList cat
      decl v  = text varType <+> nt <+> "=" <+> v <> ";"
      -- qual s  = text (packageAbsyn ++ "." ++ s)
  
  -- | Just checks if something is a basic or user-defined type.
  
  isBasicType :: [UserDef] -> String -> Bool
  isBasicType user v =
      v `elem` (user ++ ["Integer","Character","String","Double"])
  