Main.hs

{-# LANGUAGE CPP #-}
module Main where
-- ====================================== Feldspar imports ==================================
import Feldspar.NameExtractor
import Feldspar.Compiler.Compiler
import qualified Feldspar.Compiler.Compiler as CompilerCore
import Feldspar.Compiler.Backend.C.Options
import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions
import qualified Feldspar.Compiler.Frontend.CommandLine.API.Options as StandaloneOptions
import Feldspar.Compiler.Frontend.CommandLine.API.Constants
import Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib
import Feldspar.Compiler.Backend.C.Library
import Feldspar.Compiler.Frontend.CommandLine.API
import Feldspar.Compiler.Imperative.Representation
import Feldspar.Compiler.Backend.C.CodeGeneration
import Feldspar.Compiler.Error
import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint
-- ====================================== System imports ==================================
import System.IO
import System.Exit
import System.Info
import System.Process
import System.IO.Error
import System.FilePath
import System.Directory
import System.Environment
import System.Console.ANSI
import System.Console.GetOpt
-- ====================================== Control imports ==================================
import Control.Monad
import Control.Exception
import Control.Monad.Error
import Control.Monad.CatchIO
-- ====================================== Other imports ==================================
import Data.List
import Debug.Trace
import Language.Haskell.Interpreter


data CompilationError =
      InterpreterError InterpreterError
    | InternalErrorCall String

compileFunction :: String -> String -> CoreOptions.Options -> Int -> OriginalFunctionSignature
                -> Interpreter ((String, Either (Module ()) CompilationError), Int)
compileFunction inFileName outFileName coreOptions linenum originalFunctionSignature = do
    let functionName = originalFunctionName originalFunctionSignature
    (SomeCompilable prg) <- interpret ("SomeCompilable " ++ functionName) (as::SomeCompilable)
    let compilationUnit = executePluginChain Standalone prg originalFunctionSignature {
        originalFunctionName = fixFunctionName $ originalFunctionName originalFunctionSignature
    } coreOptions
    -- XXX force evaluation in order to be able to catch the exceptions
    -- liftIO $ evaluate $ compToC coreOptions compilationUnit -- XXX somehow not enough(?!) -- counter-example: structexamples
    result <- liftIO $ do 
        tempdir <- System.IO.Error.catch (getTemporaryDirectory) (\_ -> return ".")
        (tempfile, temph) <- openTempFile tempdir "feldspar-temp.txt"
        let (cCode, (resultLinenum, resultCol)) = compToC ((coreOptions, Declaration_pl), linenum) compilationUnit
        Control.Exception.finally (hPutStrLn temph cCode)
                                  (do hClose temph
                                      removeFileIfPossible tempfile)
        return $ ((functionName, Left compilationUnit), resultLinenum)
    return result

compileAllFunctions :: String -> String -> CoreOptions.Options -> Int -> [OriginalFunctionSignature]
                    -> Interpreter [(String, Either (Module ()) CompilationError)]
compileAllFunctions inFileName outFileName options linenum [] = return []
compileAllFunctions inFileName outFileName options linenum (x:xs) = do
    let functionName = originalFunctionName x
    (compilationUnit, resultLinenum) <- (catchError (compileFunction inFileName outFileName options linenum x)
                              (\(e::InterpreterError) -> return $ ((functionName, Right $ InterpreterError e), linenum)))
                          `Control.Monad.CatchIO.catch`
                          (\msg -> return $ ((functionName,
                                             Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)),
                                             linenum))
    result <- compileAllFunctions inFileName outFileName options (resultLinenum + 1) xs
    return $ compilationUnit : result

-- | Interpreter body for single-function compilation
singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature
                              -> Interpreter (IO CompilationResult)
singleFunctionCompilationBody inFileName outFileName coreOptions originalFunctionSignature = do
    liftIO $ fancyWrite $ "Compiling function " ++ (originalFunctionName originalFunctionSignature) ++ "..."
    (SomeCompilable prg) <-
        interpret ("SomeCompilable " ++ originalFunctionName originalFunctionSignature) (as::SomeCompilable)
    liftIO $ standaloneCompile prg inFileName outFileName originalFunctionSignature coreOptions
    return $ return CompilationSuccess

mergeCompilationUnits :: [Module ()] -> Module ()
mergeCompilationUnits [] = handleError "Standalone" InvariantViolation "Called mergeCompilationUnits with an empty list"
mergeCompilationUnits [x] = x
mergeCompilationUnits l@(x:xs) = Module {
    definitions = nub $ definitions x ++ (definitions $ mergeCompilationUnits xs), -- nub is in fact a "global plugin" here
    moduleLabel = ()
}

padFunctionName :: String -> String
padFunctionName n = StandaloneLib.rpadWith 50 '.' $ "Function " ++ n

writeErrors :: (String, Either a CompilationError) -> IO ()
writeErrors (functionName, Left x) = return ()
writeErrors (functionName, Right err) = case err of 
    InterpreterError ie -> do
        withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":"
        printInterpreterError ie
    InternalErrorCall ec -> do
        withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":"
        withColor Red $ putStrLn ec

writeSummary :: (String, Either a CompilationError) -> IO ()
writeSummary (functionName, Left x) = do
    withColor Cyan $ putStr $ padFunctionName functionName
    withColor Green $ putStrLn "[OK]"
writeSummary (functionName, Right msg) = do
    withColor Cyan $ putStr $ padFunctionName functionName
    withColor Red $ putStrLn "[FAILED]"

filterLefts :: [(String, Either a b)] -> [a]
filterLefts [] = []
filterLefts [(_,Left x)]  = [x]
filterLefts [(_,Right _)] = []
filterLefts ((_,Left x):xs)  = x : filterLefts xs
filterLefts ((_,Right _):xs) = filterLefts xs

-- | Interpreter body for multi-function compilation
multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature]
                             -> Interpreter (IO CompilationResult)
multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do
    let (headers, linenum) = genHeaders coreOptions
    liftIO $ appendFile outFileName $ headers
    compilationUnits <- compileAllFunctions inFileName outFileName coreOptions linenum declarationList
    liftIO $ do
        mapM writeErrors compilationUnits
        withColor Blue $ putStrLn "\n================= [ Summary of compilation results ] =================\n"
        mapM writeSummary compilationUnits
        let mergedCompilationUnits = mergeCompilationUnits $ filterLefts compilationUnits
        (appendFile outFileName $ fst $ compToC ((coreOptions, Declaration_pl), linenum) mergedCompilationUnits)
            `Control.Exception.catch`
                (\msg -> withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))
    return $ return CompilationSuccess

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

removeFileIfPossible :: String -> IO ()
removeFileIfPossible filename = removeFile filename `Prelude.catch` (const $ return())

fancyWrite :: String -> IO ()
fancyWrite s = do
    withColor Blue $ putStr "=== [ "
    withColor Cyan $ putStr $ rpad 70 s
    withColor Blue $ putStrLn " ] ==="

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.optCompilerMode   = compilerMode } = opts
    let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation
    let outputFileName = convertOutputFileName inputFileName maybeOutputFileName

    -- -- -- Input file preparations -- -- --
    removeFileIfPossible $ replaceExtension inputFileName ".hi"
    removeFileIfPossible $ replaceExtension inputFileName ".o"
    -- -- -- Output file preparations -- -- --
    renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return())
    -- -- -- </prepare> -- -- --
    fileDescriptor <- openFile inputFileName ReadMode
    fileContents <- hGetContents fileDescriptor

    let declarationList = getExtendedDeclarationList fileContents
    let moduleName = getModuleName fileContents
    fancyWrite $ "Compilation target: module " ++ moduleName
    fancyWrite $ "Output file: " ++ outputFileName

#ifdef RELEASE
    let needGlobal = False -- globalImportList modules are package modules and shouldn't be loaded, only imported
#else 
    let needGlobal = True -- in normal mode, we need to load them before importing them
#endif

    let highLevelInterpreterWithModuleInfo body = 
            highLevelInterpreter moduleName inputFileName globalImportList needGlobal False body

    -- C code generation
    case functionMode of
        StandaloneOptions.MultiFunction 
          | length declarationList == 0 -> putStrLn "No functions to compile."
          | otherwise -> do
                fancyWrite $ "Number of functions to compile: " ++ (show $ length declarationList)
                highLevelInterpreterWithModuleInfo
                    (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList)
                return ()
        StandaloneOptions.SingleFunction funName -> do
            let originalFunctionSignatureNeeded = 
                    case filter ((==funName).originalFunctionName) declarationList of
                            [a] -> a
                            []  -> error $ "Function " ++ funName ++ " not found"
                            _   -> error "Unexpected error SC/01" 
            highLevelInterpreterWithModuleInfo
                (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFunctionSignatureNeeded)
            return ()