--
-- 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 EmptyDataDecls, TypeFamilies #-}

module Feldspar.Compiler.Plugins.Precompilation where

import Feldspar.Compiler.PluginArchitecture
import qualified Feldspar.Core.Expr as Expr
import Feldspar.Core.Types

import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler
import Feldspar.Compiler.Error

import System.IO.Unsafe

-- ===========================================================================
--  == Precompilation plugin
-- ===========================================================================

data CompilationMode = Interactive | Standalone
    deriving (Show, Eq)

data SignatureInformation = SignatureInformation {
    originalFeldsparFunctionName      :: String,
    generatedImperativeParameterNames :: [String],
    originalFeldsparParameterNames    :: Maybe [Maybe String]
} deriving (Show, Eq)

instance Default SignatureInformation where defaultValue = precompilationError InternalError "Default value should not be used"

precompilationError = handleError "PluginArch/Precompilation"

data PrecompilationSemanticInfo

instance SemanticInfo PrecompilationSemanticInfo where
    type ProcedureInfo             PrecompilationSemanticInfo = SignatureInformation
    type BlockInfo                 PrecompilationSemanticInfo = ()
    type ProgramInfo               PrecompilationSemanticInfo = ()
    type EmptyInfo                 PrecompilationSemanticInfo = ()
    type PrimitiveInfo             PrecompilationSemanticInfo = ()
    type SequenceInfo              PrecompilationSemanticInfo = ()
    type BranchInfo                PrecompilationSemanticInfo = ()
    type SequentialLoopInfo        PrecompilationSemanticInfo = ()
    type ParallelLoopInfo          PrecompilationSemanticInfo = ()
    type FormalParameterInfo       PrecompilationSemanticInfo = ()
    type LocalDeclarationInfo      PrecompilationSemanticInfo = ()
    type ExpressionInfo            PrecompilationSemanticInfo = ()
    type ConstantInfo              PrecompilationSemanticInfo = ()
    type FunctionCallInfo          PrecompilationSemanticInfo = ()
    type LeftValueInfo             PrecompilationSemanticInfo = ()
    type ArrayElemReferenceInfo    PrecompilationSemanticInfo = ()
    type InstructionInfo           PrecompilationSemanticInfo = ()
    type AssignmentInfo            PrecompilationSemanticInfo = ()
    type ProcedureCallInfo         PrecompilationSemanticInfo = ()
    type ActualParameterInfo       PrecompilationSemanticInfo = ()
    type IntConstantInfo           PrecompilationSemanticInfo = ()
    type FloatConstantInfo         PrecompilationSemanticInfo = ()
    type BoolConstantInfo          PrecompilationSemanticInfo = ()
    type ArrayConstantInfo         PrecompilationSemanticInfo = ()
    type VariableInfo              PrecompilationSemanticInfo = SignatureInformation

data Precompilation = Precompilation

instance TransformationPhase Precompilation where
    type From Precompilation = ()
    type To Precompilation = ()
    type Downwards Precompilation = SignatureInformation
    type Upwards Precompilation = ()
    downwardsProcedure Precompilation fromAbove procedure = fromAbove {
        generatedImperativeParameterNames =
            map (variableName . formalParameterVariable) (inParameters procedure)
    }
    transformProcedure Precompilation fromAbove originalProcedure fromBelow =
        Procedure { -- NOTE: fromAbove won't have the generated imperative parameter names right here
            procedureName = originalFeldsparFunctionName fromAbove,
            inParameters  = recursivelyTransformedInParameters fromBelow,
            outParameters = recursivelyTransformedOutParameters fromBelow,
            procedureBody = recursivelyTransformedProcedureBody fromBelow,
            procedureSemInf = ()
        }
    transformVariable = myTransformVariable
    transformVariableLeftValueInLeftValue = myTransformVariableLeftValueInLeftValue

getVariableName :: SignatureInformation -> String -> String
getVariableName signatureInformation origname = case (originalFeldsparParameterNames signatureInformation) of
    Just originalParameterNameList ->
        if length (generatedImperativeParameterNames signatureInformation) == length originalParameterNameList then
            case searchResults of
                [] -> origname
                otherwise -> case snd $ head $ searchResults of
                                Just newname -> newname
                                Nothing -> origname
        else
            precompilationError InternalError $ "parameter name list length mismatch:" ++
                    show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameList
        where
            searchResults = (filter (((==) origname).fst) (zip (generatedImperativeParameterNames signatureInformation) originalParameterNameList))
    Nothing -> origname

myTransformVariable :: Precompilation -> SignatureInformation -> Variable () -> Variable ()
myTransformVariable Precompilation fromAbove v = v {
    variableName = getVariableName fromAbove (variableName v),
    variableSemInf = ()
}

myTransformVariableLeftValueInLeftValue :: Precompilation -> SignatureInformation -> Variable () -> LeftValueData ()
myTransformVariableLeftValueInLeftValue Precompilation fromAbove v = VariableLeftValue $ myTransformVariable Precompilation fromAbove v

data PrecompilationExternalInfo = PrecompilationExternalInfo {
    originalFeldsparFunctionSignature :: Precompiler.OriginalFeldsparFunctionSignature, 
    graphInputInterfaceType :: Tuple StorableType,
    numberOfFunctionArguments :: Int,
    compilationMode :: CompilationMode
}

countTuple :: Tuple a -> Int
countTuple (One x) = 1
countTuple (Tup list) = sum (map countTuple list)

addPostfixNumbersToMaybeList :: [Maybe String] -> [Maybe String]
addPostfixNumbersToMaybeList list
    | length list > 1 = map addPostfixNumberToMaybeString (zip list [1..]) -- postfix numbers only needed for lists with length > 1
    | otherwise = list

addPostfixNumberToMaybeString :: (Maybe String, Int) -> Maybe String
addPostfixNumberToMaybeString (ms, num) = case ms of
    Just s -> Just $ s ++ (show num)
    Nothing -> Nothing
    
inflate :: Int -> [Maybe String] -> [Maybe String]
inflate target list | length list < target = inflate target (list++[Nothing])
                    | length list == target = list
                    | otherwise = precompilationError InternalError "Unexpected situation in 'inflate'"
    
-- Applies some tweaks the original parameter name list based on the graph's input interface type signature
parameterNameListConsolidator :: PrecompilationExternalInfo -> [Maybe String]
parameterNameListConsolidator externalInfo = case graphInputInterfaceType externalInfo of
    One x -> Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo
    tuple@(Tup list) -> case numberOfFunctionArguments externalInfo of
        0 -> precompilationError InternalError "parameter name list consolidator function shouldn't be called when numArgs==0"
        1 -> addPostfixNumbersToMaybeList $ replicate (countTuple tuple)
                 (head $ Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)
        otherwise -> concat $ map (\(cnt,name)->addPostfixNumbersToMaybeList (replicate cnt name)) 
           (zip (map countTuple list) (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo))

instance Plugin Precompilation where
    type ExternalInfo Precompilation = PrecompilationExternalInfo
    executePlugin Precompilation externalInfo procedure = fst
        $ executeTransformationPhase Precompilation (SignatureInformation {
            originalFeldsparFunctionName = Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo,
            generatedImperativeParameterNames = precompilationError InternalError "GIPN should have been overwritten", 
            originalFeldsparParameterNames = if numberOfFunctionArguments externalInfo == 0
                then
                    Nothing -- if there are no arguments, disable parameter name handling (needed because of the dummy var0)
                else
                    (case compilationMode externalInfo of
                        Standalone ->
                            if -- ultimate check, should be enough...
                                numberOfFunctionArguments externalInfo ==
                                length (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)
                            then
                                Just $ parameterNameListConsolidator externalInfo
                            else
                                (unsafePerformIO $ do
                                    putStrLn $ "[WARNING @ PluginArch/Precompilation]: argument count mismatch in function " ++ 
                                          (Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo) ++
                                          ", inflating incomplete parameter name list..."
                                    putStrLn $ "numArgs: " ++ show (numberOfFunctionArguments externalInfo) ++ ", parameter list: " ++ 
                                        show (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) 
                                    return $ Just $ parameterNameListConsolidator (externalInfo {
                                        originalFeldsparFunctionSignature = (originalFeldsparFunctionSignature externalInfo) {
                                            Precompiler.originalFeldsparParameterNames = inflate (numberOfFunctionArguments externalInfo) $
                                                Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo
                                        }
                                    })
                                )
                        Interactive -> Nothing -- no parameter name handling in interactive mode
                    )
         }) procedure