{-
	This is the translator from the ASTCG to C source code, 
	every other translator should follow this template.
	Since we have four AST specific data types, the translator must provide the following
	four functions:
	
	translateField, translateNode, translateKind and translateProgram
	
	Since we're writing files, their type should be:
	translateField :: ASTField -> Flag -> IO ()
	
	Where Flag is a custom type, the only restriction made here is that Flag should provide
	a default value (Except for a ASTProgram, it must be ASTProgram -> IO()).
	
    Copyright (C) 2012 Victor Cacciari Miraldo

    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 3 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, see <http://www.gnu.org/licenses/>.
-}
module AST_C_Target where

import AST
import Char

data Flag = Decl | Imp | ParmDecl

flagDefault :: Flag
flagDefault =  Decl

ident :: IO ()
ident = putStr "\t"

identn :: Int -> IO()
identn 1 = ident
identn (n+1) = do {ident; identn n}

{-
	A "field" in C is simply a declaration of a variable.
-}
translateField :: ASTField -> Flag -> IO ()
translateField (ASTField _ n) Imp =
	do { putStr (n ++ " = " ++ n ++ ";\n") }
translateField (ASTField t n) ParmDecl = 
	do { putStr (t ++ " " ++ n) }
translateField (ASTField t n) Decl = 
	do { putStr (t ++ " " ++ n ++ ";") }
	
{-
	Now, a kind is somewhat more complex. It is different if we're inside the declaration module,
	the implementation or declaring a parameter.
-}
translateKind :: ASTKind -> Flag -> IO()
translateKind (ASTAtomKind f) Decl =
	do { identn 2; translateField f Decl; putChar '\n' }
translateKind (ASTAtomKind f) ParmDecl =
	do { translateField f ParmDecl }
translateKind (ASTAtomKind (ASTField _ n)) Imp =
	do { ident; putStrLn ("__a->u." ++ n ++ " = " ++ n ++ ";") }

{-
	We have some more complicated cases here:
	For the following functions, we will ilustrate the output of the following kind:
	
	ASTKind "binop" [(ASTField "int" "op"), (ASTField "tree*" "lh"), (ASTField "tree*" "rh")]
	
	If it's a declaration, it should be:
	
		struct {
			int op;
			tree* lh;
			tree* rh;
		} binop;
-}
translateKind (ASTKind n fields) Decl =
	do 
	{  	identn 2
	;	putStr "struct {\n"
	;	foldr (\h r -> do { identn 3; translateField h Decl; putChar '\n'; r }) (identn 2) fields
	;	putStr ("} " ++ n ++ ";\n")
	}

{-
	If we're inside a initializer:
	
	__a->u.binop.op = op;
	__a->u.binop.lh = lh;
	__a->u.binop.rh = rh;
-}
translateKind (ASTKind n fields) Imp =
	do
	{	foldr
		(\h r ->
			do
			{	ident
			;	putStr ("__a->u." ++ n ++ ".")
			;	translateField h Imp
			;	r
			}
		) (return ()) fields
	}
								
{-
	And if we're dealing with a parameter declaration:
	
	int op, tree* lh, tree* rh
-}
translateKind (ASTKind _ fields) ParmDecl =
	translateParmFieldList fields

translateParmFieldList :: [ASTField] -> IO ()
translateParmFieldList fields =
	do
	{	case pushLast fields of
			(l:tt) ->
				foldr
				(\h r ->
					do
					{	translateField h ParmDecl
					;	putStr ", "
					;	r
					}
				) (translateField l ParmDecl) tt
			[] -> return ()
	}
	where
		pushLast [] = []
		pushLast [x] = [x]
		pushLast [x,y] = [y,x]
		pushLast (h:t) = let (k:ks) = pushLast t in k:h:ks
		
{-
	Ok, we're finally in the node part, this is not hard. Let's consider the following
	node to illustrate our functions:
		
		ASTNode "Exp" [(ASTField "int" "line")] kindlist
		
	This, in the declaration should become:
	
	struct Exp_st {
		enum ExpKind_t kind;
		int line;
		translate(kindlist)
	};
-}

-- Just a simple auxiliar to handle the function prototype name.
translateNodeFuncPrototype :: ASTNode -> ASTKind -> IO ()
translateNodeFuncPrototype (ASTNode name fields kinds) k =
	do
	{	putStr (name ++ "*\t")
	;	putStr ((map toLower name) ++ "_" ++ (kindName k) ++ "_new(")
	;	translateParmFieldList (fields ++ (kindFields k))
	;	putChar ')'
	}

translateNode :: ASTNode -> Flag -> IO ()
translateNode node@(ASTNode name fields []) Decl =
	do
	{	putStr ("struct " ++ name ++ "_st {\n")	
	;	foldr (\h r -> do { ident ; translateField h Decl; putChar '\n'; r }) (return ()) fields
	;	putStr "};\n\n\n"
	;	putStr (name ++ "*\t")
	;	putStr ((map toLower name) ++ "_new(")
	;	translateParmFieldList fields
	;	putStr ");\n"
	}

translateNode node@(ASTNode name fields kinds) Decl =
	do
	{	putStr ("struct " ++ name ++ "_st {\n")
	;	putStr ("\tenum " ++ name ++ "Kind_t kind;\n")
	;	foldr (\h r -> do { ident ; translateField h Decl; putChar '\n'; r }) (return ()) fields			
	;	putStr "\tunion {\n"
	;	foldr (\h r -> do { translateKind h Decl; r }) (return ()) kinds
	;	putStr "\t} u;\n"
	; 	putStr "};\n\n\n"
	{-
	Cool, we're almost there.
	Now, we need the whole function declaration
	We want something like:

		Exp*	exp_binop_new(int line, int binop, tree* lh, tree* rh);

	For each different kind!
	-}
	;	foldr (\k r ->
				do
				{	translateNodeFuncPrototype node k
				;	putStr ";\n"
				;	r
				}
		) (return ()) kinds
	;	putStr "\n\n"
	}
	
{-
	Now we are going to actually implement every function, this is the
	time consuming task.
-}
translateNode node@(ASTNode name fields []) Imp =
	do
	{	putStr (name ++ "*\t")
	;	putStr ((map toLower name) ++ "_new(")
	;	translateParmFieldList fields
	;	putStr ")\n{\n"
	;	putStr (name ++ "* __a = ALLOC(" ++ name ++ ");\n\n")
	;	foldr (\f r -> do { putStr "\t__a->"; translateField f Imp; r }) (return ()) fields
	;	putStr "\n\treturn __a;\n}\n\n"
	}
	
translateNode node@(ASTNode name fields kinds) Imp =
	foldr (\k r ->
		do
		{	translateNodeFuncPrototype node k
		;	putStr "\n{\n"
		;	putStr (name ++ "* __a = ALLOC(" ++ name ++ ");\n\n")
		;	putStr ("\t__a->kind = " ++ (map toUpper (name ++ "_" ++ (kindName k))) ++ ";\n")
		;	foldr (\f r -> do { putStr "\t__a->"; translateField f Imp; r }) (return ()) fields
		;	translateKind k Imp
		;	putStr "\n\treturn __a;\n}\n\n"
		;	r
		}
	) (return ()) kinds
	
{-
	Ok, now it comes the final part, how do we translate a program?
	Let's imagine the following program:
	
	ASTProgram  header footer [ExpNode]
		
	We want something like:
	
			header
	
			typedef struct Exp_st Exp;
	
			struct Exp_st
			{ ... }
	
			Exp* exp_ ...
			...
	
			footer
			
			implementations
-}
translateProgram :: ASTProgram -> IO ()
translateProgram (ASTProgram header footer nodes) =
	do
	{	putStr header
	;	foldr (\(ASTNode n _ _) r ->
				do { putStr ("typedef struct " ++ n ++ "_st " ++ n ++ ";\n"); r }
				) (return ()) nodes
	;	putStr "\n\n/* E N U M S */\n"
	;	foldr (\n r -> do { genEnum n ; r }) (return ()) nodes
	;	putStr "\n\n/* D E C L A R A T I O N S */\n\n"
	;	foldr (\h r -> do { translateNode h Decl ; r }) (return ()) nodes
	;	putStr "\n\n"
	;	putStr footer
	;	foldr (\h r -> do { translateNode h Imp ; r }) (return ()) nodes
	}
	
genEnum :: ASTNode -> IO ()
genEnum (ASTNode _ _ []) = return ()
genEnum (ASTNode name _ (kh:kinds)) =
	do
	{	putStr ("enum " ++ name ++ "Kind_t {\n")
	;	foldr (\k r -> 
			do { putStr ("\t" ++ (map toUpper (name ++ "_" ++ (kindName k))) ++ ",\n"); r}
		) (putStr ("\t" ++ (map toUpper (name ++ "_" ++ (kindName kh))) ++ "};\n")) kinds
	}