Last active
December 29, 2015 13:38
-
-
Save nikita-volkov/7678130 to your computer and use it in GitHub Desktop.
A script, which serves as an alternative to `runghc` (`runhaskell`), allowing it to be run with optimization modes, such as `-O2`. What it does is just compiles the passed in script to a temporary folder, runs the executable and deletes the folder afterwards.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/usr/bin/env runghc -w | |
-- | |
-- A replacement of "runghc", which uses a compiler instead of interpreter, | |
-- thus allowing you to specify some important compiler flags, e.g. "-O2". | |
-- | |
-- USAGE: | |
-- | |
-- runmakeghc SCRIPT_PATH [COMPILER_OPTIONS] [-- SCRIPT_OPTIONS] | |
-- | |
import Control.Monad.State | |
import Control.Monad.Error | |
import Control.Applicative | |
import Control.Concurrent | |
import Control.Exception | |
import System.IO.Error | |
import System.IO | |
import System.Exit | |
import qualified System.Environment as Environment | |
import qualified System.Process as Process | |
import qualified System.Directory as Directory | |
import qualified System.FilePath as FilePath | |
main = do | |
(script, ghcOptions, scriptOptions) <- do | |
args <- Environment.getArgs | |
either (error . ("Arguments parsing failure: " ++)) return $ | |
runParse args parseArgs | |
dir <- initTempDir | |
let filename = "tmp-executable" | |
compile dir filename script ghcOptions | |
putStrLn =<< execute (FilePath.combine dir filename) scriptOptions | |
Directory.removeDirectoryRecursive dir | |
type Args = (ScriptPath, [GHCOption], [ScriptOption]) | |
type ScriptPath = FilePath | |
type GHCOption = String | |
type ScriptOption = String | |
-- * Parsing | |
------------------------- | |
type Parse = ErrorT String (State [String]) | |
runParse :: [String] -> Parse a -> Either String a | |
runParse strings = flip evalState strings . runErrorT | |
parseArgs :: Parse Args | |
parseArgs = | |
(,,) <$> parseScriptPath <*> parseGHCOptions <*> parseScriptOptions | |
parseScriptPath :: Parse ScriptPath | |
parseScriptPath = | |
maybe (throwError "No script path specified") return =<< parseHead | |
parseGHCOptions :: Parse [GHCOption] | |
parseGHCOptions = do | |
head <- parseHead | |
case head of | |
Just h | h /= "--" -> fmap (h :) parseGHCOptions | |
_ -> return [] | |
parseScriptOptions :: Parse [ScriptOption] | |
parseScriptOptions = do | |
head <- parseHead | |
maybe (return []) (\h -> fmap (h :) parseScriptOptions) head | |
parseHead :: Parse (Maybe String) | |
parseHead = do | |
strings <- get | |
case strings of | |
h : t -> do | |
put t | |
return $ Just h | |
_ -> return Nothing | |
-- * Processes | |
------------------------- | |
initTempDir :: IO FilePath | |
initTempDir = do | |
dir <- fmap (flip FilePath.combine "runmakeghc") Directory.getTemporaryDirectory | |
exists <- Directory.doesDirectoryExist dir | |
when exists $ Directory.removeDirectoryRecursive dir | |
Directory.createDirectory dir | |
return dir | |
compile :: FilePath -> FilePath -> FilePath -> [GHCOption] -> IO () | |
compile dir filename script extraOptions = do | |
void $ Process.readProcess | |
"ghc" | |
( | |
[ | |
"--make", | |
"-outputdir", | |
dir, | |
"-o", | |
FilePath.combine dir filename, | |
script | |
] ++ | |
extraOptions | |
) | |
"" | |
execute :: FilePath -> [ScriptOption] -> IO String | |
execute file options = do | |
Process.readProcess file options "" | |
-- | A modified version of 'Process.readProcess', | |
-- which passes the working directory. | |
readProcessCWD :: FilePath -> [String] -> String -> IO String | |
readProcessCWD cmd args input = | |
mask $ \restore -> do | |
(Just inh, Just outh, _, pid) <- do | |
cwd <- Directory.getCurrentDirectory | |
Process.createProcess | |
(Process.proc cmd args) { | |
Process.cwd = Just cwd, | |
Process.std_in = Process.CreatePipe, | |
Process.std_out = Process.CreatePipe, | |
Process.std_err = Process.Inherit | |
} | |
let | |
onException' = flip onException $ do | |
hClose inh | |
hClose outh | |
Process.terminateProcess pid | |
Process.waitForProcess pid | |
onException' $ do | |
restore $ do | |
-- fork off a thread to start consuming the output | |
output <- hGetContents outh | |
waitOut <- forkWait $ evaluate $ output | |
-- now write and flush any input | |
when (not (null input)) $ do hPutStr inh input; hFlush inh | |
hClose inh -- done with stdin | |
-- wait on the output | |
waitOut | |
hClose outh | |
-- wait on the process | |
ex <- Process.waitForProcess pid | |
case ex of | |
ExitSuccess -> return output | |
ExitFailure r -> | |
ioError $ userError $ | |
"readProcessCWD: " ++ cmd ++ " " ++ | |
unwords (map show args) ++ " " ++ | |
"(exit " ++ show r ++ ")" | |
where | |
forkWait :: IO a -> IO (IO a) | |
forkWait a = do | |
res <- newEmptyMVar | |
_ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res | |
return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
@dag
$()
is POSIX.