diff --git a/hesh.cabal b/hesh.cabal --- a/hesh.cabal +++ b/hesh.cabal @@ -1,5 +1,5 @@ name: hesh -version: 1.5.0 +version: 1.11.0 synopsis: the Haskell Extensible Shell: Haskell for Bash-style scripts description: Hesh makes writing scripts in Haskell easier by providing Bash-style syntax for running commands, implicit module imports, and automatic dependency inference and Cabal file generation. It allows shebang execution of scripts. homepage: https://github.com/jekor/hesh @@ -25,19 +25,21 @@ bytestring, Cabal, cartel >= 0.16, - cmdtheline, + cmdargs, containers, cryptohash, + data-default, directory, filepath, hackage-db >= 1.8, - haskell-src-exts, - hesh == 1.5.0, + haskell-src-exts < 1.18, + hesh == 1.11.0, parsec >= 3, process, text, time, - uniplate + uniplate, + unix hs-source-dirs: hesh default-language: Haskell2010 ghc-options: -threaded @@ -48,6 +50,7 @@ Hesh.Process Hesh.Shell build-depends: base >= 4.7 && < 6, + exceptions, filemanip, parsec >= 3, process, diff --git a/hesh/Main.hs b/hesh/Main.hs --- a/hesh/Main.hs +++ b/hesh/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} import qualified Cartel @@ -11,16 +12,20 @@ import Data.Aeson (Value(..), ToJSON(..), FromJSON(..), encode, decode) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL +import Data.Char (isDigit) +import Data.Data (Data) +import Data.Default (def) import Data.Generics.Uniplate.Data (universeBi, transformBi) import Data.List (intercalate, find, filter, nub, any, takeWhile, isPrefixOf, unionBy) import qualified Data.Map.Strict as Map import Data.Map.Lazy (foldrWithKey) -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (fromMaybe, catMaybes, isJust) import Data.Monoid (mempty) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Text.IO as TIO import Data.Time.LocalTime (getZonedTime) +import Data.Typeable (Typeable) import qualified Data.Version as V import Distribution.Hackage.DB (readHackage, hackagePath) import Distribution.PackageDescription (condLibrary, condTreeData, exposedModules) @@ -28,39 +33,146 @@ import Distribution.Version (versionBranch) import GHC.Generics (Generic) import Language.Haskell.Exts (parseFileContentsWithMode, ParseMode(..), defaultParseMode, Extension(..), KnownExtension(..), ParseResult(..), fromParseResult) +import Language.Haskell.Exts.Fixity (applyFixities, infix_, infixl_, infixr_) import Language.Haskell.Exts.Syntax (Module(..), ModuleName(..), ModulePragma(..), ImportDecl(..), QName(..), Name(..), Exp(..), Stmt(..), Type(..), SrcLoc(..), QOp(..)) import Language.Haskell.Exts.Pretty (prettyPrintWithMode, defaultMode, PPHsMode(linePragmas)) -import System.Console.CmdTheLine (Term, TermInfo(..), OptInfo(..), PosInfo(..), flag, value, pos, posAny, optInfo, posInfo, defTI) -import System.Console.CmdTheLine.Term (run) -import System.Console.CmdTheLine.Util (fileExists) -import System.Directory (getTemporaryDirectory, createDirectoryIfMissing) +import System.Console.CmdArgs (cmdArgs, (&=), help, typ, args, summary, name) +import System.Directory (getTemporaryDirectory, createDirectoryIfMissing, doesFileExist) import System.Exit (ExitCode(..), exitFailure) import System.FilePath ((), (<.>), replaceFileName, takeBaseName) -import System.IO (hPutStrLn, stderr, writeFile) +import System.IO (hPutStrLn, hPutStr, stderr, writeFile, hGetContents, Handle) +import System.Posix.Process (executeFile) import System.Process (ProcessHandle, waitForProcess, createProcess, CreateProcess(..), shell, proc, StdStream(..)) import Hesh.Process (pipeOps) import Hesh.Shell (desugar) -waitForSuccess :: String -> ProcessHandle -> IO () -waitForSuccess cmd p = do +data Hesh = Hesh {stdin_ :: Bool + ,no_sugar :: Bool + ,no_type_hints :: Bool + ,compile_only :: Bool + ,verbose :: Bool + ,args_ :: [String] + } deriving (Data, Typeable, Show, Eq) + +hesh = Hesh {stdin_ = False &= help "If this option is present, or if no arguments remain after option process, then the script is read from standard input." + ,no_sugar = False &= help "Don't expand syntax shortcuts." + ,no_type_hints = False &= name "t" &= help "Don't add automatic type hints." + ,compile_only = False &= help "Compile the script but don't run it." + ,verbose = False &= help "Display more information, such as Cabal output." + ,args_ = def &= args &= typ "FILE|ARG.." + } &= + help "Run a hesh script." &= + summary "Hesh v1.11.0" + +main = do + opts <- cmdArgs hesh + -- In order to work in shebang mode and to provide a more familiar + -- commandline interface, we support taking the input filename as an + -- argument (rather than just relying on the script being provided + -- on stdin). If no commandline argument is provided, we assume the + -- script is on stdin. + let scriptFile = if stdin_ opts || null (args_ opts) then "" else head (args_ opts) + scriptName = if stdin_ opts || null (args_ opts) then "script" else takeBaseName (head (args_ opts)) + (source'', args) <- if stdin_ opts || null (args_ opts) + then (\x -> (x, args_ opts)) `fmap` TIO.getContents + else (\x -> (x, tail (args_ opts))) `fmap` TIO.readFile (head (args_ opts)) + -- Remove any leading shebang line. + let source' = if Text.isPrefixOf "#!" source'' + then Text.dropWhile (/= '\n') source'' + else source'' + source = if no_sugar opts + then source' + else Text.pack (desugar (Text.unpack source')) + md5 = hash $ encodeUtf8 source :: Digest MD5 + -- + -- First, create a directory for the script. One option would be to + -- create the directory in the current directory, but that would + -- depend on running the script from its directory, another is to + -- create it in the script's directory, but we don't know that we + -- have write permissions to that (if it's even a writable + -- directory). An always writeable option is to use a temporary + -- directory, however, this has the disadvantage that it'll could be + -- cleaned up automatically and slow down start time for later calls + -- of the script. Additionally, how do we name the directory to + -- avoid collisions? If we just use the script name there's a high + -- chance of collisions. If we use a hash of the script we have to + -- rebuild the directory every time the script changes (viable for + -- production but not during development). + -- + -- We could compromise flexibility and safety by providing a command + -- line parameter for the directory. For maximum safety, we'll use a + -- hash of the script contents for now. + -- + dir <- ( ("hesh-" ++ (Text.unpack $ decodeUtf8 $ digestToHexByteString md5))) `liftM` getTemporaryDirectory + -- TODO: Set the program name appropriately. + let path = dir "dist/build" scriptName scriptName + binaryExists <- doesFileExist path + when (not binaryExists) $ do + when (verbose opts) $ hPutStrLn stderr ("Building in " ++ dir) + createDirectoryIfMissing False dir + -- First, get the module -> package+version lookup table. + p <- modulesPath + modules <- fromFileCache p =<< modulePackages + -- Now, parse the script. + let ast = (if no_type_hints opts then id else defaultToUnit) (parseScript scriptFile (no_sugar opts) source) + -- Find all qualified module names to add module names to the import list (qualified). + names = qualifiedNamesFromModule ast + -- Find any import references. + imports = importsFromModule ast + -- Remove aliased modules from the names. + aliases = catMaybes (map (\ (_, y, _) -> y) imports) + fqNames = filter (`notElem` aliases) (map fst names) + -- Insert qualified module usages back into the import list. + (Module a b pragmas d e importDecls g) = ast + expandedImports = importDecls ++ map importDeclQualified fqNames ++ if no_sugar opts then [] else (if isJust (find (\(m, _, _) -> m == "Hesh") imports) then [] else [importDeclUnqualified "Hesh"]) + expandedPragmas = pragmas ++ if no_sugar opts then [] else sugarPragmas ++ if no_type_hints opts then [] else typeHintPragmas + expandedAst = Module a b expandedPragmas d e expandedImports g + -- From the imports, build a list of necessary packages. + -- First, remove fully qualified names that were previously + -- imported explicitly. This is so that we don't override the + -- package that might have been selected for that module + -- manually in the import statement. + packages = map (packageFromModules modules) (unionBy (\ (x, _, _) (x', _, _) -> x == x') imports (map fqNameModule fqNames) ++ if no_sugar opts then [] else [("Hesh", Nothing, Just "hesh")]) + writeFile (dir "Main.hs") (prettyPrintWithMode (defaultMode { linePragmas = True }) expandedAst) + now <- getZonedTime + -- Cartel expects us to provide the version of the Cartel library + -- but doesn't export the version for us, so we use 0. + writeFile (dir scriptName <.> "cabal") (Cartel.Render.renderNoIndent (cartel opts packages scriptName)) + -- Cabal will complain without a LICENSE file. + writeFile (dir "LICENSE") "" + callCommandInDir "cabal install --only-dependencies" dir (verbose opts) + callCommandInDir "cabal build" dir (verbose opts) + if compile_only opts + then putStr path + -- Finally, run the script. + else executeFile path False args Nothing + where fqNameModule name = (name, Nothing, Nothing) + sugarPragmas = [LanguagePragma (SrcLoc "" 0 0) [Ident "TemplateHaskell", Ident "QuasiQuotes", Ident "PackageImports"]] + typeHintPragmas = [LanguagePragma (SrcLoc "" 0 0) [Ident "PartialTypeSignatures"]] + +waitForSuccess :: String -> ProcessHandle -> Maybe Handle -> IO () +waitForSuccess cmd p out = do code <- waitForProcess p when (code /= ExitSuccess) $ do + case out of + Just o -> hPutStr stderr =<< hGetContents o + Nothing -> return () hPutStrLn stderr $ cmd ++ ": exited with code " ++ show code exitFailure -callCommandInDir :: String -> FilePath -> IO () -callCommandInDir cmd dir = do +callCommandInDir :: String -> FilePath -> Bool -> IO () +callCommandInDir cmd dir verbose' = do -- GHC is noisy on stdout. It should go to stderr instead. -- TODO: Move this into a more appropriate place. It just -- happens to work here. - (_, _, _, p) <- createProcess (shell cmd) { cwd = Just dir, std_out = UseHandle stderr } - waitForSuccess cmd p + (_, out, _, p) <- createProcess (shell cmd) { cwd = Just dir, std_out = (if verbose' then UseHandle stderr else CreatePipe) } + waitForSuccess cmd p out callCommand :: FilePath -> [String] -> IO () callCommand path args = do (_, _, _, p) <- createProcess (proc path args) - waitForSuccess path p + waitForSuccess path p Nothing catchAny :: IO a -> (SomeException -> IO a) -> IO a catchAny = catch @@ -102,7 +214,7 @@ -- do ... /> "..." => ... /> "..." :: IO () canDefaultToUnit (InfixApp exp1 (QVarOp op) exp2) = op `elem` (concatMap operatorNames pipeOps) canDefaultToUnit _ = False - defaultToUnit exp = ExpTypeSig (SrcLoc "" 0 0) exp (TyVar (Ident "IO ()")) + defaultToUnit exp = ExpTypeSig (SrcLoc "" 0 0) exp (TyVar (Ident "_ ()")) functionNames name = [ UnQual (Ident name) , Qual (ModuleName "Hesh") (Ident name) ] operatorNames name = [ UnQual (Symbol name) @@ -121,118 +233,22 @@ importDeclUnqualified m = ImportDecl (SrcLoc "" 0 0) (ModuleName m) False False False Nothing Nothing Nothing packageFromModules modules (m, _, Just pkg) - | pkg == "hesh" = Cartel.package "hesh" Cartel.anyVersion -- [1, 5, 0] [1, 5, 0] - | otherwise = Cartel.package pkg Cartel.anyVersion + | pkg == "hesh" = Cartel.package "hesh" Cartel.anyVersion + | otherwise = + let parts = Text.splitOn "-" (Text.pack pkg) + in case parts of + [_] -> Cartel.package pkg Cartel.anyVersion + ps -> if Text.all (\c -> isDigit c || c == '.') (last ps) + then let version = map (read . Text.unpack) (Text.splitOn "." (last ps)) + package = Text.unpack (Text.intercalate "-" (init ps)) + in Cartel.package package (Cartel.eq version) + else Cartel.package pkg Cartel.anyVersion packageFromModules modules (m, _, Nothing) | m == "Hesh" || isPrefixOf "Hesh." m = Cartel.package "hesh" Cartel.anyVersion | otherwise = constrainedPackage (Map.findWithDefault (error ("Module \"" ++ m ++ "\" not found in Hackage list.")) (Text.pack m) modules) -main = run (term, termInfo) - -term = hesh <$> flagStdin <*> flagNoSugar <*> flagCompileOnly <*> optionFile <*> arguments - -termInfo = defTI { termName = "hesh", version = "1.5.0" } - -flagStdin :: Term Bool -flagStdin = value . flag $ (optInfo [ "stdin", "s" ]) { optName = "STDIN", optDoc = "If this option is present, or if no arguments remain after option processing, then the script is read from standard input." } - -flagNoSugar :: Term Bool -flagNoSugar = value . flag $ (optInfo [ "no-sugar", "n" ]) { optName = "NOSUGAR", optDoc = "Don't expand syntax shortcuts." } - -flagCompileOnly :: Term Bool -flagCompileOnly = value . flag $ (optInfo [ "compile-only", "c" ]) { optName = "COMPILEONLY", optDoc = "Compile the script but don't run it." } - -optionFile :: Term String -optionFile = value (pos 0 "" posInfo { posName = "FILE" }) - -arguments = value (posAny [] posInfo { posName = "ARGS" }) - -hesh useStdin noSugar compileOnly _ args' = do - -- In order to work in shebang mode and to provide a more familiar - -- commandline interface, we support taking the input filename as an - -- argument (rather than just relying on the script being provided - -- on stdin). If no commandline argument is provided, we assume the - -- script is on stdin. - let scriptFile = if useStdin || (args' == []) then "" else head args' - scriptName = if useStdin || (args' == []) then "script" else takeBaseName (head args') - (source'', args) <- if useStdin || (args' == []) - then (\x -> (x, args')) `fmap` TIO.getContents - else (\x -> (x, tail args')) `fmap` TIO.readFile (head args') - -- Remove any leading shebang line. - let source' = if Text.isPrefixOf "#!" source'' - then Text.dropWhile (/= '\n') source'' - else source'' - source = if noSugar - then source' - else Text.pack (desugar (Text.unpack source')) - md5 = hash $ encodeUtf8 source :: Digest MD5 - -- - -- First, create a directory for the script. One option would be to - -- create the directory in the current directory, but that would - -- depend on running the script from its directory, another is to - -- create it in the script's directory, but we don't know that we - -- have write permissions to that (if it's even a writable - -- directory). An always writeable option is to use a temporary - -- directory, however, this has the disadvantage that it'll could be - -- cleaned up automatically and slow down start time for later calls - -- of the script. Additionally, how do we name the directory to - -- avoid collisions? If we just use the script name there's a high - -- chance of collisions. If we use a hash of the script we have to - -- rebuild the directory every time the script changes (viable for - -- production but not during development). - -- - -- We could compromise flexibility and safety by providing a command - -- line parameter for the directory. For maximum safety, we'll use a - -- hash of the script contents for now. - -- - dir <- ( ("hesh-" ++ (Text.unpack $ decodeUtf8 $ digestToHexByteString md5))) `liftM` getTemporaryDirectory - hPutStrLn stderr ("Building in " ++ dir) - createDirectoryIfMissing False dir - -- First, get the module -> package+version lookup table. - p <- modulesPath - modules <- fromFileCache p =<< modulePackages - -- Now, parse the script. - let ast = defaultToUnit (parseScript scriptFile noSugar source) - -- Find all qualified module names to add module names to the import list (qualified). - names = qualifiedNamesFromModule ast - -- Find any import references. - imports = importsFromModule ast - -- Remove aliased modules from the names. - aliases = catMaybes (map (\ (_, y, _) -> y) imports) - fqNames = filter (`notElem` aliases) (map fst names) - -- Insert qualified module usages back into the import list. - (Module a b pragmas d e importDecls g) = ast - expandedImports = importDecls ++ map importDeclQualified fqNames ++ if noSugar then [] else [importDeclUnqualified "Hesh"] - expandedPragmas = if noSugar then pragmas else pragmas ++ sugarPragmas - expandedAst = Module a b expandedPragmas d e expandedImports g - -- From the imports, build a list of necessary packages. - -- First, remove fully qualified names that were previously - -- imported explicitly. This is so that we don't override the - -- package that might have been selected for that module - -- manually in the import statement. - packages = map (packageFromModules modules) (unionBy (\ (x, _, _) (x', _, _) -> x == x') imports (map fqNameModule fqNames) ++ if noSugar then [] else [("Hesh", Nothing, Just "hesh")]) - -- packages = map (packageFromModules modules) (map fst imports ++ fqNames ++ if noSugar then [] else ["Hesh"]) - writeFile (dir "Main.hs") (prettyPrintWithMode (defaultMode { linePragmas = True }) expandedAst) - now <- getZonedTime - -- Cartel expects us to provide the version of the Cartel library - -- but doesn't export the version for us, so we use 0. - writeFile (dir scriptName <.> "cabal") (Cartel.Render.renderNoIndent (cartel packages scriptName)) - -- Cabal will complain without a LICENSE file. - writeFile (dir "LICENSE") "" - callCommandInDir "cabal install --only-dependencies" dir - callCommandInDir "cabal build" dir - -- Finally, run the script. - -- Should we exec() here? - -- TODO: Set the program name appropriately. - let path = dir "dist/build" scriptName scriptName - if compileOnly - then putStr path - else callCommand path args - where fqNameModule name = (name, Nothing, Nothing) - sugarPragmas = [LanguagePragma (SrcLoc "" 0 0) [Ident "TemplateHaskell", Ident "QuasiQuotes", Ident "PackageImports"]] - -cartel packages name = mempty { Cartel.Ast.properties = properties - , Cartel.Ast.sections = [executable] } +cartel opts packages name = mempty { Cartel.Ast.properties = properties + , Cartel.Ast.sections = [executable] } where properties = mempty { Cartel.name = name , Cartel.version = [0,1] @@ -246,7 +262,7 @@ fields = [ Cartel.Ast.ExeMainIs "Main.hs" , Cartel.Ast.ExeInfo (Cartel.Ast.DefaultLanguage Cartel.Ast.Haskell2010) , Cartel.Ast.ExeInfo (Cartel.Ast.BuildDepends ([Cartel.package "base" Cartel.anyVersion] ++ packages)) - , Cartel.Ast.ExeInfo (Cartel.Ast.GHCOptions (["-threaded"])) + , Cartel.Ast.ExeInfo (Cartel.Ast.GHCOptions (["-threaded"] ++ if no_type_hints opts then [] else ["-fno-warn-partial-type-signatures"])) ] -- We make the simplifying assumption that a module only appears in a @@ -291,7 +307,9 @@ parseScript :: String -> Bool -> Text.Text -> Module parseScript filename noSugar source = case parseFileContentsWithMode - (defaultParseMode {parseFilename = filename, extensions = exts}) + (defaultParseMode { parseFilename = filename + , extensions = exts + , fixities = Just (infixl_ 8 ["^..", "^?", "^?!", "^@..", "^@?", "^@?!", "^.", "^@."])}) (Text.unpack source) of ParseOk m -> m r@(ParseFailed _ _) -> fromParseResult r diff --git a/lib/Hesh/Process.hs b/lib/Hesh/Process.hs --- a/lib/Hesh/Process.hs +++ b/lib/Hesh/Process.hs @@ -1,33 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} module Hesh.Process ( (|>), (/>), (!>), (&>), (>), (!>>), (&>>), pipeOps - , cmd, passThrough, (.=) + , ProcessFailure, cmd, passThrough, (.=) ) where -import Control.Concurrent (forkIO, myThreadId, ThreadId) -import Control.Exception (finally, bracketOnError, catch, throwTo, SomeException) +import Control.Exception (Exception, bracketOnError) import Control.Monad (liftM, void) +import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Char (isSpace) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO +import Data.Typeable (Typeable) import System.Exit (ExitCode(..)) import System.IO (openFile, IOMode(..), hGetContents, hClose, hPutStrLn, stderr, Handle) import System.Process (proc, createProcess, CreateProcess(..), ProcessHandle, waitForProcess, StdStream(..), CmdSpec(..), readProcess, terminateProcess) +type RunningProcess = (String, ProcessHandle) +type ProcessChain = ([RunningProcess], CreateProcess) + +data ProcessFailure = ProcessFailure String Int + deriving (Typeable) + +instance Show ProcessFailure where + show (ProcessFailure command code) = "Command " ++ command ++ " exited with failure code: " ++ show code + +instance Exception ProcessFailure + pipeOps = ["|>", "/>", "!>", "&>", ">", "!>>", "&>>"] class PipeResult a where - (|>) :: (MonadIO m) => m CreateProcess -> m CreateProcess -> m a - (/>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a - (!>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a - (&>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a - ( m CreateProcess -> FilePath -> m a - (/>>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a - (!>>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a - (&>>) :: (MonadIO m) => m CreateProcess -> FilePath -> m a + (|>) :: (MonadIO m) => m ProcessChain -> m ProcessChain -> m a + (/>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a + (!>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a + (&>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a + ( m ProcessChain -> FilePath -> m a + (/>>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a + (!>>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a + (&>>) :: (MonadIO m) => m ProcessChain -> FilePath -> m a -instance PipeResult CreateProcess where +instance PipeResult ProcessChain where (|>) = pipe () = redirect [Stdout] WriteMode @@ -57,13 +71,23 @@ p !>> path = stdoutToString (p !>> path) p &>> path = stdoutToString (p &>> path) +instance PipeResult Text where + p1 |> p2 = stdoutToText (p1 |> p2) + p /> path = stdoutToText (p /> path) + p !> path = stdoutToText (p !> path) + p &> path = stdoutToText (p &> path) + p > path = stdoutToText (p />> path) + p !>> path = stdoutToText (p !>> path) + p &>> path = stdoutToText (p &>> path) + -- cmd is like proc but operates on the resulting process depending on -- its calling context. class ProcResult a where cmd :: (MonadIO m) => FilePath -> [String] -> m a -instance ProcResult CreateProcess where - cmd path args = return (proc path args) +instance ProcResult ProcessChain where + cmd path args = return ([], proc path args) instance ProcResult () where cmd path args = passThrough (cmd path args) @@ -71,20 +95,16 @@ instance ProcResult String where cmd path args = stdoutToString (cmd path args) -waitForSuccess :: CreateProcess -> ProcessHandle -> IO () -waitForSuccess p h = do - exit <- waitForProcess h - case exit of - ExitSuccess -> return () - ExitFailure code -> let (RawCommand command _) = cmdspec p in - error ("Command " ++ command ++ " exited with failure code: " ++ show code) +instance ProcResult Text where + cmd path args = stdoutToText (cmd path args) -asyncWaitForSuccess :: CreateProcess -> ProcessHandle -> IO () -asyncWaitForSuccess p h = do - parentId <- myThreadId - void (forkIO (catch (waitForSuccess p h) (relay parentId))) - where relay :: ThreadId -> SomeException -> IO () - relay threadId e = throwTo threadId e +waitForSuccess :: [RunningProcess] -> IO () +waitForSuccess hs = mapM_ waitForSuccess' hs + where waitForSuccess' (name, handle) = do + exit <- waitForProcess handle + case exit of + ExitSuccess -> return () + ExitFailure code -> throwM (ProcessFailure name code) withProcess :: CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a withProcess p f = @@ -92,17 +112,20 @@ (\ (_, _, _, h) -> do terminateProcess h) f -passThrough :: (MonadIO m) => m CreateProcess -> m () +commandName :: CreateProcess -> String +commandName p = let (RawCommand command _) = cmdspec p in command + +passThrough :: (MonadIO m) => m ProcessChain -> m () passThrough p' = do - p <- p' - liftIO (withProcess p (\ (_, _, _, pHandle) -> waitForSuccess p pHandle)) + (ps, p) <- p' + liftIO (withProcess p (\ (_, _, _, pHandle) -> waitForSuccess (ps ++ [(commandName p, pHandle)]))) -stdoutToString :: (MonadIO m) => m CreateProcess -> m String +stdoutToString :: (MonadIO m) => m ProcessChain -> m String stdoutToString p' = do - p <- p' + (ps, p) <- p' liftIO (withProcess (p { std_out = CreatePipe }) (\ (_, Just pStdout, _, pHandle) -> do output <- hGetContents pStdout - asyncWaitForSuccess p pHandle + waitForSuccess (ps ++ [(commandName p, pHandle)]) -- Strip any trailing newline. These are almost always added to -- programs since shells don't add their own newlines, and it's a -- surprise to get these when reading a program's output. @@ -110,24 +133,37 @@ then return (init output) else return output)) -pipe :: (MonadIO m) => m CreateProcess -> m CreateProcess -> m CreateProcess +stdoutToText :: (MonadIO m) => m ProcessChain -> m Text +stdoutToText p' = do + (ps, p) <- p' + liftIO (withProcess (p { std_out = CreatePipe }) + (\ (_, Just pStdout, _, pHandle) -> do output <- Text.IO.hGetContents pStdout + waitForSuccess (ps ++ [(commandName p, pHandle)]) + -- Strip any trailing newline. These are almost always added to + -- programs since shells don't add their own newlines, and it's a + -- surprise to get these when reading a program's output. + if not (Text.null output) && Text.last output == '\n' + then return (Text.init output) + else return output)) + +pipe :: (MonadIO m) => m ProcessChain -> m ProcessChain -> m ProcessChain pipe p1' p2' = do - p1 <- p1'; p2 <- p2' + (ps1, p1) <- p1' + (ps2, p2) <- p2' liftIO (withProcess (p1 { std_out = CreatePipe }) - (\ (_, Just p1Stdout, _, p1Handle) -> do asyncWaitForSuccess p1 p1Handle - return (p2 { std_in = UseHandle p1Stdout }))) + (\ (_, Just p1Stdout, _, p1Handle) -> return (ps1 ++ [(commandName p1, p1Handle)] ++ ps2, p2 { std_in = UseHandle p1Stdout }))) data StdHandle = Stdin | Stdout | Stderr deriving (Eq) -redirect :: (MonadIO m) => [StdHandle] -> IOMode -> m CreateProcess -> FilePath -> m CreateProcess +redirect :: (MonadIO m) => [StdHandle] -> IOMode -> m ProcessChain -> FilePath -> m ProcessChain redirect handles mode p' path = do - p <- p' + (ps, p) <- p' f <- liftIO (openFile path mode) return (case handles of - [Stdin] -> p { std_in = UseHandle f } - [Stdout] -> p { std_out = UseHandle f } - [Stderr] -> p { std_err = UseHandle f } - [Stdout, Stderr] -> p { std_out = UseHandle f, std_err = UseHandle f }) + [Stdin] -> (ps, p { std_in = UseHandle f }) + [Stdout] -> (ps, p { std_out = UseHandle f }) + [Stderr] -> (ps, p { std_err = UseHandle f }) + [Stdout, Stderr] -> (ps, p { std_out = UseHandle f, std_err = UseHandle f })) -- TODO: Close handle(s). -- I'm not sure that I want this to stick around, so I'm not diff --git a/lib/Hesh/Shell.hs b/lib/Hesh/Shell.hs --- a/lib/Hesh/Shell.hs +++ b/lib/Hesh/Shell.hs @@ -4,6 +4,7 @@ module Hesh.Shell (sh, desugar) where import Control.Applicative ((<$>), (*>), (<*)) +import Control.Monad.IO.Class (liftIO) import Data.Char (isSpace, isAlphaNum) import Language.Haskell.TH (Q, location, Name, mkName, newName, stringL, litE, varE, listE, varP) import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ) @@ -59,7 +60,7 @@ fragmentExp :: Fragment -> Q Exp fragmentExp (FragmentString s) = [| return $(litE (stringL s)) |] fragmentExp (FragmentIdentifier i) = [| return $(varE (mkName i)) |] -fragmentExp (FragmentEnvVar e) = [| getEnv $(litE (stringL e)) |] +fragmentExp (FragmentEnvVar e) = [| liftIO (getEnv $(litE (stringL e))) |] fragmentsP :: Parser [Fragment] fragmentsP = many (try (variableP >>= \x -> case x of