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

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- 
   **************************************************************
    BNF Converter Module

    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 (pellauer@cs.chalmers.se)

    License       : GPL (GNU General Public License)

    Created       : 4 August, 2003                           

    Modified      : 22 May, 2004 / Antti-Juhani Kaijanaho

   
   ************************************************************** 
-}

module CFtoCPPAbs (cf2CPPAbs) where

import CF
import Utils((+++),(++++))
import NamedVariables
import Data.List
import Data.Char(toLower)


--The result is two files (.H file, .C file)
cf2CPPAbs :: String -> CF -> (String, String)
cf2CPPAbs name 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) (cf2dataLists cf),
  "",
  "#endif"
 ]
 where
  user = fst (unzip (tokenPragmas cf))
  header = "//C++ Abstract Syntax Interface generated by the BNF Converter.\n"
  rules = getRules cf
  classes = rules ++ (getClasses (allCats cf))
  prForward s | isProperLabel s = "class " ++ (normCat s) ++ ";\n"
  prForward s = ""
  getRules cf = (map testRule (rulesOfCF cf))
  getClasses [] = []
  getClasses (c:cs) = 
   if identCat (normCat c) /= c 
   then getClasses cs
   else if elem c rules
     then getClasses cs
     else c : (getClasses cs)
  
  testRule (Rule f c r) = 
   if isList c
   then if isConsFun f 
     then identCat c
     else "_" --ignore this
   else f

--Prints interface classes for all categories.
prDataH :: [UserDef] -> Data -> String
prDataH  user (cat, rules) = 
  case lookup cat rules of
    Just x -> 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] -> String -> (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:",
     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:",
     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
     fun' = identCat (normCat fun)
     c' = identCat (normCat c);
     mem = drop 4 c'
     memstar = if isBasic user mem then "" else "*"
     super = if 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"
    where
       f' = identCat (normCat f)
   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 :: [UserDef] -> [IVar] -> String
prInstVars _ [] = []
prInstVars user vars@((t,n):vs) = 
  "  " ++ t +++ uniques ++ ";" ++++
  (prInstVars user vs')
 where
   (uniques, vs') = prUniques t vars
   --these functions group the types together nicely
   prUniques :: String -> [IVar] -> (String, [IVar])
   prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) ->  y == t) vs) vs, remType t vs)
   prVars (x:[]) vs =  case vs !! x of
   			(t,n) -> ((varLinkName t) ++ (showNum n))
   prVars (x:xs) vs = case vs !! x of 
   			(t,n) -> ((varLinkName t) ++ (showNum n)) ++ "," +++
				 (prVars xs vs)
   varLinkName z = if isBasic user z
     then (map toLower z) ++ "_"
     else "*" ++ (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) (cf2dataLists 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' ++ "    ********************/",
     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' ++ "    ********************/",
     prConstructorC user fun' vs cats,
     prCopyC user fun' vs,
     prDestructorC user fun' vs,
     prAcceptC fun,
     prCloneC user fun' vs,
     ""
    ]
   where 
     vs = getVars cats
     fun' = identCat (normCat fun)
     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 :: [UserDef] -> String -> [IVar] -> [Cat] -> String
prConstructorC user c vs cats = 
  c ++ "::" ++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ 
   prAssigns vs params ++ "}"
  where
   (types, params) = unzip (prParams cats (length cats) ((length cats)+1))
   interleave _ [] = []
   interleave (x:[]) (y:[]) = x +++ (optstar x) ++ y
   interleave (x:xs) (y:ys) = x +++ (optstar x) ++ y ++ "," +++ (interleave xs ys)
   optstar x = if isBasic user x
       then ""
       else "*"

--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 user c vs =
  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) = if isBasic user t
    then ""
    else if n == 0
     then "delete(" ++ (varName t) ++ "); "
     else "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 (\x -> case x of (l,r) -> l == t) vs of
    [] -> (varName t) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)
    z -> ((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 = 
  if elem x user
    then True
    else case x of
      "Integer" -> True
      "Char" -> True
      "String" -> True
      "Double" -> True
      "Ident" -> True
      _ -> False