{-# 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."