CompilerMain.hs

--
-- 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 CPP #-}
module Main where

import Feldspar.Compiler.Precompiler.Precompiler
import qualified Feldspar.Compiler.Compiler as CompilerCore
import qualified Feldspar.Compiler.Options as CoreOptions
import qualified Feldspar.Compiler.Standalone.Options as StandaloneOptions
import Feldspar.Compiler.Standalone.Constants
import Feldspar.Compiler.Standalone.Library as StandaloneLib

import System.Exit
import System.Environment
import System.IO
import System.Process
import System.Info
import System.Directory

import Control.Monad
import Control.Monad.Error
import Control.Monad.CatchIO
import Control.Exception

import Data.List
import System.Console.GetOpt
import System.Console.ANSI
import System.FilePath

import Language.Haskell.Interpreter

serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature =
    "(OriginalFeldsparFunctionSignature \"" ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++
        "\" " ++ (show $ originalFeldsparParameterNames originalFeldsparFunctionSignature) ++ ")"

generateCompileCode :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> String
generateCompileCode inputFileName outputFileName coreOptions originalFeldsparFunctionSignature =
    "standaloneCompile " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++
        " \"" ++ inputFileName ++ "\" " ++ " \"" ++ outputFileName ++ "\" " ++
        (serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature) ++
        " (Options " ++
        "{ platform = " ++ (CoreOptions.name $ CoreOptions.platform coreOptions) ++
        ", unroll = " ++ (show $ CoreOptions.unroll coreOptions) ++
        ", debug = " ++ (show $ CoreOptions.debug coreOptions) ++
        ", defaultArraySize = " ++ (show $ CoreOptions.defaultArraySize coreOptions) ++
        "})"

compileFunction :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> Interpreter ()
compileFunction inFileName outFileName options originalFeldsparFunctionSignature = do
    iPutStr $ StandaloneLib.rpadWith 50 '.' $
        "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature)
    --result <- catchError ( interpret (generateCompileCode outputFileName options functionName) (as::IO()) ) (\_->error "error")
    result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (as::IO())
    lift result
    liftIO $ withColor Green (putStrLn "[OK]")

compileAllFunctions :: String -> String -> CoreOptions.Options -> [OriginalFeldsparFunctionSignature] -> Interpreter ()
compileAllFunctions inFileName outFileName options [] = return()
compileAllFunctions inFileName outFileName options (x:xs) = do
    (catchError (compileFunction inFileName outFileName options x)
                (const $ liftIO $ withColor Red (putStrLn "[FAILED]")))
        `Control.Monad.CatchIO.catch`
        (\msg -> liftIO $ withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))
    compileAllFunctions inFileName outFileName options xs

buildIncludeString :: [String] -> String
buildIncludeString includes = concatMap (\x -> "#include " ++ x ++ "\n") includes

includeGeneration :: FilePath -> CoreOptions.Options -> IO ()
includeGeneration fileName coreOptions
   = appendFile fileName $ buildIncludeString (CoreOptions.includes $ CoreOptions.platform coreOptions)

-- | Interpreter body for single-function compilation
singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> Interpreter (IO ())
singleFunctionCompilationBody inFileName outFileName coreOptions originalFeldsparFunctionSignature = do
    iPutStrLn $ "Output file: " ++ outFileName
    iPutStrLn $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "..."
    liftIO $ includeGeneration outFileName coreOptions
    -- iPutStrLn $ generateCompileCode inFileName outFileName coreOptions originalFeldsparFunctionSignature
    result <- interpret (generateCompileCode inFileName outFileName coreOptions originalFeldsparFunctionSignature) (as::IO())
    return result

-- | Interpreter body for multi-function compilation
multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFeldsparFunctionSignature] -> Interpreter (IO ())
multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do
    iPutStrLn $ "Output file: " ++ outFileName
    liftIO $ includeGeneration outFileName coreOptions
    compileAllFunctions inFileName outFileName coreOptions declarationList
    return(return())

-- | A general interpreter body for interpreting an expression
generalInterpreterBody :: String -- ^ the expression to interpret
                       -> Interpreter (IO ())
generalInterpreterBody expression = do
    result <- interpret expression (as::IO())
    return result

-- | A high-level interface for calling the interpreter
highLevelInterpreter :: String -- ^ the module name (for example My.Module)
                     -> String -- ^ the input file name (for example "My/Module.hs")
                     -> Interpreter (IO ()) -- ^ an interpreter body
                     -> IO ()
highLevelInterpreter moduleName inputFileName interpreterBody = do
    actionToExecute <- runInterpreter $ do
        set [ languageExtensions := (glasgowExtensions ++
                [NoMonomorphismRestriction, OverlappingInstances, Rank2Types, UndecidableInstances]) ]
        iPutStrLn $ "Loading module " ++ moduleName ++ "..."
#ifdef RELEASE
        loadModules [inputFileName] -- globalImportList modules are package modules and shouldn't be loaded, only imported
#else
        loadModules $ [inputFileName] ++ globalImportList -- in normal mode, we need to load them before importing them
#endif
        setTopLevelModules [moduleName]
        setImports globalImportList
        interpreterBody
    either printInterpreterError id actionToExecute


printGhcError (GhcError {errMsg=s}) = putStrLn s

printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile []) = return()
printInterpreterError (WontCompile (x:xs)) = do
    printGhcError x
    printInterpreterError (WontCompile xs)
printInterpreterError e = putStrLn $ "Code generation failed: " ++ (show e)

-- | Calculates the output file name.
convertOutputFileName :: String -> Maybe String -> String
convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of
    Nothing -> takeFileName $ replaceExtension inputFileName ".c" -- remove takeFileName to return the full path
    Just overriddenFileName -> overriddenFileName

main = do
    args <- getArgs

    when (length args == 0) (do
        putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors
        exitWith ExitSuccess)

    -- Parse options, getting a list of option actions
    let (actions, nonOptions, errors) = getOpt Permute StandaloneOptions.optionDescriptors args

    when (length errors > 0) (do
        putStrLn $ concat errors
        putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors
        exitWith (ExitFailure 1))

    -- Here we thread startOptions through all supplied option actions
    opts <- foldl (>>=) (return StandaloneOptions.startOptions) actions

    when (length nonOptions /= 1) (do
        putStrLn "ERROR: Exactly one input file expected."
        exitWith (ExitFailure 1))

    let StandaloneOptions.Options {
                  StandaloneOptions.optSingleFunction = functionMode
                , StandaloneOptions.optOutputFileName = maybeOutputFileName
                , StandaloneOptions.optDotGeneration  = dotGeneration
                , StandaloneOptions.optDotFileName    = dotFileName
                , StandaloneOptions.optCompilerMode   = compilerMode } = opts
    let inputFileName = head nonOptions -- change it for multi-file operation
    let outputFileName = convertOutputFileName inputFileName maybeOutputFileName

    compilationCore functionMode inputFileName outputFileName opts dotGeneration dotFileName compilerMode

compilationCore functionMode inputFileName outputFileName commandLineOptions dotGeneration dotFileName compilerMode = do
    putStrLn $ "Starting the Standalone Feldspar Compiler..."
    -- -- -- Input file preparations -- -- --
    removeFile (replaceExtension inputFileName ".hi") `Prelude.catch` (const $ return())
    removeFile (replaceExtension inputFileName ".o" ) `Prelude.catch` (const $ return())
    -- -- -- Output file preparations -- -- --
    renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return())
    -- -- -- </prepare> -- -- --
    fileDescriptor <- openFile inputFileName ReadMode
    fileContents <- hGetContents fileDescriptor
    putStrLn $ "Parsing source file with the precompiler..."
    let declarationList = getExtendedDeclarationList fileContents
    let moduleName = getModuleName fileContents

    let highLevelInterpreterWithModuleInfo = highLevelInterpreter moduleName inputFileName

    -- Dot generation
    case commandLineOptions of
        StandaloneOptions.Options { StandaloneOptions.optDotGeneration = True} -> do
            putStrLn "Dot generation enabled"
            case functionMode of
                StandaloneOptions.SingleFunction funName -> case dotFileName of
                    Just fileName -> highLevelInterpreterWithModuleInfo
                                     (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ funName)
                    Nothing       -> highLevelInterpreterWithModuleInfo
                                     (generalInterpreterBody $ "putStr $ fs2dot " ++ funName)
                StandaloneOptions.MultiFunction ->
                    putStrLn $ "ERROR: Dot generation requested, but not supported in multi-function mode\n"++
                                            "(use the \"-f function\" option to enable single-function mode)"
        _ -> putStrLn "Dot generation disabled"

    -- C code generation
    case functionMode of
        StandaloneOptions.MultiFunction 
          | length declarationList == 0 -> putStrLn "Multi-function mode: Nothing to do."
          | otherwise -> do
              if length declarationList > 1
                then putStrLn $ "Multi-function mode, compiling " ++ (show $ length declarationList) ++ " functions..."
                else putStrLn $ "Multi-function mode, compiling the only function (" ++ (originalFeldsparFunctionName $ head declarationList) ++ ")..." 
              highLevelInterpreterWithModuleInfo (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList)
        StandaloneOptions.SingleFunction funName -> do
            putStrLn $ "Single-function mode, compiling function " ++ funName ++ "..."
            let originalFeldsparFunctionSignatureNeeded = case filter ((==funName).originalFeldsparFunctionName) declarationList of
                                                                    [a] -> a
                                                                    []  -> error $ "Function " ++ funName ++ " not found"
                                                                    _   -> error "Unexpected error SC/01" 
            highLevelInterpreterWithModuleInfo
                (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFeldsparFunctionSignatureNeeded)