{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}

{-
    BNF Converter: C++ abstract syntax generator
    Copyright (C) 2004  Author:  Michael Pellauer

    Description   : This module generates the C++ Abstract Syntax
                    tree classes. It generates both a Header file
                    and an Implementation file, and uses the Visitor
                    design pattern.

    Author        : Michael Pellauer
    Created       : 4 August, 2003
    Modified      : 22 May, 2004 / Antti-Juhani Kaijanaho
-}

module BNFC.Backend.CPP.NoSTL.CFtoCPPAbs (cf2CPPAbs) where

import Prelude hiding ((<>))

import BNFC.CF
import BNFC.Utils((+++),(++++))
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Common.OOAbstract
import Data.List
import Data.Char(toLower)
import Text.PrettyPrint


--The result is two files (.H file, .C file)
cf2CPPAbs :: String -> CF -> (String, String)
cf2CPPAbs _ cf = (mkHFile cf, mkCFile cf)


{- **** Header (.H) File Functions **** -}

--Makes the Header file.
mkHFile :: CF -> String
mkHFile cf = unlines
 [
  "#ifndef ABSYN_HEADER",
  "#define ABSYN_HEADER",
  "",
  header,
  prTypeDefs user,
  "/********************   Forward Declarations    ********************/\n",
  concatMap prForward classes,
  "",
  prVisitor classes,
  prVisitable,
  "",
  "/********************   Abstract Syntax Classes    ********************/\n",
  concatMap (prDataH user) (getAbstractSyntax cf),
  "",
  "#endif"
 ]
 where
  user = fst (unzip (tokenPragmas cf)) -- includes position tokens
  -- user = [ name | TokenReg name False _ <- cfgPragmas cf ]  -- position tokens are in allClasses already
  header = "/* ~~~ C++ Abstract Syntax Interface generated by the BNF Converter.\n ~~~ */"
  ca = cf2cabs cf
  classes = absclasses ca ++ conclasses ca ++ map fst (listtypes ca)
  -- classes = allClasses (cf2cabs cf)  -- includes position tokens
  prForward s | isProperLabel s = "class " ++ s ++ ";\n"
  prForward _ = ""

--Prints interface classes for all categories.
prDataH :: [UserDef] -> Data -> String
prDataH  user (cat, rules) =
    case lookup (show cat) rules of
        Just _ -> concatMap (prRuleH user cat) rules
        Nothing -> if isList cat
            then concatMap (prRuleH user cat) rules
            else unlines
                [ "class" +++ identCat cat +++ ": public Visitable {"
                , "public:"
                , "  virtual" +++ identCat cat +++ "*clone() const = 0;"
                , "};\n"
                , concatMap (prRuleH user cat) rules
                ]

--Interface definitions for rules vary on the type of rule.
prRuleH :: [UserDef] -> Cat -> (Fun, [Cat]) -> String
prRuleH user c (fun, cats) =
    if isNilFun fun || isOneFun fun
    then ""  --these are not represented in the AbSyn
    else if isConsFun fun
    then --this is the linked list case.
    unlines
    [
     "class" +++ c' +++ ": public Visitable",
     "{",
     " public:",
     render $ nest 2 $ prInstVars user vs,
     "  " ++ c' ++ "(const" +++ c' +++ "&);",
     "  " ++ c' ++ " &operator=(const" +++ c' +++ "&);",
     "  " ++ c' ++ "(" ++ (prConstructorH 1 vs) ++ ");",
     "  " ++ c' ++ "(" ++ mem +++ memstar ++ "p);",
     prDestructorH c',
     "  " ++ c' ++ "* reverse();",
     "  " ++ c' ++ "* reverse(" ++ c' ++ " *l);",
     "  virtual void accept(Visitor *v);",
     "  virtual " ++ c' ++ " *clone() const;",
     "  void swap(" ++ c' +++ "&);",
     "};"
    ]
    else --a standard rule
    unlines
    [
     "class" +++ fun +++ ": public" +++ super,
     "{",
     " public:",
     render $ nest 2 $ prInstVars user vs,
     "  " ++ fun ++ "(const" +++ fun +++ "&);",
     "  " ++ fun ++ " &operator=(const" +++ fun +++ "&);",
     "  " ++ fun ++ "(" ++ prConstructorH 1 vs ++ ");",
     prDestructorH fun,
     "  virtual void accept(Visitor *v);",
     "  virtual " +++ fun +++ " *clone() const;",
     "  void swap(" ++ fun +++ "&);",
     "};\n"
    ]
   where
     vs = getVars cats
     c' = identCat (normCat c);
     mem = drop 4 c'
     memstar = if isBasic user mem then "" else "*"
     super = if show c == fun then "Visitable" else identCat c
     prConstructorH :: Int -> [(String, b)] -> String
     prConstructorH _ [] = ""
     prConstructorH n [(t,_)] = t +++ optstar t ++ "p" ++ show n
     prConstructorH n ((t,_):vs) = t +++ optstar t ++ "p" ++ show n ++ ", " ++ prConstructorH (n+1) vs
     prDestructorH n = "  ~" ++ n ++ "();"
     optstar x = if isBasic user x
       then ""
       else "*"

prVisitable :: String
prVisitable = unlines
 [
  "class Visitable",
  "{",
  " public:",
  -- all classes with virtual methods require a virtual destructor
  "  virtual ~Visitable() {}",
  "  virtual void accept(Visitor *v) = 0;",
  "};\n"
 ]

prVisitor :: [String] -> String
prVisitor fs = unlines
 [
  "/********************   Visitor Interfaces    ********************/",
  "",
  "class Visitor",
  "{",
  " public:",
  "  virtual ~Visitor() {}",
  concatMap prVisitFun fs,
  footer
 ]
 where
   footer = unlines
    [  --later only include used categories
     "  virtual void visitInteger(Integer i) = 0;",
     "  virtual void visitDouble(Double d) = 0;",
     "  virtual void visitChar(Char c) = 0;",
     "  virtual void visitString(String s) = 0;",
     "};"
    ]
   prVisitFun f | isProperLabel f =
     "  virtual void visit" ++ f ++ "(" ++ f ++ " *p) = 0;\n"
   prVisitFun _ = ""

--typedefs in the Header make generation much nicer.
prTypeDefs user = unlines
  [
   "/********************   TypeDef Section    ********************/",
   "typedef int Integer;",
   "typedef char Char;",
   "typedef double Double;",
   "typedef char* String;",
   "typedef char* Ident;",
   concatMap prUserDef user
  ]
 where
  prUserDef s = "typedef char* " ++ s ++ ";\n"

-- | A class's instance variables.
-- >>> prInstVars ["MyTokn"] [("MyTokn",1), ("A",1), ("A",2)]
-- MyTokn mytokn_1;
-- A *a_1, *a_2;
prInstVars :: [UserDef] -> [IVar] -> Doc
prInstVars _ [] = empty
prInstVars user vars@((t,_):_) =
    text t <+> uniques <> ";" $$ prInstVars user vs'
 where
    (uniques, vs') = prUniques t
    --these functions group the types together nicely
    prUniques :: String -> (Doc, [IVar])
    prUniques t = (prVars (findIndices (\(y,_) ->  y == t) vars), remType t vars)
    prVars = hsep . punctuate comma . map prVar
    prVar x = let (t,n) = vars !! x in varLinkName t <> text (showNum n)
    varLinkName z = if isBasic user z
      then text (map toLower z) <> "_"
      else "*" <> text (map toLower z) <> "_"
    remType :: String -> [IVar] -> [IVar]
    remType _ [] = []
    remType t ((t2,n):ts) = if t == t2
        then remType t ts
        else (t2,n) : remType t ts


{- **** Implementation (.C) File Functions **** -}

--Makes the .C file
mkCFile :: CF -> String
mkCFile cf = unlines
 [
  header,
  concatMap (prDataC user) (getAbstractSyntax cf)
 ]
 where
  user = fst (unzip (tokenPragmas cf))
  header = unlines
   [
    "//C++ Abstract Syntax Implementation generated by the BNF Converter.",
    "#include <algorithm>",
    "#include \"Absyn.H\""
   ]

--This is not represented in the implementation.
prDataC :: [UserDef] -> Data -> String
prDataC user (cat, rules) = concatMap (prRuleC user cat) rules

--Classes for rules vary based on the type of rule.
prRuleC user c (fun, cats) =
    if isNilFun fun || isOneFun fun
    then ""  --these are not represented in the AbSyn
    else if isConsFun fun
    then --this is the linked list case.
    unlines
    [
     "/********************   " ++ c' ++ "    ********************/",
     render $ prConstructorC user c' vs cats,
     prCopyC user c' vs,
     prDestructorC user c' vs,
     prListFuncs user c',
     prAcceptC c',
     prCloneC user c' vs,
     ""
    ]
    else --a standard rule
    unlines
    [
     "/********************   " ++ fun ++ "    ********************/",
     render $ prConstructorC user fun vs cats,
     prCopyC user fun vs,
     prDestructorC user fun vs,
     prAcceptC fun,
     prCloneC user fun vs,
     ""
    ]
   where
     vs = getVars cats
     c' = identCat (normCat c)

--These are all built-in list functions.
--Later we could include things like lookup,insert,delete,etc.
prListFuncs :: [UserDef] -> String -> String
prListFuncs user c = unlines
 [
  c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)",
  "{",
  "  " ++ m' ++ " = p;",
  "  " ++ v ++ "= 0;",
  "}",
  c ++ "*" +++ c ++ "::" ++ "reverse()",
  "{",
  "  if (" ++ v +++ "== 0) return this;",
  "  else",
  "  {",
  "    " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);",
  "    " ++ v +++ "= 0;",
  "    return tmp;",
  "  }",
  "}",
  "",
  c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)",
  "{",
  "  if (" ++ v +++ "== 0)",
  "  {",
  "    " ++ v +++ "= prev;",
  "    return this;",
  "  }",
  "  else",
  "  {",
  "    " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);",
  "    " ++ v +++ "= prev;",
  "    return tmp;",
  "  }",
  "}"
 ]
 where
   v = map toLower c ++ "_"
   m = drop 4 c
   mstar = if isBasic user m then "" else "*"
   m' = drop 4 v

--The standard accept function for the Visitor pattern
prAcceptC :: String -> String
prAcceptC ty =
  "\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }"

-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
-- >>> prConstructorC ["Integer"] "bla" [("A",1), ("Integer",1), ("A",2)] [Cat "A", Cat "Integer", Cat "A"]
-- bla::bla(A *p1, Integer p2, A *p3) { a_1 = p1; integer_ = p2; a_2 = p3; }
prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> Doc
prConstructorC user c vs cats =
    text c <> "::" <> text c <> parens args
    <+> "{" <+> text (prAssigns vs params) <> "}"
  where
    (types, params) = unzip (prParams cats (length cats) (length cats+1))
    args = hsep $ punctuate "," $ zipWith prArg types params
    prArg type_ name
      | isBasic user type_  = text type_ <+> text name
      | otherwise           = text type_ <+> "*" <> text name

--Print copy constructor and copy assignment
prCopyC :: [UserDef] -> String -> [IVar] -> String
prCopyC user c vs =
    c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" +++
      concatMap doV vs ++++
      "}" ++++
      c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" ++++
      "  " ++ c +++ "tmp(other);" ++++
      "  swap(tmp);" ++++
      "  return *this;" ++++
      "}" ++++
      "void" +++ c ++ "::swap(" ++ c +++ "& other) {" ++++
      concatMap swapV vs ++++
      "}\n"
    where  doV :: IVar -> String
           doV v@(t, _)
             | isBasic user t = "  " ++ vn v ++ " = other." ++ vn v ++ ";\n"
             | otherwise = "  " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n"
           vn :: IVar -> String
           vn (t, 0) = varName t
           vn (t, n) = varName t ++ show n
           swapV :: IVar -> String
           swapV v = "  std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n"

--The cloner makes a new deep copy of the object
prCloneC :: [UserDef] -> String -> [IVar] -> String
prCloneC _ c _ =
  c +++ "*" ++ c ++ "::clone() const {" ++++
    "  return new" +++ c ++ "(*this);\n}"

--The destructor deletes all a class's members.
prDestructorC :: [UserDef] -> String -> [IVar] -> String
prDestructorC user c vs  =
    c ++ "::~" ++ c ++"()" +++ "{" +++
    concatMap prDeletes vs ++ "}"
  where
    prDeletes :: (String, Int) -> String
    prDeletes (t, n)
        | isBasic user t = ""
        | n == 0 = "delete(" ++ varName t ++ "); "
        | otherwise = "delete(" ++ varName t ++ show n ++ "); "

--Prints the constructor's parameters.
prParams :: [Cat] -> Int -> Int -> [(String,String)]
prParams [] _ _ = []
prParams (c:cs) n m = (identCat c, "p" ++ show (m-n))
                    : prParams cs (n-1) m

--Prints the assignments of parameters to instance variables.
--This algorithm peeks ahead in the list so we don't use map or fold
prAssigns :: [IVar] -> [String] -> String
prAssigns [] _ = []
prAssigns _ [] = []
prAssigns ((t,n):vs) (p:ps) =
 if n == 1 then
  case findIndices (\(l,_) -> l == t) vs of
    [] -> varName t +++ "=" +++ p ++ ";" +++ prAssigns vs ps
    _ -> varName t ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps
 else varName t ++ showNum n +++ "=" +++ p ++ ";" +++ prAssigns vs ps


{- **** Helper Functions **** -}

-- | Checks if something is a basic or user-defined type.
isBasic :: [UserDef] -> String -> Bool
isBasic user x = x `elem` user || x `elem` specialCatsP