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

{-
    BNF Converter: Java 1.5 Abstract Syntax
    Copyright (C) 2004  Author:  Michael Pellauer, Bjorn Bringert

    Description   : This module generates the Java Abstract Syntax
                    It uses the BNFC.Backend.Common.NamedVariables module for variable
                    naming. It returns a list of file names, and the
                    contents to be written into that file. (In Java
                    public classes must go in their own file.)

                    The generated classes also support the Visitor
                    Design Pattern.

    Author        : Michael Pellauer
                    Bjorn Bringert
    Created       : 24 April, 2003
    Modified      : 16 June, 2004

-}

module BNFC.Backend.Java.CFtoJavaAbs15 (cf2JavaAbs, typename, cat2JavaType) where

import Data.Bifunctor  ( first )
import Data.Char       ( isUpper, toLower )
import Data.Function   ( on )
import Data.List       ( findIndices, intercalate )
import Data.Maybe      ( mapMaybe )
import System.FilePath ( (</>) )
import Text.PrettyPrint as P

import BNFC.CF
import BNFC.Options     ( RecordPositions(..) )
import BNFC.TypeChecker ( buildContext, ctxTokens, isToken )
import BNFC.Utils       ( (+++), (++++), unless )

import BNFC.Backend.Common.NamedVariables ( UserDef, showNum )
import BNFC.Backend.Java.Utils            ( getRuleName )

--Produces abstract data types in Java.
--These follow Appel's "non-object oriented" version.
--They also allow users to use the Visitor design pattern.

type IVar = (String, Int, String)
-- ^ The type of an instance variable,
--   a number unique to that type,
--   and an optional name (handles typedefs).

-- | The result is a list of files (without file extension)
--   which must be written to disk.
--   The tuple is (FileName, FileContents)

cf2JavaAbs :: FilePath  -- ^ Directory for AST without trailing 'pathSeparator'.
  -> String -> String -> CF -> RecordPositions -> [(FilePath, String)]
cf2JavaAbs dirAbsyn packageBase packageAbsyn cf rp = concat
  [ unless (null defs)
    [ (dirAbsyn ++ "Def", unlines deftext) ]
  , map (first mkPath) $ concatMap (prData rp header packageAbsyn user) rules
  ]
  where
  header = "package " ++ packageAbsyn ++ ";\n"
  user   = [ n | (n,_) <- tokenPragmas cf ]
  rules  = getAbstractSyntax cf
  defs   = definitions cf
  deftext= concat
   [ [ "package " ++ packageBase ++ ";"
     , ""
     , "public class AbsynDef {"
     , ""
     , "  public static <B,A extends java.util.LinkedList<? super B>> A cons(B x, A xs) {"
     , "    xs.addFirst(x);"
     , "    return xs;"
     , "  }"
     , ""
     ]
   , definedRules defs packageAbsyn cf
   , [ "}"]
   ]
  mkPath :: String -> FilePath
  mkPath s = dirAbsyn </> s

definedRules :: [Define] -> String -> CF -> [String]
definedRules defs packageAbsyn cf = map rule defs
  where
    ctx = buildContext cf

    rule (Define f args e t) =
        unlines $ map ("  " ++) $
                [ "public static " ++ javaType t ++ " " ++ sanitize (funName f) ++ "(" ++
                    intercalate ", " (map javaArg args) ++ ") {"
                , "  return " ++ javaExp (map fst args) e ++ ";"
                , "}"
                ]
     where
       sanitize = getRuleName

       javaType :: Base -> String
       javaType = \case
           ListT (BaseT x) -> concat [ packageAbsyn, ".List", x ]
           BaseT x         -> typename packageAbsyn (ctxTokens ctx) x
           ListT ListT{}   -> undefined
           -- ListT t         -> javaType t -- undefined

       javaArg :: (String, Base) -> String
       javaArg (x,t) = javaType t ++ " " ++ x

       javaExp :: [String] -> Exp -> String
       javaExp args = \case
           Var x                -> x      -- argument
           App "[]" (FunT _ t) []
                                -> callQ (identType t) []
           App "(:)" _ es       -> call "cons" es
           App t _ [e]
             | isToken t ctx    -> javaExp args e     -- wraps new String
           App x _ es
             | isUpper (head x) -> callQ x es
             | otherwise        -> call (sanitize x) es
            -- -- | x `elem` args    -> call x es
           LitInt n             -> "Integer.valueOf(" ++ show n ++ ")"
           LitDouble x          -> "Double.valueOf(" ++ show x ++ ")"
           LitChar c            -> "Character.valueOf(" ++ show c ++ ")"
           LitString s          -> "String.valueOf(" ++ show s ++ ")"
         where
         call x es = x ++ "(" ++ intercalate ", " (map (javaExp args) es) ++ ")"
         callQ     = call . qualify
         qualify x = "new " ++ packageAbsyn ++ "." ++ x


-- | Generates a (possibly abstract) category class, and classes for all its rules.

prData :: RecordPositions -> String -> String -> [UserDef] -> Data ->[(String, String)]
prData rp header packageAbsyn user (cat, rules) =
  categoryClass ++ mapMaybe (prRule rp header packageAbsyn funs user cat) rules
      where
      funs = map fst rules
      categoryClass
          | catToStr cat `elem` funs = [] -- the catgory is also a function, skip abstract class
          | otherwise = [(cls, header ++++
                         unlines [
                                  "public abstract class" +++ cls
                                    +++ "implements java.io.Serializable {",
                                  "  public abstract <R,A> R accept("
                                  ++ cls ++ ".Visitor<R,A> v, A arg);",
                                  prVisitor packageAbsyn funs,
                                  "}"
                                 ])]
                where cls = identCat cat

prVisitor :: String -> [String] -> String
prVisitor packageAbsyn funs =
    unlines [
             "  public interface Visitor <R,A> {",
             unlines (map prVisitFun funs),
             "  }"
            ]
    where
    prVisitFun f = "    public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);"

-- | Generates classes for a rule, depending on what type of rule it is.

prRule :: RecordPositions     -- ^ Include line number info in generated classes.
       -> String   -- ^ Header.
       -> String   -- ^ Abstract syntax package name.
       -> [String] -- ^ Names of all constructors in the category.
       -> [UserDef] -> Cat -> (Fun, [Cat]) -> Maybe (String, String)
prRule rp h packageAbsyn funs user c (fun, cats)
  | isNilFun fun || isOneFun fun = Nothing  -- these are not represented in the Absyn
  | isConsFun fun = Just . (fun',) . unlines $ -- this is the linked list case.
      [ h
      , unwords [ "public class", fun', "extends", cat2JavaTypeTopList user c, "{" ]
      , "}"
      ]
  | otherwise = Just . (fun,) . unlines $ -- a standard rule
      [ h
      , unwords [ "public class", fun, ext, "{" ]
      , render $ nest 2 $ vcat
          [ prInstVars rp vs
          , prConstructor fun user vs cats
          ]
      , prAccept packageAbsyn c fun
      , prEquals packageAbsyn fun vs
      , prHashCode packageAbsyn fun vs
      , if isAlsoCategory then prVisitor packageAbsyn funs else ""
      , "}"
      ]
   where
     vs = getVars cats user
     fun' = identCat (normCat c)
     isAlsoCategory = fun == catToStr c
     --This handles the case where a LBNF label is the same as the category.
     ext = if isAlsoCategory then "" else " extends" +++ identCat c

-- | The standard accept function for the Visitor pattern.

prAccept :: String -> Cat -> String -> String
prAccept pack cat _ = "\n  public <R,A> R accept(" ++ pack ++ "." ++ catToStr cat
                      ++ ".Visitor<R,A> v, A arg) { return v.visit(this, arg); }\n"

-- | Creates the equals() method.

prEquals :: String -> String -> [IVar] -> String
prEquals pack fun vs =
    unlines $ map ("  "++) $ ["public boolean equals(java.lang.Object o) {",
                              "  if (this == o) return true;",
                              "  if (o instanceof " ++ fqn ++ ") {"]
                              ++ (if null vs
                                     then ["    return true;"]
                                     else ["    " ++ fqn +++ "x = ("++fqn++")o;",
                                           "    return " ++ checkKids ++ ";"]) ++
                             ["  }",
                              "  return false;",
                              "}"]
  where
  fqn = pack++"."++fun
  checkKids = intercalate " && " $ map checkKid vs
  checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")"
      where v = render (iVarName iv)

-- | Creates the hashCode() method.

prHashCode :: String -> String -> [IVar] -> String
prHashCode _ _ vs =
    unlines $ map ("  "++) ["public int hashCode() {",
                            "  return " ++ hashKids vs ++ ";",
                            "}"
                           ]
  where
  aPrime = "37"
  hashKids [] = aPrime
  hashKids (v:vs) = hashKids_ (hashKid v) vs
  hashKids_ = foldl (\r v -> aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v)
  hashKid iv = "this." ++ render (iVarName iv) ++ ".hashCode()"


-- | A class's instance variables.
--
-- >>> prInstVars NoRecordPositions [("A",1,""), ("B",1,""), ("A",2,"abc")]
-- public final A _1, abc_2;
-- public final B _1;
--
-- >>> prInstVars RecordPositions [("A",1,""), ("B",1,""), ("A",2,"abc")]
-- public final A _1, abc_2;
-- public final B _1;
-- public int line_num, col_num, offset;

prInstVars :: RecordPositions -> [IVar] -> Doc
prInstVars rp [] = case rp of
  RecordPositions -> "public int line_num, col_num, offset;"
  NoRecordPositions -> empty
prInstVars rp vars@((t,_,_):_) =
    "public" <+> "final" <+> text t <+> uniques P.<> ";" $$ prInstVars rp vs'
 where
   (uniques, vs') = prUniques t vars
   --these functions group the types together nicely
   prUniques :: String -> [IVar] -> (Doc, [IVar])
   prUniques t vs = (prVars vs (findIndices (\(y,_,_) ->  y == t) vs), remType t vs)
   prVars vs = hsep . punctuate comma . map (iVarName . (vs!!))
   remType :: String -> [IVar] -> [IVar]
   remType _ [] = []
   remType t ((t2,n,nm):ts)
    | t == t2 = remType t ts
    | otherwise = (t2,n,nm) : remType t ts

-- | Convert IVar to java name.
--
-- >>> iVarName ("A",1,"abc")
-- abc_1
--
-- >>> iVarName ("C", 2, "")
-- _2
--
-- >>> iVarName ("Integer", 0, "integer")
-- integer_

iVarName :: IVar -> Doc
iVarName (_,n,nm) = text (varName nm) P.<> text (showNum n)

-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
--
-- >>> prConstructor "bla" [] [("A",1,"a"),("B",1,""),("A",2,"")] [Cat "A",Cat "B", Cat "C"]
-- public bla(A p1, B p2, C p3) { a_1 = p1; _ = p2; _2 = p3; }
--
-- >>> prConstructor "EInt" [] [("Integer",0,"integer")] [Cat "Integer"]
-- public EInt(Integer p1) { integer_ = p1; }

prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> Doc
prConstructor c u vs cats =
    "public" <+> text c P.<> parens (interleave types params)
    <+> "{" <+> text (prAssigns vs params) P.<> "}"
  where
   (types, params) = unzip (prParams cats u (length cats) (length cats+1))
   interleave xs ys = hsep $ punctuate "," $ zipWith ((<+>) `on` text) xs ys

-- | Prints the parameters to the constructors.

prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)]
prParams cs user n m = zipWith pr cs [m-n, m-n+1 ..]
  where pr c k = (typename "" user (identCat c), 'p' : show k)

-- | This algorithm peeks ahead in the list so we don't use @map@ or @fold@.

prAssigns :: [IVar] -> [String] -> String
prAssigns [] _ = []
prAssigns _ [] = []
prAssigns ((t,n,nm):vs) (p:ps) =
 if n == 1 then
  case findIndices (\x -> case x of (l,_,_) -> l == t) vs of
    [] -> varName nm +++ "=" +++ p ++ ";" +++ prAssigns vs ps
    _ -> varName nm ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps
 else varName nm ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps

-- | Different than the standard ''BNFC.Backend.Common.NamedVariables'' version
-- because of the user-defined types.

getVars :: [Cat] -> [UserDef] -> [IVar]
getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs)
  where
  addVar is c = (c', n, c):is
    where c' = typename "" user c
          n = maximum (1:[n'+1 | (_,n',c'') <- is, c'' == c])
  singleToZero is =
    [ (t,n',nm)
    | (t,n,nm) <- is
    , let n' = if length [n | (_,_,n) <- is, n == nm] == 1 then 0 else n
    ]

varName :: String -- ^ category name
        -> String -- ^ Variable name
varName c = map toLower c ++ "_"

-- | This makes up for the fact that there's no typedef in Java.

typename
  :: String     -- ^ Qualification (can be empty).
  -> [UserDef]  -- ^ User-defined token names.
  -> String     -- ^ Category name.
  -> String
typename q user t
  | t == "Ident"   = "String"
  | t == "Char"    = "Character"
  | t == "Double"  = "Double"
  | t == "Integer" = "Integer"
  | t == "String"  = "String"
  | t `elem` user  = "String"
  | null q         = t
  | otherwise      = q ++ "." ++ t

-- | Print the Java type corresponding to a category.
cat2JavaType :: [UserDef] -> Cat -> String
cat2JavaType user = loop
  where
  loop = \case
    ListCat c -> "List" ++ loop c
    -- ListCat c -> "java.util.LinkedList<" ++ loop c ++ ">"
    c -> typename "" user $ identCat $ normCat c

-- | Print the Java type corresponding to a category.
--   The top list is printed as @java.util.LinkedList<...>@.
cat2JavaTypeTopList :: [UserDef] -> Cat -> String
cat2JavaTypeTopList user = \case
  ListCat c -> "java.util.LinkedList<" ++ cat2JavaType user c ++ ">"
  c -> cat2JavaType user c
