hesh 1.5.0 → 1.11.0
raw patch · 4 files changed
+231/−173 lines, 4 filesdep +cmdargsdep +data-defaultdep +exceptionsdep −cmdthelinedep ~haskell-src-extsdep ~hesh
Dependencies added: cmdargs, data-default, exceptions, unix
Dependencies removed: cmdtheline
Dependency ranges changed: haskell-src-exts, hesh
Files
- hesh.cabal +8/−5
- hesh/Main.hs +142/−124
- lib/Hesh/Process.hs +79/−43
- lib/Hesh/Shell.hs +2/−1
hesh.cabal view
@@ -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,
hesh/Main.hs view
@@ -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 "<stdin>" 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 "<generated>" 0 0) [Ident "TemplateHaskell", Ident "QuasiQuotes", Ident "PackageImports"]]+ typeHintPragmas = [LanguagePragma (SrcLoc "<generated>" 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 "<generated>" 0 0) exp (TyVar (Ident "IO ()"))+ defaultToUnit exp = ExpTypeSig (SrcLoc "<generated>" 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 "<generated>" 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 "<stdin>" 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 "<generated>" 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
lib/Hesh/Process.hs view
@@ -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- (</) :: (MonadIO m) => 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+ (</) :: (MonadIO m) => 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 [Stdin] ReadMode (/>) = 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) + 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
lib/Hesh/Shell.hs view
@@ -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