{-
 - Copyright (c) 2009-2010, ERICSSON AB All rights reserved.
 - 
 - Redistribution and use in source and binary forms, with or without
 - modification, are permitted provided that the following conditions
 - are met:
 - 
 -     * Redistributions of source code must retain the above copyright
 -     notice,
 -       this list of conditions and the following disclaimer.
 -     * Redistributions in binary form must reproduce the above copyright
 -       notice, this list of conditions and the following disclaimer
 -       in the documentation and/or other materials provided with the
 -       distribution.
 -     * Neither the name of the ERICSSON AB nor the names of its
 -     contributors
 -       may be used to endorse or promote products derived from this
 -       software without specific prior written permission.
 - 
 - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 - HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 -}

{-# LANGUAGE FlexibleInstances #-}

module Feldspar.Compiler.Imperative.CodeGeneration where

import Feldspar.Compiler.Imperative.Representation
import Feldspar.Compiler.Imperative.Semantics
import Feldspar.Compiler.Error
import qualified Data.List as List (last)

------------------------
-- C code generation --
------------------------

codeGenerationError = handleError "CodeGeneration"

data Place =
      Declaration_pl
      --value of var,           need type,          type array-style
      --declare variables
    | MainParameter_pl
      --value of var            need type,          type pointer-style
      --main fun parameters
    | ValueNeed_pl
      --value of var,           not need type       -
      --in Expressions
    | AddressNeed_pl
      --access of var,          not need type       -
      --output of fun
    | FunctionCallIn_pl
      --value of var,           not need type       - SPEC ARRAY FORMAT
      --input of fun 
    deriving (Eq,Show)

compToC :: ToC a => a -> String
compToC = toC Declaration_pl

class ToC a where
    toC :: Place -> a -> String

instance ToC Size where
    toC _ S8 = "char"
    toC _ S16 = "short"
    toC _ S32 = "int"
    toC _ S64 = "long long"

instance ToC Signedness where
    toC _ ImpSigned = "signed"
    toC _ ImpUnsigned = "unsigned"

instance ToC Type where
    toC _ BoolType = "int"
    toC _ FloatType = "float"
    toC p (Numeric s t) = listprint id " " [toC p s, toC p t]
    --arraytype handled in variable

instance ToC (Variable PrettyPrintSemanticInfo) where
    toC p a@(Variable (VariableData r t n) _) = show_variable r p t n NoRestrict

show_variable :: VariableRole -> Place -> Type -> String -> IsRestrict -> String
show_variable r p t n restr = listprint (id) " " [variableType, show_name r p t n ++ arrLn] --concat [addSpace $ variableType, show_name r p t n, arrLn]
    where
        (variableType,arrLn) = show_type p t restr
        show_type :: Place -> Type -> IsRestrict -> (String,String)
        show_type MainParameter_pl (ImpArrayType s t@(ImpArrayType s2 t2)) restr = decl_matr_type s t2 s2 restr         
        show_type Declaration_pl (ImpArrayType s t) restr = decl_arr_type t s ("","") 
        show_type MainParameter_pl (ImpArrayType s t) restr = decl_arr_type_0 t s restr
        show_type Declaration_pl t _ = (toC p t,"")
        show_type MainParameter_pl t _ = (toC p t,"")
        show_type _ _ _ = ("","")
        
        decl_arr_type_0 :: Type -> Length -> IsRestrict -> (String,String)
        decl_arr_type_0 t s Restrict = ((toC Declaration_pl t) ++ " * const restrict",  "") 
        decl_arr_type_0 t s _        = ((toC Declaration_pl t) ++ " *",  "")
        
        decl_matr_type :: Length -> Type -> Length -> IsRestrict -> (String,String)
        decl_matr_type mb t2 s2 Restrict = decl_arr_type t2 s2 (" (* const restrict", ")")       
        decl_matr_type mb t2 s2 _ = decl_arr_type t2 s2 (" (*", ")")
        
        decl_arr_type :: Type -> Length -> (String,String) -> (String,String)
        decl_arr_type (ImpArrayType s2 t2) mb (st1,st2) = decl_arr_type t2 s2 (st1,st2 ++ (show_brackets mb))
        decl_arr_type t mb (st1,st2) =  ((toC Declaration_pl t) ++ st1,  st2 ++ show_brackets mb)
        
        show_brackets :: Length -> String
        show_brackets Undefined = codeGenerationError InternalError $ "Unattended unknown array size"
        show_brackets (Norm i) = concat["[",show i,"]"]
        show_brackets (Defined i)  = concat["[", show i, defaultArraySizeWarning, "]"]
        
        defaultArraySizeWarning :: String
        defaultArraySizeWarning  = " /* WARNING: Default size used!! */"

        show_name :: VariableRole -> Place-> Type -> String  -> String
        show_name _ FunctionCallIn_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"]
        show_name _ AddressNeed_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"]
        show_name _ _ (ImpArrayType _ _) n = n
        show_name Value place t n 
            | place == AddressNeed_pl = "&" ++ n
            | otherwise = n
        show_name FunOut place t n
            | place == AddressNeed_pl = n
            | place == Declaration_pl = codeGenerationError InternalError $ "You can't declare output variable of the function"
            | place == MainParameter_pl = "* " ++ n
            | List.last n == ']' = n
            | otherwise = "(* " ++ n ++ ")"
        
        genIndex :: Type -> String
        genIndex (ImpArrayType _ t) = "[0]" ++ genIndex t
        genIndex _ = ""

instance ToC (Constant PrettyPrintSemanticInfo) where
    toC _ (IntConstant i) = show (intConstantValue i)
    toC _ (FloatConstant i) = show (floatConstantValue i) ++ "f"
    toC _ (BoolConstant (BoolConstantType True _)) = "1"
    toC _ (BoolConstant (BoolConstantType False _)) = "0"
    toC p a@(ArrayConstant l) = "{" ++ (toCArray p a) ++ "}"

toCArray :: Place -> Constant PrettyPrintSemanticInfo -> String
toCArray p (ArrayConstant l) = listprint (toCArray p) "," (arrayConstantValue l)
toCArray p i = toC p i

instance ToC (LeftValue PrettyPrintSemanticInfo) where
    toC p (VariableLeftValue (VariableInLeftValue v _)) = toC p v
    toC p (ArrayElemReferenceLeftValue leftArrayElemReference) = toC p $ insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference) where
        insertIndex :: LeftValue PrettyPrintSemanticInfo -> LeftValue PrettyPrintSemanticInfo
        insertIndex (VariableLeftValue (VariableInLeftValue variable semInf)) = VariableLeftValue $ VariableInLeftValue 
            (variable {
                variableData = (variableData variable) {
                    variableType = decrArrayDepth (variableType $ variableData variable),
                    variableName = (concat[variableName $ variableData variable,"[",
                                           toC ValueNeed_pl (arrayIndex $ arrayElemReferenceData leftArrayElemReference), "]"])
                }
            }) semInf
        insertIndex (ArrayElemReferenceLeftValue leftArrayElemReference) =
            ArrayElemReferenceLeftValue $ leftArrayElemReference {
                arrayElemReferenceData = ArrayElemReferenceData (insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference))
                                                                (arrayIndex $ arrayElemReferenceData leftArrayElemReference)
            }
            
instance ToC (ActualParameter PrettyPrintSemanticInfo) where
    toC p (InputActualParameter (InputActualParameterType e _)) = toC FunctionCallIn_pl e
    toC p (OutputActualParameter (OutputActualParameterType l _)) = toC AddressNeed_pl l

instance ToC (Expression PrettyPrintSemanticInfo) where
    toC p (LeftValueExpression (LeftValueInExpression lv _)) = toC p lv
    toC p (ConstantExpression c) = toC p c
    toC p (FunctionCallExpression (FunctionCall (FunctionCallData InfixOp _ f [a,b]) _)) = concat["(",toC p a," ",f," ",toC p b,")"]
    toC p (FunctionCallExpression (FunctionCall (FunctionCallData _ t f x) _)) = concat [f,"(",listprint (toC p) ", " x,")"]

instance ToC (Procedure PrettyPrintSemanticInfo) where
    toC p (Procedure n il ol pr semInf) = concat ["void ",n,"(",param,")\n{\n",prog,"}\n"]
        where
            param = listprint (toC MainParameter_pl) ", " (il ++ ol)
            prog = ind (toC Declaration_pl) pr

instance ToC (Block PrettyPrintSemanticInfo) where
    toC p (Block (BlockData d pr) semInf) = listprint id "\n" [decl,toC p pr]
        where
            decl = concat $ map (\a->toC Declaration_pl a ++ ";\n") d

instance ToC (FormalParameter PrettyPrintSemanticInfo) where
    toC p (FormalParameter v restr) = (helper p v restr) 
        where
            helper :: Place -> Variable PrettyPrintSemanticInfo -> IsRestrict -> String
            helper MainParameter_pl (Variable (VariableData r t n) _) restr 
                    = show_variable r MainParameter_pl t n restr 
            helper _                (Variable (VariableData r t n) _) restr 
                    = show_variable r Declaration_pl t n restr

instance ToC (LocalDeclaration PrettyPrintSemanticInfo) where
    toC p (LocalDeclaration (LocalDeclarationData v i) isDefArrSize) = (helper p v i) 
        where
            helper :: Place -> Variable PrettyPrintSemanticInfo -> (Maybe (Expression PrettyPrintSemanticInfo)) -> String
            helper MainParameter_pl v i = concat [toC MainParameter_pl v,init i]
            helper _            v i = concat [toC Declaration_pl v,init i]
            init :: Maybe (Expression PrettyPrintSemanticInfo) -> String
            init Nothing = ""
            init (Just e) = " = " ++ toC ValueNeed_pl e

instance ToC (Instruction PrettyPrintSemanticInfo) where
    toC p (AssignmentInstruction assignment) =
        concat [toC ValueNeed_pl (assignmentLhs $ assignmentData assignment)," = ",toC ValueNeed_pl (assignmentRhs $ assignmentData assignment),";\n"]
    toC p (ProcedureCallInstruction procedureCall) =
        concat [nameOfProcedureToCall $ procedureCallData procedureCall,"(",
                listprint (toC p) ", " (actualParametersOfProcedureToCall $ procedureCallData procedureCall),");\n"]
        -- TODO ProcedureCall.actualParameters procedureCall -----> External helper functions !!!
        
instance ToC (Program PrettyPrintSemanticInfo) where
    toC p (Program (EmptyProgram (Empty i)) seminf) = ""
    toC p (Program (PrimitiveProgram (Primitive i seminf)) psi) = toC p i
    toC p (Program (SequenceProgram (Sequence ps _)) psi) = listprint (toC p) "" ps
    toC p (Program (BranchProgram (Branch (BranchData con tPrg ePrg) _)) psi)
        = concat ["if(",toC ValueNeed_pl con,")\n{\n", ind (toC p) tPrg,"}\nelse\n{\n",ind (toC p) ePrg,"}\n"]
    toC p (Program (SequentialLoopProgram (SequentialLoop (SequentialLoopData condVar condCalc loopBody) _)) psi) = concat["{\n",ind id whereBody,"}\n"] 
        where
            whereBody = concat [toC p condCalc,"while(",toC ValueNeed_pl condVar,")\n",
                                "{\n",ind (toC p) loopBody,ind (toC p) (blockInstructions $ blockData condCalc),"}\n"]
    toC p (Program (ParallelLoopProgram (ParallelLoop (ParallelLoopData v num step prg) _)) psi) = concat ["{\n",ind id for_seq,"}\n"]
        where
            for_seq = concat [toC Declaration_pl v,";\nfor(",for_init,for_test,for_inc,")\n{\n",ind (toC p) prg,"}\n"]
            for_init = concat [toC ValueNeed_pl v," = 0; "]
            for_test = concat [toC ValueNeed_pl v," < ",toC ValueNeed_pl num,"; "]
            for_inc = concat [toC ValueNeed_pl v," += ",show step]

instance ToC a => ToC (Maybe a) where
     toC p Nothing = ""
     toC p (Just a) = toC p a

instance (ToC a) => ToC [a] where
    toC p xs = listprint (toC p) "\n" xs

----------------------
--   Type           --
----------------------

class HasType a where
    typeof :: a -> Type

instance (SemanticInfo t) => HasType (Variable t) where
    typeof (Variable (VariableData r t s) _) = t

instance (SemanticInfo t) => HasType (LeftValue t) where
    typeof (VariableLeftValue (VariableInLeftValue v _)) = typeof v
    typeof (ArrayElemReferenceLeftValue arrayElemReference) =
        decrArrayDepth (typeof (arrayName $ arrayElemReferenceData arrayElemReference))

instance (SemanticInfo t) => HasType (Constant t) where
    typeof (IntConstant _) = Numeric ImpSigned S32
    typeof (FloatConstant _) = FloatType
    typeof (BoolConstant _) = BoolType
    typeof arr@(ArrayConstant l) = ImpArrayType (Norm $ length innerConstList) elemtype
        where
            elemtype = case innerConstList of
                []  -> codeGenerationError InternalError $ "Const array with 0 elements: " ++ show arr
                _   -> checktype (typeof $ head innerConstList) (map typeof innerConstList)
            innerConstList = arrayConstantValue l
            checktype :: Type -> [Type] -> Type
            checktype t [] = t
            checktype t (x:xs)
                | t == x = checktype t xs
                | otherwise = codeGenerationError InternalError $ "Different element types in constant array: " ++ show arr

instance (SemanticInfo t) => HasType (Expression t) where
    typeof (LeftValueExpression lve) = typeof $ leftValueExpressionContents lve
    typeof (ConstantExpression c) = typeof c
    typeof (FunctionCallExpression functionCallExpression) = typeOfFunctionToCall $ functionCallData functionCallExpression

instance (SemanticInfo t) => HasType (ActualParameter t) where
    typeof (InputActualParameter (InputActualParameterType e _)) = typeof e
    typeof (OutputActualParameter (OutputActualParameterType l _)) = typeof l

----------------------
-- Helper functions --
----------------------

ind :: (a-> String) -> a -> String
ind f x = unlines $ map (\a -> "    " ++ a) $ lines $ f x

listprint :: (a->String) -> String -> [a] -> String
listprint f s xs = listprint' s $ filter (\a -> a /= "")$ map f xs where
    listprint' _ [] = ""
    listprint' _ [x] = x
    listprint' s (x:y:xs) = x ++ s ++ listprint' s (y:xs)

parameterToExpression :: (SemanticInfo t) => ActualParameter t -> Expression t
parameterToExpression (InputActualParameter (InputActualParameterType e _)) = e
parameterToExpression (OutputActualParameter (OutputActualParameterType lv _)) =
    LeftValueExpression $ LeftValueInExpression lv undefined -- TODO undefined

decrArrayDepth :: Type -> Type
decrArrayDepth (ImpArrayType _ t) = t
decrArrayDepth _ = codeGenerationError InternalError $ "A variable is indexed, but not array!"

simpleType :: Type -> Bool
simpleType BoolType = True
simpleType (Numeric _ _) = True
simpleType FloatType = True
simpleType (ImpArrayType _ _) = False

toLeftValue :: (SemanticInfo t) => Expression t -> LeftValue t
toLeftValue (LeftValueExpression (LeftValueInExpression lv _)) = lv
toLeftValue e = codeGenerationError InternalError $ show e ++ " is not a left value."

contains :: (SemanticInfo t) => String -> Expression t -> Bool
contains n (LeftValueExpression (LeftValueInExpression lv _)) = contains' n lv where
    contains' n (VariableLeftValue 
                    (VariableInLeftValue (Variable (VariableData _ _ n' ) _) _)
                ) = n == n'
    contains' n (ArrayElemReferenceLeftValue arrayElemReference) = contains' n (arrayName $ arrayElemReferenceData arrayElemReference) ||
                                                                   contains n (arrayIndex $ arrayElemReferenceData arrayElemReference)
contains _ (ConstantExpression _) = False
contains n (FunctionCallExpression functionCallExpression) =
    any (contains n) (actualParametersOfFunctionToCall $ functionCallData functionCallExpression)

getVarName :: (SemanticInfo t) => LeftValue t -> String
getVarName (VariableLeftValue (VariableInLeftValue ( Variable (VariableData _ _ n) _ ) _ )) = n
getVarName (ArrayElemReferenceLeftValue arrayElemReference) = getVarName (arrayName $ arrayElemReferenceData arrayElemReference)