{-
    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
    }