Hs2lib-0.5.7: WinDll/Utils/Processes.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- The main entry file for the preprocessor
-- part of the WinDll suite
--
-----------------------------------------------------------------------------
module WinDll.Utils.Processes where
import WinDll.Builder
import WinDll.Session.Hs2lib
import WinDll.Utils.Feedback
import WinDll.EntryPoint
import qualified Control.Exception as C
import Control.Monad
import Control.Monad.Error
import Data.Either
import System.Random
import System.FilePath
import System.Directory
import System.IO
import System.Environment
import System.Process hiding (createProcess)
import qualified System.Process as Proc
import System.Exit
import GHC.Paths
import Paths_Hs2lib
type Process = FilePath -> Exec (String,[String]) -> Component
createProcess :: Maybe FilePath -> Process
createProcess wd = createProcess' wd True
-- | Create and run processes
createProcess' :: Maybe FilePath -> Bool -> Process
createProcess' wd quit name robot =
do (outfile,args) <- robot
session <- get
let build = pipeline session
fullfile = dirPath build
args' = map (strReplace "%filepath" fullfile) args
proc' = name ++ (case platform session of
Unix -> ""
Windows -> ".exe")
inform _normal ("*** running " ++ name ++ " in (" ++ fullfile ++ ")...")
inform _detail ("*** " ++ proc' ++ " " ++ unwords args')
(pcode) <-
liftIO $ do C.try $ Proc.createProcess
(proc proc' args'){ cwd = wd `mplus` Just (fullfile)
, std_out = CreatePipe
, std_err = CreatePipe
}
(code,_out) <- case pcode of
Left err -> if quit
then die ("Error running process '" ++ name ++ "' \n\t" ++ (show :: C.SomeException -> String) err)
else error ("Error running process '" ++ name ++ "'")
Right code -> readWhileWaitForProcess code
case code of
ExitSuccess -> do inform _detail _out
inform _normal ("*** process completed successfully.")
inform _detail ("*** Writing " ++ fullfile ++ outfile)
put $ session { pipeline = build { files = outfile :(files build) } }
(ExitFailure _) -> do inform _detail _out
inform _normal ("*** process failed.")
(if quit then die else error) ("external fault. failed to create " ++ outfile)
-- | Sandbox a process, if it fails return false, if it was successful return true.
-- This can be used to isolate calls to createProcess that should not abort the
-- entire compilation
sandbox :: Component -> Exec Bool
sandbox action =
do session <- get
result <- liftIO $ C.try (runErrorT (evalStateT action session))
return $ either (const False :: C.SomeException -> Bool) (const True) result
-- | A helper function to loop and print only the information i want out.
readWhileWaitForProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Exec (ExitCode,String)
readWhileWaitForProcess full@(_, Just hout, Just herr, proccode)
= do ret <- liftIO $ getProcessExitCode proccode
case ret of
Just c -> liftIO ( hGetContents hout >>= (\v->hClose hout>>return v) )
>>= (\val -> return (c, val))
Nothing -> do p <- liftIO $ C.try (hLookAhead herr) :: Exec (Either C.SomeException Char)
case p of
Right '[' -> (liftIO $ putStrLn =<< hGetLine herr)
>> readWhileWaitForProcess full
Right 'L' -> (liftIO $ putStrLn =<< hGetLine herr)
>> readWhileWaitForProcess full
Right _ -> (liftIO $ hGetLine herr)
>>= inform _normal
>> readWhileWaitForProcess full
Left _ -> readWhileWaitForProcess full -- will hopefully exit
-- | Run the entire compilation pipeline.
runCompilePipeLine :: Exec ()
runCompilePipeLine = do inform _normal "Compiling..."
session <- get
env <- liftIO $ getEnvironment
let vsbin = maybe "." addTrailingPathSeparator (lookup "VSBIN" env)
createProcess Nothing "ghc" createDllMain
createProcess Nothing "hsc2hs" createHSfile
createProcess Nothing "ghc" createDLL
when (mvcpp session) $ createProcess (Just vsbin) "lib" createLIB
moveAllFiles
-- | Create the dllMain c file.
createDllMain :: Exec (String,[String])
createDllMain = do session <- get
return ("dllmain.o",["-c"]
++ (if (platform session) == Windows then [] else ["-fPIC"]) ++
["dllmain.c"])
-- | Process hsc file
createHSfile :: Exec (String,[String])
createHSfile = do session <- get
let out_ = namespace session ++ ".hs"
in_ = namespace session ++ ".hsc"
ghc_ = reverse $ dropWhile (/=pathSeparator) $ reverse libdir
odir = outputDIR session
ldir = addTrailingPathSeparator (baseDir session) ++ "Includes"
cc1 = ghc_ ++ "mingw"
++ [pathSeparator] ++ "libexec"
++ [pathSeparator] ++ "gcc"
++ [pathSeparator] ++ "mingw32"
++ [pathSeparator] ++ "3.4.5"
++ [pathSeparator] ++ "cc1.exe"
ldir2 <- liftIO $ getDataFileName "Includes"
return (out_
,["-o" ++ out_
,"-I" ++ ldir
,"-I" ++ ldir2
, in_ ]) --, "-c " ++ cc1])
-- | Create the final shared lib
createDLL :: Exec (String,[String])
createDLL = do session <- get
let output = outputFile session
name = namespace session
extra = "HS" ++ name ++ ".a"
odir = outputDIR session
build = pipeline session
fullfile = dirPath build
os = platform session
dir = baseDir session
extras = optGHC session
dynamic = link_dynamic session
return (output,["-fglasgow-exts"
,"--make"
]
++ (if os /= Windows then ["-fPIC"] else [])
++ ["-shared"
,"-o"
,output
,fullfile ++ name ++ ".hs"
,"dllmain.o"
]
++ (if os == Windows then ["exports.def"] else [])
++ (if dynamic then ["-dynamic" ] else []) -- ["-static"])
++ (if threaded session then ["-threaded" ] else [])
++ ["-fno-warn-deprecated-flags"
,"-O2"
,"-package ghc"
,"-package Hs2lib"
,"-i" ++ if ' ' `elem` dir then escapePath dir else dir
--,"-outputdir " ++ if ' ' `elem` odir then escapePath odir else odir
]
++ (if os == Windows
then ["-optl --enable-stdcall-fixup"]
else [libdir </> "libHSrts.a"])
-- "-optl --disable-stdcall-fixup"
++ ["-optl"
,"-Wl,-s"
,"-funfolding-use-threshold=16"
,"-optc-O3"
,"-optc-ffast-math"
]
++ (if null extras then [] else [extras]) ++
[
-- ,"-debug"
-- ,"-fno-full-laziness" -- due to calls to unsafePerformIO
-- ,"-fno-cse" -- prevent any cse to be performed.
-- ,"-prof"
-- ,"-auto-all"
-- ,"-caf-all"
])
-- | Create the MSVC++ lib
createLIB :: Exec (String,[String])
createLIB = do session <- get
let name = namespace session
odir = addTrailingPathSeparator $ outputDIR session
lib = name ++ ".lib"
def = "exports.lib"
return (lib, ["/DEF:\""++odir ++ "exports.def\""
,"/out:\"" ++ odir ++ lib ++ "\""])
-- | Move all the required files to their final destinations
moveAllFiles :: Exec ()
moveAllFiles = do session <- get
let output = outputFile session
name = namespace session
extra = "HS" ++ name ++ ".a"
header = name ++ ".h"
ffi = name ++ "_FFI.h"
csfile = name ++ ".cs"
lib = name ++ ".lib"
odir = addTrailingPathSeparator $ outputDIR session
build = pipeline session
fullfile = dirPath build
liftIO $ copyFile (fullfile++output) (odir++output)
#if __GLASGOW_HASKELL__ >= 702
liftIO $ copyFile (fullfile++name++".dll.a") (odir++extra)
#else
liftIO $ copyFile (fullfile++"HSdll.dll.a") (odir++extra)
#endif
when (cpp session) $
do liftIO $ copyFile (fullfile++header) (odir++header)
liftIO $ copyFile (fullfile++ffi) (odir++ffi)
when (csharp session) $
liftIO $ copyFile (fullfile++csfile) (odir++csfile)
when (mvcpp session) $
liftIO $ copyFile (fullfile++lib) (odir++lib)
when (incDef session) $
liftIO $ copyFile (fullfile++"exports.def") (odir++name++".def")
inform _normal "Files copied."