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) |
I think $()
isn't POSIX though? May want to change the shebang line accordingly.
Okay. The problem with the first revision was that it didn't allow passing of parameters to the script. It only accepted the GHC parameters. While trying to resolve the issues that @lunaryorn has detected I got that it was getting to quite non-trivial shell-scripting.
So I decided: to hell with shell, and reimplemented the whole thing as a Haskell script.
Should I possibly distribute this as a Cabal package? That way it would generate crossplatform executables.
@dag $()
is POSIX.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
You should use
$()
instead of backticks for process expansion, and you should quote all occurrences of$dir
, because it might contain whitespace, however unlikely.And you definitely must quote
$@
to preserve the field splitting of positional parameters. Without quotes,$@
expands to an ordinary string, which is then splitted by$IFS
.EDIT: This comment obviously refers to the first revision of this script, which you should restore and fix accordingly. The current revision makes it impossible to safely specify GHC parameters with whitespace.