Skip to content

Instantly share code, notes, and snippets.

@nikita-volkov
Last active December 29, 2015 13:38
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save nikita-volkov/7678130 to your computer and use it in GitHub Desktop.
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.
#!/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)
@swsnr
Copy link

swsnr commented May 1, 2014

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.

@dag
Copy link

dag commented May 1, 2014

I think $() isn't POSIX though? May want to change the shebang line accordingly.

@nikita-volkov
Copy link
Author

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.

@UnkindPartition
Copy link

@dag $() is POSIX.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment