turtle 1.2.8 → 1.6.2
raw patch · 19 files changed
Files
- CHANGELOG.md +378/−0
- LICENSE +2/−2
- bench/Main.hs +1/−1
- src/Turtle.hs +54/−18
- src/Turtle/Bytes.hs +802/−0
- src/Turtle/Format.hs +29/−10
- src/Turtle/Internal.hs +249/−0
- src/Turtle/Line.hs +106/−0
- src/Turtle/Options.hs +96/−15
- src/Turtle/Pattern.hs +13/−3
- src/Turtle/Prelude.hs +2339/−1574
- src/Turtle/Shell.hs +126/−34
- src/Turtle/Tutorial.hs +187/−82
- test/Main.hs +5/−1
- test/RegressionBrokenPipe.hs +24/−0
- test/RegressionMaskingException.hs +10/−0
- test/cptree.hs +26/−0
- test/system-filepath.hs +226/−0
- turtle.cabal +116/−32
+ CHANGELOG.md view
@@ -0,0 +1,378 @@+1.6.2++* Build against latest `ansi-wl-pprint` and `optparse-applicative` [[#445]](https://github.com/Gabriella439/turtle/pull/445) / [[#446]](https://github.com/Gabriella439/turtle/pull/446) / [[#447]](https://github.com/Gabriella439/turtle/pull/447)++1.6.1++* BUG FIX: Fix `turtle` to build on Windows+* BUG FIX: `stripPrefix` and `commonPrefix` now correctly handle files with+ extensions+ * For example, before this fix `stripPrefix "./" "./foo.bar"` would+ return `Just "foo/.bar"`++1.6.0++* BREAKING CHANGE: Switch to the `FilePath` type from `base` instead of+ `system-filepath`+ * This is a breaking change for a couple of reasons:+ * The `FilePath` type has changed, so the API is not backwards-compatible+ * The thing most likely to break is if you directly imported utilities+ from the `system-filepath` or `system-fileio` packages to operate on+ `turtle`'s `FilePath`s+ * If that happens, you should first check if the `Turtle` module+ exports a utility of the same name. If so, then switch to that+ * If there is no equivalent substitute from the `Turtle` module then+ you will have to change your code to use the closest equivalent+ utility from the `filepath` or `directory` package+ * If you were previously using any of the `system-filepath` or+ `system-fileio` utilities re-exported from the `Turtle` module then+ those utilities will not break as they have been replaced with+ versions compatible with the `FilePath` type from `base`+ * The second thing most likely to break is any code that relies on+ typeclasses since because if you defined any instances for the+ `FilePath` type exported by `turtle` then those instances will now+ overlap with any instances defined for the `String` type+ * The conversion utilities (e.g. `toText`, `encodeString`) will still+ work, so code that used those conversion utilities should be less+ affected by this change+ * The behavior of the `collapse` utility is subtly different+ * `collapse` no longer interprets `..` in paths+ * This new behavior is more correct in the presence of symlinks, so the+ change is (hopefully) an improvement to downstream code+ * The new API strives to match the old behavior as closely as possible+ * … so this should (hopefully) not break too much code in practice+ * With the exception of the `collapse` function the new API should be+ bug-for-bug compatible with the old API+ * Most of the surprising behavior inherited from the old API is around+ how `.` and `..` are handled in paths+ * `parent ".." == "."` is an example of such surprising behavior+ * At some point in the future we may fix bugs in these utilities inherited+ from `system-filepath` / `system-fileio`, but no decision either way has+ been made, yet+ * Some old utilities are marked `DEPRECATED` if their behavior exactly matches+ the behavior of an existing utility from the `filepath` or `directory`+ package+ * These may be eventually removed at some point in the future or they+ remain in a deprecated state indefinitely. No decision either way has+ been made+ * The `Turtle` module also re-exports any utility suggested by a+ `DEPRECATED` pragma as a convenience+ * Other utilities are not deprecated if the old behavior significantly departs+ from any existing utility from the `filepath` or `directory` package+ * For example, the behavior of the `filename` utility differs from the+ behavior of `System.FilePath.takeFileName` for filenames that begin with a+ `.`, so we have to preserve the old behavior to avoid breaking downstream+ code+ * At some point in the future utilities like these may be deprecated in+ favor of their closest analogs in the `filepath` / `directory` packages or+ they may be supported indefinitely. No decision either way has been made+ * If you want to try to author code that is compatible with both the+ pre-1.6 and post-1.6 API:+ * If you add any instances to the `FilePath` type, import it qualified+ directly from the `system-filepath` package and use it only for instances+ * Otherwise, don't import anything else from the `system-filepath` /+ `system-fileio` packages if you can help it. Instead, restrict yourself+ entirely to the utilities and `FilePath` type exported by the `Turtle`+ module+ * Use the conversion utilities (e.g. `encodeStrings`, even if they are not+ necessary post-1.6)+ * If that's still not enough, use `CPP` and good luck!++1.5.25++* Build against latest version of `Win32` package++1.5.24++* Expose `Format` constructor++1.5.23++* Add `fromIO` utility+* Build against GHC 9.0 / 9.2++1.5.22++* Add new `update` utility+* Improve documentation for `limit`++1.5.21++* Build against `optparse-applicative-0.16.0.0`++1.5.20++* Build against `doctest-0.17`+* Only depend on `semigroups` for GHC < 8.0++1.5.19++* Add pattern synonyms for `Size`++1.5.18++* Fix space leak++1.5.17++* Add `optionsExt`: Extended version of `options` with header, footer,+ porgram-description and version information in `--help` flag+* Add `readlink`++1.5.16++* Add `cptreeL`++1.5.15++* Add `toLines`+* Add `Turtle.Bytes.{fromUTF8,toUTF8}`+* Add `Turtle.Bytes.{compress,decompress}`+* Always expose a `MonadFail` instance, relying on the `fail` package+ where needed. Related GHC 8.8 preparedness.++1.5.14++* Fix `cptree` to copy symlinks instead of descending into them+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/344+* Build against newer versions of `Win32` package++1.5.13++* Fix `chmod` bug+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/337+* Add `reduce` and re-export `(<&>)`+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/332++1.5.12++* Increase upper bound on `containers`++1.5.11++* Don't forward broken pipe exceptions when using `inproc`+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/321+* Increase upper bound on `stm`+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/321+* Tutorial improvements:+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/322++1.5.10++* Increase upper bound on `doctest` and `criterion`++1.5.9++* Add `symlink`++1.5.8++* Bug fix: `invert` no longer rejects inputs where a prefix matches the inverted+ pattern+ * See: https://github.com/Gabriel439/Haskell-Turtle-Library/pull/297+* Add lsdepth, findtree, cmin, and cmax+* Increase upper bound on `temporary` and `foldl`++1.5.7++* Increase upper bound on `doctest`++1.5.6++* Increase upper bound on `exceptions`++1.5.5++* Increase upper bound on `criterion`++1.5.4++* Increase upper bound on `exceptions`++1.5.3++* Increase upper bound on `doctest`++1.5.2++* Increase upper bound on `async`++1.5.1++* GHC 8.4 support+* Re-export `encodeString`/`decodeString`+* Update tutorial to use `stack script`+* Increase upper bounds on dependencies++1.5.0++* BREAKING CHANGE: Add `MonadCatch` instance for `Shell`+ * This requires a breaking change to the internal implementation of `Shell`+ * Most breaking changes can be fixed by replacing the `Shell` constructor+ with the newly added `_Shell` utility for ease of migration+ * If you don't use the `Shell` constructor then this change likely does not+ affect you+* Add `eprintf`++1.4.5++* Add `grepText`, `uniq`, `nub`, `sort` to `Turtle.Prelude`+* Increase upper bound on `unix-compat`++1.4.4++* Fix small mistake in tutorial++1.4.3++* Increase upper bound on `doctest`++1.4.2++* Add `sed{Prefix,Suffix,Entire}` and `inplace{Prefix,Suffix,Entire}`++1.4.1++* Increase upper bound on `doctest`++1.4.0++* BREAKING CHANGE: Remove unnecessary `Maybe` from type of `single`+* BREAKING CHANGE: Consolidate `searchable` and `executable`+* `stream{,WithErr}` now throws an `ExitCode` on failure++1.3.6++* Build against `ghc-8.2`+* Relax upper bound on `optparse-applicative` and `foldl`++1.3.5++* Increase upper bound on `foldl`++1.3.4++* Bug fix: `cptree` now correctly copies files instead of creating directories+ of the same name+* Increase upper bound on `criterion`++1.3.3++* Bug fix: Change `textToLines` to behave like `Data.Text.splitOn "\n"`+ instead of `Data.Text.unlines`+ * This fixes weird behavior around handling empty strings. `splitOn` does+ the right thing, but `unlines` does not. For example, this indirectly+ fixes a regression in `sed`, which would discard empty lines+* Bug fix: `which`/`whichAll` now behave correctly on Windows+* Add new `cptree`/`single` utilities+* Documentation fixes++1.3.2++* Fix bugs in subprocess management+* Generalize type of `repr` to return any type that implements `IsString`+* Add `optLine`, `argLine`, and `l` utilities to simplify working with `Line`s++1.3.1++* `find` no longer follows symlinks+* Increase upper bound on `directory`++1.3++* BREAKING CHANGE: Several utilities now produce and consume `Line`s instead of+ `Text`+ * The purpose of this change is to fix a very common source of confusion for+ new users about which utilities are line-aware+ * Most of the impact on existing code is just changing the types by+ replacing `Text` with `Line` in the right places. The change at the+ term level should be small (based on the changes to the tutorial examples)+* BREAKING CHANGE: `Description` now wraps a `Doc` instead of `Text`+ * In the most common case where users use string literals this has no effect+* New `Turtle.Bytes` module that provides `ByteString` variations on subprocess+ runners+* Fix `du` reporting incorrect sizes for directories+* Add `pushd`, `stat`, `lstat`, `which`, `procStrictWithErr`,+ `shellStrictWithErr`, `onFiles`, `header`, `subcommandGroup`, and `parallel`+* Backport `need` to GHC 7.6.3+* Fix missing help text for option parsers+* Fix bugs in subprocess management++1.2.8++* Increase upper bound on `time` and `transformers`+* Fix incorrect lower bound for `base`++1.2.7++* Increase upper bound on `clock` dependency++1.2.6++* Generalize several types to use `MonadManaged`+* Generalize type of `printf` to use `MonadIO`+* Add `system`, and `copymod`+* Fix `rmtree` to more accurately match behavior of `rm -r`++1.2.5++* Add `printf`, `utc`, `procs`, and `shells`++1.2.4++* Generalize type of `d` format specifier to format any `Integral` type+* Add `inprocWithErr`, `inShellWithErr`, `inplace`, and `sz`++1.2.3++* Add `subcommand` and `testpath`+* Use line buffering for `Text`-based subprocesses++1.2.2++* Re-export `with`+* Add `begins`, `ends`, `contains`, `lowerBounded`, `mktempfile`, `nl`, `paste`+ `endless`, `lsif`, and `cut`+* Fix subprocess management bugs++1.2.1++* Fix subprocess management bugs++1.2.0++* BREAKING CHANGE: `du` now returns a `Size` instead of an `Integer`+* New `Turtle.Options` module that provides convenient utilities for options+ parsing+* Add `hostname`, `outhandle`, `stderr`, `cache`, `countChars`, `countWords`,+ and `countLines`+* Fix subprocess management bugs++1.1.1++* Add `bounded`, `upperBounded`, `procStrict`, `shellStrict`, `arguments`+* Add several `Permissions`-related commands+* Generalize several types to `MonadIO`++1.1.0++* BREAKING CHANGE: Remove `Floating`/`Fractional` instances for `Pattern` and+ `Shell`+* BREAKING CHANGE: Change behavior of `Num` instance for `Pattern` and `Shell`+* Re-export `(&)`+* Add `asciiCI`, `(.||.)`, `(.&&.)`, `strict`++1.0.2++* Add `fp` format specifier+* Add `chars`/`chars` high-efficiency parsing primitives+* Fix bugs in path handling++1.0.1++* Generalize type of `die`+* Fix doctest++1.0.0++* Initial release
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015 Gabriel Gonzalez+Copyright (c) 2017 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification,@@ -8,7 +8,7 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.- * Neither the name of Gabriel Gonzalez nor the names of other contributors+ * Neither the name of Gabriella Gonzalez nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
bench/Main.hs view
@@ -2,7 +2,7 @@ module Main where import qualified Data.Text as Text-import Criterion.Main+import Test.Tasty.Bench import Turtle boundedNaive :: Int -> Int -> Pattern a -> Pattern [a]
src/Turtle.hs view
@@ -47,8 +47,6 @@ -- -- "Control.Monad.Managed.Safe" provides `Managed` resources ----- "Filesystem.Path.CurrentOS" provides `FilePath`-manipulation utilities--- -- Additionally, you might also want to import the following modules qualified: -- -- * "Options.Applicative" from @optparse-applicative@ for command-line option@@ -61,8 +59,6 @@ -- * "Data.Text" (for `Text`-manipulation utilities) -- -- * "Data.Text.IO" (for reading and writing `Text`)------ * "Filesystem.Path.CurrentOS" (for the remaining `FilePath` utilities) module Turtle ( -- * Modules@@ -70,13 +66,15 @@ , module Turtle.Pattern , module Turtle.Options , module Turtle.Shell+ , module Turtle.Line , module Turtle.Prelude , module Control.Applicative , module Control.Monad , module Control.Monad.IO.Class , module Data.Monoid , module Control.Monad.Managed- , module Filesystem.Path.CurrentOS+ , module System.FilePath+ , module Turtle.Internal , Fold(..) , FoldM(..) , Text@@ -86,12 +84,14 @@ , ExitCode(..) , IsString(..) , (&)+ , (<&>) ) where import Turtle.Format import Turtle.Pattern import Turtle.Options import Turtle.Shell+import Turtle.Line import Turtle.Prelude import Control.Applicative ( Applicative(..)@@ -117,9 +117,23 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Monoid (Monoid(..), (<>)) import Data.String (IsString(..))-import Filesystem.Path.CurrentOS+import Control.Monad.Managed (Managed, managed, runManaged, with)+import Control.Foldl (Fold(..), FoldM(..))+import Data.Text (Text)+import Data.Time (NominalDiffTime, UTCTime)+import System.FilePath ( FilePath- , root+ , dropExtension+ , hasExtension+ , isAbsolute+ , isRelative+ , (</>)+ , (<.>)+ )+import System.IO (Handle)+import System.Exit (ExitCode(..))+import Turtle.Internal+ ( root , directory , parent , filename@@ -127,28 +141,21 @@ , basename , absolute , relative- , (</>) , commonPrefix , stripPrefix , collapse , splitDirectories , extension- , hasExtension- , (<.>)- , dropExtension , splitExtension+ , splitExtensions , toText , fromText+ , encodeString+ , decodeString )-import Control.Monad.Managed (Managed, managed, runManaged, with)-import Control.Foldl (Fold(..), FoldM(..))-import Data.Text (Text)-import Data.Time (NominalDiffTime, UTCTime)-import System.IO (Handle)-import System.Exit (ExitCode(..)) import Prelude hiding (FilePath) -#if MIN_VERSION_base(4,8,0)+#if __GLASGOW_HASKELL__ >= 710 import Data.Function ((&)) #else infixl 1 &@@ -158,4 +165,33 @@ -- application operator '$', which allows '&' to be nested in '$'. (&) :: a -> (a -> b) -> b x & f = f x+#endif++#if __GLASGOW_HASKELL__ >= 821+import Data.Functor ((<&>))+#else+-- | Flipped version of '<$>'.+--+-- @+-- ('<&>') = 'flip' 'fmap'+-- @+--+-- @since 4.11.0.0+--+-- ==== __Examples__+-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right':+--+-- >>> Just 2 <&> (+1)+-- Just 3+--+-- >>> [1,2,3] <&> (+1)+-- [2,3,4]+--+-- >>> Right 3 <&> (+1)+-- Right 4+--+(<&>) :: Functor f => f a -> (a -> b) -> f b+as <&> f = f <$> as++infixl 1 <&> #endif
+ src/Turtle/Bytes.hs view
@@ -0,0 +1,802 @@+{-# LANGUAGE RankNTypes #-}++{-| This module provides `ByteString` analogs of several utilities in+ "Turtle.Prelude". The main difference is that the chunks of bytes read by+ these utilities are not necessarily aligned to line boundaries.+-}++module Turtle.Bytes (+ -- * Byte operations+ stdin+ , input+ , inhandle+ , stdout+ , output+ , outhandle+ , append+ , stderr+ , strict+ , compress+ , decompress+ , WindowBits(..)+ , Zlib.defaultWindowBits+ , fromUTF8+ , toUTF8++ -- * Subprocess management+ , proc+ , shell+ , procs+ , shells+ , inproc+ , inshell+ , inprocWithErr+ , inshellWithErr+ , procStrict+ , shellStrict+ , procStrictWithErr+ , shellStrictWithErr++ , system+ , stream+ , streamWithErr+ , systemStrict+ , systemStrictWithErr+ ) where++import Control.Applicative+import Control.Concurrent.Async (Async, Concurrently(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Managed (MonadManaged(..))+import Data.ByteString (ByteString)+import Data.Monoid+import Data.Streaming.Zlib (Inflate, Popper, PopperRes(..), WindowBits(..))+import Data.Text (Text)+import Data.Text.Encoding (Decoding(..))+import System.Exit (ExitCode(..))+import System.IO (Handle)+import Turtle.Internal (ignoreSIGPIPE)+import Turtle.Prelude (ProcFailed(..), ShellFailed(..))+import Turtle.Shell (Shell(..), FoldShell(..), fold, sh)++import qualified Control.Concurrent.Async as Async+import qualified Control.Concurrent.STM as STM+import qualified Control.Concurrent.MVar as MVar+import qualified Control.Concurrent.STM.TQueue as TQueue+import qualified Control.Exception as Exception+import qualified Control.Foldl+import qualified Control.Monad+import qualified Control.Monad.Managed as Managed+import qualified Data.ByteString+import qualified Data.Streaming.Zlib as Zlib+import qualified Data.Text+import qualified Data.Text.Encoding as Encoding+import qualified Data.Text.Encoding.Error as Encoding.Error+import qualified Foreign+import qualified System.IO+import qualified System.Process as Process+import qualified Turtle.Prelude++{-| Read chunks of bytes from standard input++ The chunks are not necessarily aligned to line boundaries+-}+stdin :: Shell ByteString+stdin = inhandle System.IO.stdin++{-| Read chunks of bytes from a file++ The chunks are not necessarily aligned to line boundaries+-}+input :: FilePath -> Shell ByteString+input file = do+ handle <- using (Turtle.Prelude.readonly file)+ inhandle handle++{-| Read chunks of bytes from a `Handle`++ The chunks are not necessarily aligned to line boundaries+-}+inhandle :: Handle -> Shell ByteString+inhandle handle = Shell (\(FoldShell step begin done) -> do+ let loop x = do+ eof <- System.IO.hIsEOF handle+ if eof+ then done x+ else do+ bytes <- Data.ByteString.hGetSome handle defaultChunkSize+ x' <- step x bytes+ loop $! x'+ loop $! begin )+ where+ -- Copied from `Data.ByteString.Lazy.Internal`+ defaultChunkSize :: Int+ defaultChunkSize = 32 * 1024 - 2 * Foreign.sizeOf (undefined :: Int)++{-| Stream chunks of bytes to standard output++ The chunks are not necessarily aligned to line boundaries+-}+stdout :: MonadIO io => Shell ByteString -> io ()+stdout s = sh (do+ bytes <- s+ liftIO (Data.ByteString.hPut System.IO.stdout bytes) )++{-| Stream chunks of bytes to a file++ The chunks do not need to be aligned to line boundaries+-}+output :: MonadIO io => FilePath -> Shell ByteString -> io ()+output file s = sh (do+ handle <- using (Turtle.Prelude.writeonly file)+ bytes <- s+ liftIO (Data.ByteString.hPut handle bytes) )++{-| Stream chunks of bytes to a `Handle`++ The chunks do not need to be aligned to line boundaries+-}+outhandle :: MonadIO io => Handle -> Shell ByteString -> io ()+outhandle handle s = sh (do+ bytes <- s+ liftIO (Data.ByteString.hPut handle bytes) )++{-| Append chunks of bytes to append to a file++ The chunks do not need to be aligned to line boundaries+-}+append :: MonadIO io => FilePath -> Shell ByteString -> io ()+append file s = sh (do+ handle <- using (Turtle.Prelude.appendonly file)+ bytes <- s+ liftIO (Data.ByteString.hPut handle bytes) )++{-| Stream chunks of bytes to standard error++ The chunks do not need to be aligned to line boundaries+-}+stderr :: MonadIO io => Shell ByteString -> io ()+stderr s = sh (do+ bytes <- s+ liftIO (Data.ByteString.hPut System.IO.stderr bytes) )++-- | Read in a stream's contents strictly+strict :: MonadIO io => Shell ByteString -> io ByteString+strict s = do+ listOfByteStrings <- fold s Control.Foldl.list+ return (Data.ByteString.concat listOfByteStrings)++{-| Run a command using @execvp@, retrieving the exit code++ The command inherits @stdout@ and @stderr@ for the current process+-}+proc+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io ExitCode+ -- ^ Exit code+proc cmd args =+ system+ ( (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args))+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.Inherit+ , Process.std_err = Process.Inherit+ } )++{-| Run a command line using the shell, retrieving the exit code++ This command is more powerful than `proc`, but highly vulnerable to code+ injection if you template the command line with untrusted input++ The command inherits @stdout@ and @stderr@ for the current process+-}+shell+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io ExitCode+ -- ^ Exit code+shell cmdline =+ system+ ( (Process.shell (Data.Text.unpack cmdline))+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.Inherit+ , Process.std_err = Process.Inherit+ } )++{-| This function is identical to `proc` except this throws `ProcFailed` for+ non-zero exit codes+-}+procs+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io ()+procs cmd args s = do+ exitCode <- proc cmd args s+ case exitCode of+ ExitSuccess -> return ()+ _ -> liftIO (Exception.throwIO (ProcFailed cmd args exitCode))++{-| This function is identical to `shell` except this throws `ShellFailed` for+ non-zero exit codes+-}+shells+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io ()+ -- ^ Exit code+shells cmdline s = do+ exitCode <- shell cmdline s+ case exitCode of+ ExitSuccess -> return ()+ _ -> liftIO (Exception.throwIO (ShellFailed cmdline exitCode))++{-| Run a command using @execvp@, retrieving the exit code and stdout as a+ non-lazy blob of Text++ The command inherits @stderr@ for the current process+-}+procStrict+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io (ExitCode, ByteString)+ -- ^ Exit code and stdout+procStrict cmd args =+ systemStrict (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args))++{-| Run a command line using the shell, retrieving the exit code and stdout as a+ non-lazy blob of Text++ This command is more powerful than `proc`, but highly vulnerable to code+ injection if you template the command line with untrusted input++ The command inherits @stderr@ for the current process+-}+shellStrict+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io (ExitCode, ByteString)+ -- ^ Exit code and stdout+shellStrict cmdline = systemStrict (Process.shell (Data.Text.unpack cmdline))++{-| Run a command using @execvp@, retrieving the exit code, stdout, and stderr+ as a non-lazy blob of Text+-}+procStrictWithErr+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io (ExitCode, ByteString, ByteString)+ -- ^ (Exit code, stdout, stderr)+procStrictWithErr cmd args =+ systemStrictWithErr (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args))++{-| Run a command line using the shell, retrieving the exit code, stdout, and+ stderr as a non-lazy blob of Text++ This command is more powerful than `proc`, but highly vulnerable to code+ injection if you template the command line with untrusted input+-}+shellStrictWithErr+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io (ExitCode, ByteString, ByteString)+ -- ^ (Exit code, stdout, stderr)+shellStrictWithErr cmdline =+ systemStrictWithErr (Process.shell (Data.Text.unpack cmdline))++-- | Halt an `Async` thread, re-raising any exceptions it might have thrown+halt :: Async a -> IO ()+halt a = do+ m <- Async.poll a+ case m of+ Nothing -> Async.cancel a+ Just (Left e) -> Exception.throwIO e+ Just (Right _) -> return ()++{-| `system` generalizes `shell` and `proc` by allowing you to supply your own+ custom `CreateProcess`. This is for advanced users who feel comfortable+ using the lower-level @process@ API+-}+system+ :: MonadIO io+ => Process.CreateProcess+ -- ^ Command+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io ExitCode+ -- ^ Exit code+system p s = liftIO (do+ let open = do+ (m, Nothing, Nothing, ph) <- Process.createProcess p+ case m of+ Just hIn -> System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)+ _ -> return ()+ return (m, ph)++ -- Prevent double close+ mvar <- MVar.newMVar False+ let close handle = do+ MVar.modifyMVar_ mvar (\finalized -> do+ Control.Monad.unless finalized+ (ignoreSIGPIPE (System.IO.hClose handle))+ return True )+ let close' (Just hIn, ph) = do+ close hIn+ Process.terminateProcess ph+ close' (Nothing , ph) = do+ Process.terminateProcess ph++ let handle (Just hIn, ph) = do+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (ignoreSIGPIPE (outhandle hIn s))+ `Exception.finally` close hIn+ Exception.mask (\restore ->+ Async.withAsync (feedIn restore) (\a ->+ restore (Process.waitForProcess ph) <* halt a ) )+ handle (Nothing , ph) = do+ Process.waitForProcess ph++ Exception.bracket open close' handle )++{-| `systemStrict` generalizes `shellStrict` and `procStrict` by allowing you to+ supply your own custom `CreateProcess`. This is for advanced users who feel+ comfortable using the lower-level @process@ API+-}+systemStrict+ :: MonadIO io+ => Process.CreateProcess+ -- ^ Command+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io (ExitCode, ByteString)+ -- ^ Exit code and stdout+systemStrict p s = liftIO (do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.Inherit+ }++ let open = do+ (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')+ System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)+ return (hIn, hOut, ph)++ -- Prevent double close+ mvar <- MVar.newMVar False+ let close handle = do+ MVar.modifyMVar_ mvar (\finalized -> do+ Control.Monad.unless finalized+ (ignoreSIGPIPE (System.IO.hClose handle))+ return True )++ Exception.bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (ignoreSIGPIPE (outhandle hIn s))+ `Exception.finally` close hIn++ Async.concurrently+ (Exception.mask (\restore ->+ Async.withAsync (feedIn restore) (\a ->+ restore (Process.waitForProcess ph) <* halt a ) ))+ (Data.ByteString.hGetContents hOut) ) )++{-| `systemStrictWithErr` generalizes `shellStrictWithErr` and+ `procStrictWithErr` by allowing you to supply your own custom+ `CreateProcess`. This is for advanced users who feel comfortable using+ the lower-level @process@ API+-}+systemStrictWithErr+ :: MonadIO io+ => Process.CreateProcess+ -- ^ Command+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> io (ExitCode, ByteString, ByteString)+ -- ^ Exit code and stdout+systemStrictWithErr p s = liftIO (do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.CreatePipe+ }++ let open = do+ (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')+ System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)+ return (hIn, hOut, hErr, ph)++ -- Prevent double close+ mvar <- MVar.newMVar False+ let close handle = do+ MVar.modifyMVar_ mvar (\finalized -> do+ Control.Monad.unless finalized+ (ignoreSIGPIPE (System.IO.hClose handle))+ return True )++ Exception.bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, hErr, ph) -> do+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (ignoreSIGPIPE (outhandle hIn s))+ `Exception.finally` close hIn++ runConcurrently $ (,,)+ <$> Concurrently (Exception.mask (\restore ->+ Async.withAsync (feedIn restore) (\a ->+ restore (Process.waitForProcess ph) <* halt a ) ))+ <*> Concurrently (Data.ByteString.hGetContents hOut)+ <*> Concurrently (Data.ByteString.hGetContents hErr) ) )++{-| Run a command using @execvp@, streaming @stdout@ as chunks of `ByteString`++ The command inherits @stderr@ for the current process+-}+inproc+ :: Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> Shell ByteString+ -- ^ Chunks of bytes read from process output+inproc cmd args =+ stream (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args))++{-| Run a command line using the shell, streaming @stdout@ as chunks of+ `ByteString`++ This command is more powerful than `inproc`, but highly vulnerable to code+ injection if you template the command line with untrusted input++ The command inherits @stderr@ for the current process+-}+inshell+ :: Text+ -- ^ Command line+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> Shell ByteString+ -- ^ Chunks of bytes read from process output+inshell cmd = stream (Process.shell (Data.Text.unpack cmd))++waitForProcessThrows :: Process.ProcessHandle -> IO ()+waitForProcessThrows ph = do+ exitCode <- Process.waitForProcess ph+ case exitCode of+ ExitSuccess -> return ()+ ExitFailure _ -> Exception.throwIO exitCode++{-| `stream` generalizes `inproc` and `inshell` by allowing you to supply your+ own custom `CreateProcess`. This is for advanced users who feel comfortable+ using the lower-level @process@ API++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+stream+ :: Process.CreateProcess+ -- ^ Command+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> Shell ByteString+ -- ^ Chunks of bytes read from process output+stream p s = do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.Inherit+ }++ let open = do+ (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')+ System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)+ return (hIn, hOut, ph)++ -- Prevent double close+ mvar <- liftIO (MVar.newMVar False)+ let close handle = do+ MVar.modifyMVar_ mvar (\finalized -> do+ Control.Monad.unless finalized (ignoreSIGPIPE (System.IO.hClose handle))+ return True )++ (hIn, hOut, ph) <- using (Managed.managed (Exception.bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph)))+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (ignoreSIGPIPE (sh (do+ bytes <- s+ liftIO (Data.ByteString.hPut hIn bytes) ) ) )+ `Exception.finally` close hIn++ a <- using+ (Managed.managed (\k ->+ Exception.mask (\restore ->+ Async.withAsync (feedIn restore) k ) ))+ inhandle hOut <|> (liftIO (waitForProcessThrows ph *> halt a) *> empty)++{-| `streamWithErr` generalizes `inprocWithErr` and `inshellWithErr` by allowing+ you to supply your own custom `CreateProcess`. This is for advanced users+ who feel comfortable using the lower-level @process@ API++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+streamWithErr+ :: Process.CreateProcess+ -- ^ Command+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> Shell (Either ByteString ByteString)+ -- ^ Chunks of bytes read from process output+streamWithErr p s = do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.CreatePipe+ }++ let open = do+ (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')+ System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)+ return (hIn, hOut, hErr, ph)++ -- Prevent double close+ mvar <- liftIO (MVar.newMVar False)+ let close handle = do+ MVar.modifyMVar_ mvar (\finalized -> do+ Control.Monad.unless finalized (ignoreSIGPIPE (System.IO.hClose handle))+ return True )++ (hIn, hOut, hErr, ph) <- using (Managed.managed (Exception.bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph)))+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (ignoreSIGPIPE (sh (do+ bytes <- s+ liftIO (Data.ByteString.hPut hIn bytes) ) ) )+ `Exception.finally` close hIn++ queue <- liftIO TQueue.newTQueueIO+ let forwardOut :: (forall a. IO a -> IO a) -> IO ()+ forwardOut restore =+ restore (sh (do+ bytes <- inhandle hOut+ liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right bytes)))) ))+ `Exception.finally` STM.atomically (TQueue.writeTQueue queue Nothing)+ let forwardErr :: (forall a. IO a -> IO a) -> IO ()+ forwardErr restore =+ restore (sh (do+ bytes <- inhandle hErr+ liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left bytes)))) ))+ `Exception.finally` STM.atomically (TQueue.writeTQueue queue Nothing)+ let drain = Shell (\(FoldShell step begin done) -> do+ let loop x numNothing+ | numNothing < 2 = do+ m <- STM.atomically (TQueue.readTQueue queue)+ case m of+ Nothing -> loop x $! numNothing + 1+ Just e -> do+ x' <- step x e+ loop x' numNothing+ | otherwise = return x+ x1 <- loop begin (0 :: Int)+ done x1 )++ a <- using+ (Managed.managed (\k ->+ Exception.mask (\restore ->+ Async.withAsync (feedIn restore) k ) ))+ b <- using+ (Managed.managed (\k ->+ Exception.mask (\restore ->+ Async.withAsync (forwardOut restore) k ) ))+ c <- using+ (Managed.managed (\k ->+ Exception.mask (\restore ->+ Async.withAsync (forwardErr restore) k ) ))+ let l `also` r = do+ _ <- l <|> (r *> STM.retry)+ _ <- r+ return ()+ let waitAll = STM.atomically (Async.waitSTM a `also` (Async.waitSTM b `also` Async.waitSTM c))+ drain <|> (liftIO (waitForProcessThrows ph *> waitAll) *> empty)++{-| Run a command using the shell, streaming @stdout@ and @stderr@ as chunks of+ `ByteString`. Chunks from @stdout@ are wrapped in `Right` and chunks from+ @stderr@ are wrapped in `Left`.++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+inprocWithErr+ :: Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> Shell (Either ByteString ByteString)+ -- ^ Chunks of either output (`Right`) or error (`Left`)+inprocWithErr cmd args =+ streamWithErr (Process.proc (Data.Text.unpack cmd) (map Data.Text.unpack args))+++{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as+ chunks of `ByteString`. Chunks from @stdout@ are wrapped in `Right` and+ chunks from @stderr@ are wrapped in `Left`.++ This command is more powerful than `inprocWithErr`, but highly vulnerable to+ code injection if you template the command line with untrusted input++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+inshellWithErr+ :: Text+ -- ^ Command line+ -> Shell ByteString+ -- ^ Chunks of bytes written to process input+ -> Shell (Either ByteString ByteString)+ -- ^ Chunks of either output (`Right`) or error (`Left`)+inshellWithErr cmd = streamWithErr (Process.shell (Data.Text.unpack cmd))++-- | Internal utility used by both `compress` and `decompress`+fromPopper :: Popper -> Shell ByteString+fromPopper popper = loop+ where+ loop = do+ result <- liftIO popper++ case result of+ PRDone ->+ empty+ PRNext compressedByteString ->+ return compressedByteString <|> loop+ PRError exception ->+ liftIO (Exception.throwIO exception)++{-| Compress a stream using @zlib@++ Note that this can decompress streams that are the concatenation of+ multiple compressed streams (just like @gzip@)++>>> let compressed = select [ "ABC", "DEF" ] & compress 0 defaultWindowBits+>>> compressed & decompress defaultWindowBits & view+"ABCDEF"+>>> (compressed <|> compressed) & decompress defaultWindowBits & view+"ABCDEF"+"ABCDEF"+-}+compress+ :: Int+ -- ^ Compression level+ -> WindowBits+ -- ^+ -> Shell ByteString+ -- ^+ -> Shell ByteString+compress compressionLevel windowBits bytestrings = do+ deflate <- liftIO (Zlib.initDeflate compressionLevel windowBits)++ let loop = do+ bytestring <- bytestrings++ popper <- liftIO (Zlib.feedDeflate deflate bytestring)++ fromPopper popper++ let wrapUp = do+ let popper = liftIO (Zlib.finishDeflate deflate)++ fromPopper popper++ loop <|> wrapUp++data DecompressionState = Uninitialized | Decompressing Inflate++-- | Decompress a stream using @zlib@ (just like the @gzip@ command)+decompress :: WindowBits -> Shell ByteString -> Shell ByteString+decompress windowBits (Shell k) = Shell k'+ where+ k' (FoldShell step begin done) = k (FoldShell step' begin' done')+ where+ begin' = (begin, Uninitialized)++ step' (x0, Uninitialized) compressedByteString = do+ inflate <- Zlib.initInflate windowBits++ step' (x0, Decompressing inflate) compressedByteString+ step' (x0, Decompressing inflate) compressedByteString = do+ popper <- Zlib.feedInflate inflate compressedByteString++ let loop x = do+ result <- popper++ case result of+ PRDone -> do+ compressedByteString' <- Zlib.getUnusedInflate inflate++ if Data.ByteString.null compressedByteString'+ then return (x, Decompressing inflate)+ else do+ decompressedByteString <- Zlib.finishInflate inflate++ x' <- step x decompressedByteString++ step' (x', Uninitialized) compressedByteString'+ PRNext decompressedByteString -> do+ x' <- step x decompressedByteString++ loop x'+ PRError exception -> do+ Exception.throwIO exception++ loop x0++ done' (x0, Uninitialized) = do+ done x0+ done' (x0, Decompressing inflate) = do+ decompressedByteString <- Zlib.finishInflate inflate++ x0' <- step x0 decompressedByteString++ done' (x0', Uninitialized)++{-| Decode a stream of bytes as UTF8 `Text`++ NOTE: This function will throw a pure exception (i.e. an `error`) if UTF8+ decoding fails (mainly due to limitations in the @text@ package's stream+ decoding API)+-}+toUTF8 :: Shell ByteString -> Shell Text+toUTF8 (Shell k) = Shell k'+ where+ k' (FoldShell step begin done) =+ k (FoldShell step' begin' done')+ where+ begin' =+ (mempty, Encoding.streamDecodeUtf8With Encoding.Error.strictDecode, begin)++ step' (prefix, decoder, x) suffix = do+ let bytes = prefix <> suffix++ let Some text prefix' decoder' = decoder bytes ++ x' <- step x text++ return (prefix', decoder', x')++ done' (_, _, x) = do+ done x++-- | Encode a stream of bytes as UTF8 `Text`+fromUTF8 :: Shell Text -> Shell ByteString+fromUTF8 = fmap Encoding.encodeUtf8
src/Turtle/Format.hs view
@@ -42,10 +42,11 @@ module Turtle.Format ( -- * Format- Format+ Format (..) , (%) , format , printf+ , eprintf , makeFormat -- * Parameters@@ -58,6 +59,7 @@ , e , g , s+ , l , fp , utc @@ -72,11 +74,13 @@ import Data.Text (Text, pack) import Data.Time (UTCTime) import Data.Word-import Filesystem.Path.CurrentOS (FilePath, toText) import Numeric (showEFloat, showFFloat, showGFloat, showHex, showOct)-import Prelude hiding ((.), id, FilePath)+import Prelude hiding ((.), id)+import qualified System.IO as IO+import Turtle.Line (Line) import qualified Data.Text.IO as Text+import qualified Turtle.Line -- | A `Format` string newtype Format a b = Format { (>>-) :: (Text -> a) -> b }@@ -110,6 +114,14 @@ printf :: MonadIO io => Format (io ()) r -> r printf fmt = fmt >>- (liftIO . Text.putStr) +{-| Print a `Format` string to standard err (without a trailing newline)++>>> eprintf ("Hello, "%s%"!\n") "world"+Hello, world!+-}+eprintf :: MonadIO io => Format (io ()) r -> r+eprintf fmt = fmt >>- (liftIO . Text.hPutStr IO.stderr)+ -- | Create your own format specifier makeFormat :: (a -> Text) -> Format r (a -> r) makeFormat k = Format (\return_ -> \a -> return_ (k a))@@ -194,20 +206,27 @@ s :: Format r (Text -> r) s = makeFormat id --- | `Format` a `Filesystem.Path.CurrentOS.FilePath` into `Text`+{-| `Format` that inserts a `Line`++>>> format l "ABC"+"ABC"+-}+l :: Format r (Line -> r)+l = makeFormat Turtle.Line.lineToText++-- | `Format` a `FilePath` into `Text` fp :: Format r (FilePath -> r)-fp = makeFormat (\fpath -> either id id (toText fpath))+fp = makeFormat pack -- | `Format` a `UTCTime` into `Text` utc :: Format r (UTCTime -> r) utc = w -{-| Convert a `Show`able value to `Text`-- Short-hand for @(format w)@+{-| Convert a `Show`able value to any type that implements `IsString` (such as+ `Text`) >>> repr (1,2) "(1,2)" -}-repr :: Show a => a -> Text-repr = format w+repr :: (Show a, IsString text) => a -> text+repr = fromString . show
+ src/Turtle/Internal.hs view
@@ -0,0 +1,249 @@+module Turtle.Internal where++import Control.Applicative ((<|>))+import Control.Exception (handle, throwIO)+import Data.Text (Text)+import Foreign.C.Error (Errno(..), ePIPE)+import GHC.IO.Exception (IOErrorType(..), IOException(..))+import System.FilePath ((</>))++import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO+import qualified System.FilePath as FilePath++ignoreSIGPIPE :: IO () -> IO ()+ignoreSIGPIPE = handle (\e -> case e of+ IOError+ { ioe_type = ResourceVanished+ , ioe_errno = Just ioe }+ | Errno ioe == ePIPE -> return ()+ _ -> throwIO e+ )++{-| Convert a `FilePath` to human-readable `Text`++ Note that even though the type says `Either` this utility actually always+ succeeds and returns a `Right` value. The only reason for the `Either` is+ compatibility with the old type from the @system-filepath@ package.+-}+toText :: FilePath -> Either Text Text+toText = Right . Text.pack+{-# DEPRECATED toText "Use Data.Text.pack instead" #-}++-- | Convert `Text` to a `FilePath`+fromText :: Text -> FilePath+fromText = Text.unpack+{-# DEPRECATED fromText "Use Data.Text.unpack instead" #-}++-- | Convert a `String` to a `FilePath`+decodeString :: String -> FilePath+decodeString = id+{-# DEPRECATED decodeString "Use id instead" #-}++-- | Convert a `FilePath` to a `String`+encodeString :: FilePath -> String+encodeString = id+{-# DEPRECATED encodeString "Use id instead" #-}++-- | Find the greatest common prefix between a list of `FilePath`s+commonPrefix :: [FilePath] -> FilePath+commonPrefix [ ] = mempty+commonPrefix (path : paths) = foldr longestPathPrefix path paths+ where+ longestPathPrefix left right+ | leftComponents == rightComponents =+ FilePath.joinPath leftComponents+ ++ mconcat (longestPrefix leftExtensions rightExtensions)+ | otherwise =+ FilePath.joinPath (longestPrefix leftComponents rightComponents)+ where+ (leftComponents, leftExtensions) = splitExt (splitDirectories left)++ (rightComponents, rightExtensions) = splitExt (splitDirectories right)++longestPrefix :: Eq a => [a] -> [a] -> [a]+longestPrefix (l : ls) (r : rs)+ | l == r = l : longestPrefix ls rs+longestPrefix _ _ = [ ]++-- | Remove a prefix from a path+stripPrefix :: FilePath -> FilePath -> Maybe FilePath+stripPrefix prefix path = do+ componentSuffix <- List.stripPrefix prefixComponents pathComponents++ if null componentSuffix+ then do+ prefixSuffix <- List.stripPrefix prefixExtensions pathExtensions++ return (mconcat prefixSuffix)+ else do+ return (FilePath.joinPath componentSuffix ++ mconcat pathExtensions)+ where+ (prefixComponents, prefixExtensions) = splitExt (splitDirectories prefix)++ (pathComponents, pathExtensions) = splitExt (splitDirectories path)++-- Internal helper function for `stripPrefix` and `commonPrefix`+splitExt :: [FilePath] -> ([FilePath], [String])+splitExt [ component ] = ([ base ], map ("." ++) exts)+ where+ (base, exts) = splitExtensions component+splitExt [ ] =+ ([ ], [ ])+splitExt (component : components) = (component : base, exts)+ where+ (base, exts) = splitExt components++-- | Normalise a path+collapse :: FilePath -> FilePath+collapse = FilePath.normalise+{-# DEPRECATED collapse "Use System.FilePath.normalise instead" #-}++-- | Read in a file as `Text`+readTextFile :: FilePath -> IO Text+readTextFile = Text.IO.readFile+{-# DEPRECATED readTextFile "Use Data.Text.IO.readFile instead" #-}++-- | Write out a file as `Text`+writeTextFile :: FilePath -> Text -> IO ()+writeTextFile = Text.IO.writeFile+{-# DEPRECATED writeTextFile "Use Data.Text.IO.writeFile instead" #-}++-- | Retrieves the `FilePath`'s root+root :: FilePath -> FilePath+root = fst . FilePath.splitDrive++-- | Retrieves the `FilePath`'s parent directory+parent :: FilePath -> FilePath+parent path = prefix </> suffix+ where+ (drive, rest) = FilePath.splitDrive path++ components = loop (splitDirectories rest)++ prefix =+ case components of+ "./" : _ -> drive+ "../" : _ -> drive+ _ | null drive -> "./"+ | otherwise -> drive++ suffix = FilePath.joinPath components++ loop [ _ ] = [ ]+ loop [ ] = [ ]+ loop (c : cs) = c : loop cs++-- | Retrieves the `FilePath`'s directory+directory :: FilePath -> FilePath+directory path+ | prefix == "" && suffix == ".." =+ "../"+ | otherwise =+ trailingSlash (FilePath.takeDirectory prefix) ++ suffix+ where+ (prefix, suffix) = trailingParent path+ where+ trailingParent ".." = ("" , "..")+ trailingParent [ a, b ] = ([ a, b ], "" )+ trailingParent [ a ] = ([ a ] , "" )+ trailingParent [ ] = ([ ] , "" )+ trailingParent (c : cs) = (c : p, s)+ where+ ~(p, s) = trailingParent cs++ trailingSlash "" = "/"+ trailingSlash "/" = "/"+ trailingSlash (c : cs) = c : trailingSlash cs++-- | Retrieves the `FilePath`'s filename component+filename :: FilePath -> FilePath+filename path+ | result == "." || result == ".." = ""+ | otherwise = result+ where+ result = FilePath.takeFileName path++-- | Retrieve a `FilePath`'s directory name+dirname :: FilePath -> FilePath+dirname path = loop (splitDirectories path)+ where+ loop [ x, y ] =+ case deslash y <|> deslash x of+ Just name -> name+ Nothing -> ""+ loop [ x ] =+ case deslash x of+ Just name -> name+ Nothing -> ""+ loop [ ] =+ ""+ loop (_ : xs) =+ loop xs++ deslash "" = Nothing+ deslash "/" = Just ""+ deslash (c : cs) = fmap (c :) (deslash cs)++-- | Retrieve a `FilePath`'s basename component+basename :: FilePath -> String+basename path =+ case name of+ '.' : _ -> name+ _ ->+ case splitExtensions name of+ (base, _) -> base+ where+ name = filename path++-- | Test whether a path is absolute+absolute :: FilePath -> Bool+absolute = FilePath.isAbsolute+{-# DEPRECATED absolute "Use System.FilePath.isAbsolute instead" #-}++-- | Test whether a path is relative+relative :: FilePath -> Bool+relative = FilePath.isRelative+{-# DEPRECATED relative "Use System.FilePath.isRelative instead" #-}++-- | Split a `FilePath` into its components+splitDirectories :: FilePath -> [FilePath]+splitDirectories path = loop (FilePath.splitPath path)+ where+ loop [ ] = [ ]+ loop [ ".." ] = [ "../" ]+ loop [ "." ] = [ "./" ]+ loop (c : cs) = c : loop cs++-- | Get a `FilePath`'s last extension, or `Nothing` if it has no extension+extension :: FilePath -> Maybe String+extension path =+ case suffix of+ '.' : ext -> Just ext+ _ -> Nothing+ where+ suffix = FilePath.takeExtension path++-- | Split a `FilePath` on its extension+splitExtension :: FilePath -> (String, Maybe String)+splitExtension path =+ case suffix of+ '.' : ext -> (prefix, Just ext)+ _ -> (prefix, Nothing)+ where+ (prefix, suffix) = FilePath.splitExtension path++-- | Split a `FilePath` on its extensions+splitExtensions :: FilePath -> (String, [String])+splitExtensions path0 = (prefix0, reverse exts0)+ where+ (prefix0, exts0) = loop path0++ loop path = case splitExtension path of+ (prefix, Just ext) ->+ (base, ext : exts)+ where+ (base, exts) = loop prefix+ (base, Nothing) ->+ (base, [])
+ src/Turtle/Line.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Turtle.Line+ ( Line+ , lineToText+ , textToLines+ , linesToText+ , textToLine+ , unsafeTextToLine+ , NewlineForbidden(..)+ ) where++import Data.Text (Text)+import qualified Data.Text as Text+#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#endif+import Data.List.NonEmpty (NonEmpty(..))+import Data.String+#if __GLASGOW_HASKELL__ >= 710+#else+import Data.Monoid+#endif+import Data.Maybe+import Data.Typeable+import Control.Exception++import qualified Data.List.NonEmpty++-- | The `NewlineForbidden` exception is thrown when you construct a `Line`+-- using an overloaded string literal or by calling `fromString` explicitly+-- and the supplied string contains newlines. This is a programming error to+-- do so: if you aren't sure that the input string is newline-free, do not+-- rely on the @`IsString` `Line`@ instance.+--+-- When debugging, it might be useful to look for implicit invocations of+-- `fromString` for `Line`:+--+-- > >>> sh (do { line <- "Hello\nWorld"; echo line })+-- > *** Exception: NewlineForbidden+--+-- In the above example, `echo` expects its argument to be a `Line`, thus+-- @line :: `Line`@. Since we bind @line@ in `Shell`, the string literal+-- @\"Hello\\nWorld\"@ has type @`Shell` `Line`@. The+-- @`IsString` (`Shell` `Line`)@ instance delegates the construction of a+-- `Line` to the @`IsString` `Line`@ instance, where the exception is thrown.+--+-- To fix the problem, use `textToLines`:+--+-- > >>> sh (do { line <- select (textToLines "Hello\nWorld"); echo line })+-- > Hello+-- > World+data NewlineForbidden = NewlineForbidden+ deriving (Show, Typeable)++instance Exception NewlineForbidden++-- | A line of text (does not contain newlines).+newtype Line = Line Text+ deriving (Eq, Ord, Show, Monoid)++#if __GLASGOW_HASKELL__ >= 804+instance Semigroup Line where+ (<>) = mappend+#endif++instance IsString Line where+ fromString = fromMaybe (throw NewlineForbidden) . textToLine . fromString++-- | Convert a line to a text value.+lineToText :: Line -> Text+lineToText (Line t) = t++-- | Split text into lines. The inverse of `linesToText`.+textToLines :: Text -> NonEmpty Line+textToLines =+#if __GLASGOW_HASKELL__ >= 708+ Data.List.NonEmpty.fromList . coerce (Text.splitOn "\n")+#else+ Data.List.NonEmpty.fromList . map unsafeTextToLine . Text.splitOn "\n"+#endif++-- | Merge lines into a single text value.+linesToText :: [Line] -> Text+linesToText =+#if __GLASGOW_HASKELL__ >= 708+ coerce Text.unlines+#else+ Text.unlines . map lineToText+#endif++-- | Try to convert a text value into a line.+-- Precondition (checked): the argument does not contain newlines.+textToLine :: Text -> Maybe Line+textToLine = fromSingleton . textToLines+ where+ fromSingleton (a :| []) = Just a+ fromSingleton _ = Nothing++-- | Convert a text value into a line.+-- Precondition (unchecked): the argument does not contain newlines.+unsafeTextToLine :: Text -> Line+unsafeTextToLine = Line
src/Turtle/Options.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Example usage of this module: --@@ -14,8 +17,8 @@ -- > -- > main = do -- > (name, age) <- options "Greeting script" parser--- > echo (format ("Hello there, "%s) name)--- > echo (format ("You are "%d%" years old") age)+-- > echo (repr (format ("Hello there, "%s) name))+-- > echo (repr (format ("You are "%d%" years old") age)) -- -- > $ ./options --name John --age 42 -- > Hello there, John@@ -46,6 +49,7 @@ -- * Flag-based option parsers , switch , optText+ , optLine , optInt , optInteger , optDouble@@ -55,6 +59,7 @@ -- * Positional argument parsers , argText+ , argLine , argInt , argInteger , argDouble@@ -64,7 +69,9 @@ -- * Consume parsers , subcommand+ , subcommandGroup , options+ , optionsExt ) where @@ -73,23 +80,56 @@ import Data.String (IsString) import Text.Read (readMaybe) import Data.Text (Text)-import qualified Data.Text as Text import Data.Optional import Control.Applicative import Control.Monad.IO.Class-import Filesystem.Path.CurrentOS (FilePath, fromText) import Options.Applicative (Parser)+import Text.PrettyPrint.ANSI.Leijen (Doc, displayS, renderCompact)+import Turtle.Line (Line)++import qualified Data.Text as Text import qualified Options.Applicative as Opts import qualified Options.Applicative.Types as Opts-import Prelude hiding (FilePath)+import qualified Turtle.Line -- | Parse the given options from the command line options :: MonadIO io => Description -> Parser a -> io a options desc parser = liftIO- $ Opts.execParser+ $ Opts.customExecParser (Opts.prefs prefs) $ Opts.info (Opts.helper <*> parser)- (Opts.header (Text.unpack (getDescription desc)))+ (Opts.headerDoc (Just (getDescription desc)))+ where+ prefs :: Opts.PrefsMod+#if MIN_VERSION_optparse_applicative(0,13,0)+ prefs = Opts.showHelpOnError <> Opts.showHelpOnEmpty+#else+ prefs = Opts.showHelpOnError+#endif +{-| Parse the given options from the command line and add additional information++ Extended version of @options@ with program version header and footer information+-}+optionsExt :: MonadIO io => Header -> Footer -> Description -> Version -> Parser a -> io a+optionsExt header footer desc version parser = liftIO+ $ Opts.customExecParser (Opts.prefs prefs)+ $ Opts.info (Opts.helper <*> versionOption <*> parser)+ (Opts.headerDoc (Just (getHeader header)) <>+ Opts.footerDoc (Just (getFooter footer)) <>+ Opts.progDescDoc (Just (getDescription desc)))+ where+ versionOption =+ Opts.infoOption+ (Text.unpack version)+ (Opts.long "version" <> Opts.help "Show version")+ prefs :: Opts.PrefsMod+#if MIN_VERSION_optparse_applicative(0,13,0)+ prefs = Opts.showHelpOnError <> Opts.showHelpOnEmpty+#else+ prefs = Opts.showHelpOnError+#endif++ {-| The name of a command-line argument This is used to infer the long name and metavariable for the command line@@ -115,9 +155,24 @@ This description will appear in the header of the @--help@ output -}-newtype Description = Description { getDescription :: Text }+newtype Description = Description { getDescription :: Doc } deriving (IsString) +{-| Header of the program++ This description will appear in the header of the @--help@ output+-}+newtype Header = Header { getHeader :: Doc }+ deriving (IsString)+{-| Footer of the program++ This description will appear in the footer of the @--help@ output+-}+newtype Footer = Fotter { getFooter :: Doc }+ deriving (IsString)++-- | Program Version+type Version = Text {-| A helpful message explaining what a flag does This will appear in the @--help@ output@@ -174,9 +229,13 @@ optText :: ArgName -> ShortName -> Optional HelpMessage -> Parser Text optText = opt Just +-- | Parse a `Line` value as a flag-based option+optLine :: ArgName -> ShortName -> Optional HelpMessage -> Parser Line+optLine = opt Turtle.Line.textToLine+ -- | Parse a `FilePath` value as a flag-based option optPath :: ArgName -> ShortName -> Optional HelpMessage -> Parser FilePath-optPath argName short msg = fmap fromText (optText argName short msg)+optPath argName short msg = fmap Text.unpack (optText argName short msg) {- | Build a positional argument parser for any type by providing a `Text`-parsing function@@ -210,16 +269,20 @@ argText :: ArgName -> Optional HelpMessage -> Parser Text argText = arg Just +-- | Parse a `Line` as a positional argument+argLine :: ArgName -> Optional HelpMessage -> Parser Line+argLine = arg Turtle.Line.textToLine+ -- | Parse a `FilePath` as a positional argument argPath :: ArgName -> Optional HelpMessage -> Parser FilePath-argPath argName msg = fmap fromText (argText argName msg)+argPath argName msg = fmap Text.unpack (argText argName msg) argParseToReadM :: (Text -> Maybe a) -> Opts.ReadM a argParseToReadM f = do s <- Opts.readerAsk case f (Text.pack s) of Just a -> return a- Nothing -> Opts.readerAbort Opts.ShowHelpText+ Nothing -> Opts.readerAbort (Opts.ShowHelpText Nothing) {-| Create a sub-command that parses `CommandName` and then parses the rest of the command-line arguments@@ -228,10 +291,28 @@ -} subcommand :: CommandName -> Description -> Parser a -> Parser a subcommand cmdName desc p =- Opts.subparser (Opts.command name info <> Opts.metavar name)+ Opts.hsubparser (Opts.command name info <> Opts.metavar name) where name = Text.unpack (getCommandName cmdName) - info = Opts.info- (Opts.helper <*> p)- (Opts.header (Text.unpack (getDescription desc)))+ info = Opts.info p (Opts.progDescDoc (Just (getDescription desc)))++-- | Create a named group of sub-commands+subcommandGroup :: forall a. Description -> [(CommandName, Description, Parser a)] -> Parser a+subcommandGroup name cmds =+ Opts.hsubparser (Opts.commandGroup name' <> foldMap f cmds <> Opts.metavar metavar)+ where+ f :: (CommandName, Description, Parser a) -> Opts.Mod Opts.CommandFields a+ f (cmdName, desc, p) =+ Opts.command+ (Text.unpack (getCommandName cmdName))+ (Opts.info p (Opts.progDescDoc (Just (getDescription desc))))++ metavar :: String+ metavar = Text.unpack (Text.intercalate " | " (map g cmds))+ where+ g :: (CommandName, Description, Parser a) -> Text+ g (cmdName, _, _) = getCommandName cmdName++ name' :: String+ name' = displayS (renderCompact (getDescription name)) ""
src/Turtle/Pattern.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}@@ -123,6 +124,11 @@ newtype Pattern a = Pattern { runPattern :: StateT Text [] a } deriving (Functor, Applicative, Monad, Alternative, MonadPlus) +#if __GLASGOW_HASKELL__ >= 804+instance Monoid a => Semigroup (Pattern a) where+ (<>) = mappend+#endif+ instance Monoid a => Monoid (Pattern a) where mempty = pure mempty mappend = liftA2 mappend@@ -438,11 +444,15 @@ [] >>> match (invert "A") "B" [()]+>>> match (invert "A") "AA"+[()] -} invert :: Pattern a -> Pattern ()-invert p = Pattern (StateT (\str -> case runStateT (runPattern p) str of- [] -> [((), "")]- _ -> [] ))+invert p = Pattern (StateT f)+ where+ f str = case match p str of+ [] -> [((), "")]+ _ -> [] {-| Match a `Char`, but return `Text`
src/Turtle/Prelude.hs view
@@ -3,1577 +3,2342 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}---- | This module provides a large suite of utilities that resemble Unix--- utilities.------ Many of these commands are just existing Haskell commands renamed to match--- their Unix counterparts:------ >>> :set -XOverloadedStrings--- >>> cd "/tmp"--- >>> pwd--- FilePath "/tmp"------ Some commands are `Shell`s that emit streams of values. `view` prints all--- values in a `Shell` stream:------ >>> view (ls "/usr")--- FilePath "/usr/lib"--- FilePath "/usr/src"--- FilePath "/usr/sbin"--- FilePath "/usr/include"--- FilePath "/usr/share"--- FilePath "/usr/games"--- FilePath "/usr/local"--- FilePath "/usr/bin"--- >>> view (find (suffix "Browser.py") "/usr/lib")--- FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py"--- FilePath "/usr/lib/python3.4/idlelib/RemoteObjectBrowser.py"--- FilePath "/usr/lib/python3.4/idlelib/PathBrowser.py"--- FilePath "/usr/lib/python3.4/idlelib/ObjectBrowser.py"------ Use `fold` to reduce the output of a `Shell` stream:------ >>> import qualified Control.Foldl as Fold--- >>> fold (ls "/usr") Fold.length--- 8--- >>> fold (find (suffix "Browser.py") "/usr/lib") Fold.head--- Just (FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py")------ Create files using `output`:------ >>> output "foo.txt" ("123" <|> "456" <|> "ABC")--- >>> realpath "foo.txt"--- FilePath "/tmp/foo.txt"------ Read in files using `input`:------ >>> stdout (input "foo.txt")--- 123--- 456--- ABC------ Format strings in a type safe way using `format`:------ >>> dir <- pwd--- >>> format ("I am in the "%fp%" directory") dir--- "I am in the /tmp directory"------ Commands like `grep`, `sed` and `find` accept arbitrary `Pattern`s------ >>> stdout (grep ("123" <|> "ABC") (input "foo.txt"))--- 123--- ABC--- >>> let exclaim = fmap (<> "!") (plus digit)--- >>> stdout (sed exclaim (input "foo.txt"))--- 123!--- 456!--- ABC------ Note that `grep` and `find` differ from their Unix counterparts by requiring--- that the `Pattern` matches the entire line or file name by default. However,--- you can optionally match the prefix, suffix, or interior of a line:------ >>> stdout (grep (has "2") (input "foo.txt"))--- 123--- >>> stdout (grep (prefix "1") (input "foo.txt"))--- 123--- >>> stdout (grep (suffix "3") (input "foo.txt"))--- 123------ You can also build up more sophisticated `Shell` programs using `sh` in--- conjunction with @do@ notation:------ >{-# LANGUAGE OverloadedStrings #-}--- >--- >import Turtle--- >--- >main = sh example--- >--- >example = do--- > -- Read in file names from "files1.txt" and "files2.txt"--- > file <- fmap fromText (input "files1.txt" <|> input "files2.txt")--- >--- > -- Stream each file to standard output only if the file exists--- > True <- liftIO (testfile file)--- > line <- input file--- > liftIO (echo line)------ See "Turtle.Tutorial" for an extended tutorial explaining how to use this--- library in greater detail.--module Turtle.Prelude (- -- * IO- echo- , err- , readline- , Filesystem.readTextFile- , Filesystem.writeTextFile- , arguments-#if MIN_VERSION_base(4,7,0)- , export- , unset-#endif-#if MIN_VERSION_base(4,6,0)- , need-#endif- , env- , cd- , pwd- , home- , realpath- , mv- , mkdir- , mktree- , cp- , rm- , rmdir- , rmtree- , testfile- , testdir- , testpath- , date- , datefile- , touch- , time- , hostname- , sleep- , exit- , die- , (.&&.)- , (.||.)-- -- * Managed- , readonly- , writeonly- , appendonly- , mktemp- , mktempfile- , mktempdir- , fork- , wait-- -- * Shell- , inproc- , inshell- , inprocWithErr- , inshellWithErr- , stdin- , input- , inhandle- , stdout- , output- , outhandle- , append- , stderr- , strict- , ls- , lsif- , lstree- , cat- , grep- , sed- , inplace- , find- , yes- , nl- , paste- , endless- , limit- , limitWhile- , cache-- -- * Folds- , countChars- , countWords- , countLines-- -- * Text- , cut-- -- * Subprocess management- , proc- , shell- , system- , procs- , shells- , procStrict- , shellStrict-- -- * Permissions- , Permissions- , chmod- , getmod- , setmod- , copymod- , readable, nonreadable- , writable, nonwritable- , executable, nonexecutable- , searchable, nonsearchable- , ooo,roo,owo,oox,oos,rwo,rox,ros,owx,rwx,rws-- -- * File size- , du- , Size- , sz- , bytes- , kilobytes- , megabytes- , gigabytes- , terabytes- , kibibytes- , mebibytes- , gibibytes- , tebibytes-- -- * Exceptions- , ProcFailed(..)- , ShellFailed(..)- ) where--import Control.Applicative-import Control.Concurrent (threadDelay)-import Control.Concurrent.Async- (Async, withAsync, withAsyncWithUnmask, wait, waitSTM, concurrently)-import Control.Concurrent.MVar (newMVar, modifyMVar_)-import qualified Control.Concurrent.STM as STM-import qualified Control.Concurrent.STM.TQueue as TQueue-import Control.Exception (Exception, bracket, finally, mask_, throwIO)-import Control.Foldl (Fold, FoldM(..), genericLength, handles, list, premap)-import qualified Control.Foldl.Text-import Control.Monad (liftM, msum, when, unless)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Managed (MonadManaged(..), managed, runManaged)-#ifdef mingw32_HOST_OS-import Data.Bits ((.&.))-#endif-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.Text (Text, pack, unpack)-import Data.Time (NominalDiffTime, UTCTime, getCurrentTime)-import Data.Traversable-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import Data.Typeable (Typeable)-import qualified Filesystem-import Filesystem.Path.CurrentOS (FilePath, (</>))-import qualified Filesystem.Path.CurrentOS as Filesystem-import GHC.IO.Exception (IOErrorType(UnsupportedOperation))-import Network.HostName (getHostName)-import System.Clock (Clock(..), TimeSpec(..), getTime)-import System.Environment (- getArgs,-#if MIN_VERSION_base(4,7,0)- setEnv,- unsetEnv,-#endif-#if MIN_VERSION_base(4,6,0)- lookupEnv,-#endif- getEnvironment )-import System.Directory (Permissions)-import qualified System.Directory as Directory-import System.Exit (ExitCode(..), exitWith)-import System.IO (Handle, hClose)-import qualified System.IO as IO-import System.IO.Temp (withTempDirectory, withTempFile)-import System.IO.Error (catchIOError, ioeGetErrorType)-import qualified System.Process as Process-#ifdef mingw32_HOST_OS-import qualified System.Win32 as Win32-#else-import System.Posix (- openDirStream,- readDirStream,- closeDirStream,- touchFile,- getSymbolicLinkStatus,- isDirectory,- isSymbolicLink )-#endif-import Prelude hiding (FilePath)--import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy)-import Turtle.Shell-import Turtle.Format (Format, format, makeFormat, d, w, (%))--{-| Run a command using @execvp@, retrieving the exit code-- The command inherits @stdout@ and @stderr@ for the current process--}-proc- :: MonadIO io- => Text- -- ^ Command- -> [Text]- -- ^ Arguments- -> Shell Text- -- ^ Lines of standard input- -> io ExitCode- -- ^ Exit code-proc cmd args =- system- ( (Process.proc (unpack cmd) (map unpack args))- { Process.std_in = Process.CreatePipe- , Process.std_out = Process.Inherit- , Process.std_err = Process.Inherit- } )--{-| Run a command line using the shell, retrieving the exit code-- This command is more powerful than `proc`, but highly vulnerable to code- injection if you template the command line with untrusted input-- The command inherits @stdout@ and @stderr@ for the current process--}-shell- :: MonadIO io- => Text- -- ^ Command line- -> Shell Text- -- ^ Lines of standard input- -> io ExitCode- -- ^ Exit code-shell cmdLine =- system- ( (Process.shell (unpack cmdLine))- { Process.std_in = Process.CreatePipe- , Process.std_out = Process.Inherit- , Process.std_err = Process.Inherit- } )--data ProcFailed = ProcFailed- { procCommand :: Text- , procArguments :: [Text]- , procExitCode :: ExitCode- } deriving (Show, Typeable)--instance Exception ProcFailed--{-| This function is identical to `proc` except this throws `ProcFailed` for- non-zero exit codes--}-procs- :: MonadIO io- => Text- -- ^ Command- -> [Text]- -- ^ Arguments- -> Shell Text- -- ^ Lines of standard input- -> io ()-procs cmd args s = do- exitCode <- proc cmd args s- case exitCode of- ExitSuccess -> return ()- _ -> liftIO (throwIO (ProcFailed cmd args exitCode))--data ShellFailed = ShellFailed- { shellCommandLine :: Text- , shellExitCode :: ExitCode- } deriving (Show, Typeable)--instance Exception ShellFailed--{-| This function is identical to `shell` except this throws `ShellFailed` for- non-zero exit codes--}-shells- :: MonadIO io- => Text- -- ^ Command line- -> Shell Text- -- ^ Lines of standard input- -> io ()- -- ^ Exit code-shells cmdline s = do- exitCode <- shell cmdline s- case exitCode of- ExitSuccess -> return ()- _ -> liftIO (throwIO (ShellFailed cmdline exitCode))--{-| Run a command using @execvp@, retrieving the exit code and stdout as a- non-lazy blob of Text-- The command inherits @stderr@ for the current process--}-procStrict- :: MonadIO io- => Text- -- ^ Command- -> [Text]- -- ^ Arguments- -> Shell Text- -- ^ Lines of standard input- -> io (ExitCode, Text)- -- ^ Exit code and stdout-procStrict cmd args =- systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args))--{-| Run a command line using the shell, retrieving the exit code and stdout as a- non-lazy blob of Text-- This command is more powerful than `proc`, but highly vulnerable to code- injection if you template the command line with untrusted input-- The command inherits @stderr@ for the current process--}-shellStrict- :: MonadIO io- => Text- -- ^ Command line- -> Shell Text- -- ^ Lines of standard input- -> io (ExitCode, Text)- -- ^ Exit code and stdout-shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine))--{-| `system` generalizes `shell` and `proc` by allowing you to supply your own- custom `CreateProcess`. This is for advanced users who feel comfortable- using the lower-level @process@ API--}-system- :: MonadIO io- => Process.CreateProcess- -- ^ Command- -> Shell Text- -- ^ Lines of standard input- -> io ExitCode- -- ^ Exit code-system p s = liftIO (do- let open = do- (Just hIn, Nothing, Nothing, ph) <- Process.createProcess p- IO.hSetBuffering hIn IO.LineBuffering- return (hIn, ph)-- -- Prevent double close- mvar <- newMVar False- let close handle = do- modifyMVar_ mvar (\finalized -> do- unless finalized (hClose handle)- return True )-- bracket open (\(hIn, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, ph) -> do- let feedIn :: (forall a. IO a -> IO a) -> IO ()- feedIn restore =- restore (sh (do- txt <- s- liftIO (Text.hPutStrLn hIn txt) ) )- `finally` close hIn- mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a) ) ) )--systemStrict- :: MonadIO io- => Process.CreateProcess- -- ^ Command- -> Shell Text- -- ^ Lines of standard input- -> io (ExitCode, Text)- -- ^ Exit code and stdout-systemStrict p s = liftIO (do- let p' = p- { Process.std_in = Process.CreatePipe- , Process.std_out = Process.CreatePipe- , Process.std_err = Process.Inherit- }-- let open = do- (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')- IO.hSetBuffering hIn IO.LineBuffering- return (hIn, hOut, ph)-- -- Prevent double close- mvar <- newMVar False- let close handle = do- modifyMVar_ mvar (\finalized -> do- unless finalized (hClose handle)- return True )-- bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do- let feedIn :: (forall a. IO a -> IO a) -> IO ()- feedIn restore =- restore (sh (do- txt <- s- liftIO (Text.hPutStrLn hIn txt) ) )- `finally` close hIn-- concurrently- (mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a)))- (Text.hGetContents hOut) ) )--{-| Run a command using @execvp@, streaming @stdout@ as lines of `Text`-- The command inherits @stderr@ for the current process--}-inproc- :: Text- -- ^ Command- -> [Text]- -- ^ Arguments- -> Shell Text- -- ^ Lines of standard input- -> Shell Text- -- ^ Lines of standard output-inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args))--{-| Run a command line using the shell, streaming @stdout@ as lines of `Text`-- This command is more powerful than `inproc`, but highly vulnerable to code- injection if you template the command line with untrusted input-- The command inherits @stderr@ for the current process--}-inshell- :: Text- -- ^ Command line- -> Shell Text- -- ^ Lines of standard input- -> Shell Text- -- ^ Lines of standard output-inshell cmd = stream (Process.shell (unpack cmd))--stream- :: Process.CreateProcess- -- ^ Command- -> Shell Text- -- ^ Lines of standard input- -> Shell Text- -- ^ Lines of standard output-stream p s = do- let p' = p- { Process.std_in = Process.CreatePipe- , Process.std_out = Process.CreatePipe- , Process.std_err = Process.Inherit- }-- let open = do- (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')- IO.hSetBuffering hIn IO.LineBuffering- return (hIn, hOut, ph)-- -- Prevent double close- mvar <- liftIO (newMVar False)- let close handle = do- modifyMVar_ mvar (\finalized -> do- unless finalized (hClose handle)- return True )-- (hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph)))- let feedIn :: (forall a. IO a -> IO a) -> IO ()- feedIn restore =- restore (sh (do- txt <- s- liftIO (Text.hPutStrLn hIn txt) ) )- `finally` close hIn-- a <- using (managed (mask_ . withAsyncWithUnmask feedIn))- inhandle hOut <|> (liftIO (Process.waitForProcess ph *> wait a) *> empty)--streamWithErr- :: Process.CreateProcess- -- ^ Command- -> Shell Text- -- ^ Lines of standard input- -> Shell (Either Text Text)- -- ^ Lines of standard output-streamWithErr p s = do- let p' = p- { Process.std_in = Process.CreatePipe- , Process.std_out = Process.CreatePipe- , Process.std_err = Process.CreatePipe- }-- let open = do- (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')- IO.hSetBuffering hIn IO.LineBuffering- return (hIn, hOut, hErr, ph)-- -- Prevent double close- mvar <- liftIO (newMVar False)- let close handle = do- modifyMVar_ mvar (\finalized -> do- unless finalized (hClose handle)- return True )-- (hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph)))- let feedIn :: (forall a. IO a -> IO a) -> IO ()- feedIn restore =- restore (sh (do- txt <- s- liftIO (Text.hPutStrLn hIn txt) ) )- `finally` close hIn-- queue <- liftIO TQueue.newTQueueIO- let forwardOut :: (forall a. IO a -> IO a) -> IO ()- forwardOut restore =- restore (sh (do- txt <- inhandle hOut- liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right txt)))) ))- `finally` STM.atomically (TQueue.writeTQueue queue Nothing)- let forwardErr :: (forall a. IO a -> IO a) -> IO ()- forwardErr restore =- restore (sh (do- txt <- inhandle hErr- liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left txt)))) ))- `finally` STM.atomically (TQueue.writeTQueue queue Nothing)- let drain = Shell (\(FoldM step begin done) -> do- x0 <- begin- let loop x numNothing- | numNothing < 2 = do- m <- STM.atomically (TQueue.readTQueue queue)- case m of- Nothing -> loop x $! numNothing + 1- Just e -> do- x' <- step x e- loop x' numNothing- | otherwise = return x- x1 <- loop x0 (0 :: Int)- done x1 )-- a <- using (managed (mask_ . withAsyncWithUnmask feedIn ))- b <- using (managed (mask_ . withAsyncWithUnmask forwardOut))- c <- using (managed (mask_ . withAsyncWithUnmask forwardErr))- let l `also` r = do- _ <- l <|> (r *> STM.retry)- _ <- r- return ()- let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c))- drain <|> (liftIO (Process.waitForProcess ph *> waitAll) *> empty)--{-| Run a command using the shell, streaming @stdout@ and @stderr@ as lines of- `Text`. Lines from @stdout@ are wrapped in `Right` and lines from @stderr@- are wrapped in `Left`. This does /not/ throw an exception if the command- returns a non-zero exit code--}-inprocWithErr- :: Text- -- ^ Command- -> [Text]- -- ^ Arguments- -> Shell Text- -- ^ Lines of standard input- -> Shell (Either Text Text)- -- ^ Lines of either standard output (`Right`) or standard error (`Left`)-inprocWithErr cmd args =- streamWithErr (Process.proc (unpack cmd) (map unpack args))---{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as lines- of `Text`. Lines from @stdout@ are wrapped in `Right` and lines from- @stderr@ are wrapped in `Left`. This does /not/ throw an exception if the- command returns a non-zero exit code-- This command is more powerful than `inprocWithErr`, but highly vulnerable to- code injection if you template the command line with untrusted input--}-inshellWithErr- :: Text- -- ^ Command line- -> Shell Text- -- ^ Lines of standard input- -> Shell (Either Text Text)- -- ^ Lines of either standard output (`Right`) or standard error (`Left`)-inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd))---- | Print to @stdout@-echo :: MonadIO io => Text -> io ()-echo txt = liftIO (Text.putStrLn txt)---- | Print to @stderr@-err :: MonadIO io => Text -> io ()-err txt = liftIO (Text.hPutStrLn IO.stderr txt)--{-| Read in a line from @stdin@-- Returns `Nothing` if at end of input--}-readline :: MonadIO io => io (Maybe Text)-readline = liftIO (do- eof <- IO.isEOF- if eof- then return Nothing- else fmap (Just . pack) getLine )---- | Get command line arguments in a list-arguments :: MonadIO io => io [Text]-arguments = liftIO (fmap (map pack) getArgs)--#if MIN_VERSION_base(4,7,0)--- | Set or modify an environment variable-export :: MonadIO io => Text -> Text -> io ()-export key val = liftIO (setEnv (unpack key) (unpack val))---- | Delete an environment variable-unset :: MonadIO io => Text -> io ()-unset key = liftIO (unsetEnv (unpack key))-#endif--#if MIN_VERSION_base(4,6,0)--- | Look up an environment variable-need :: MonadIO io => Text -> io (Maybe Text)-need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key)))-#endif---- | Retrieve all environment variables-env :: MonadIO io => io [(Text, Text)]-env = liftIO (fmap (fmap toTexts) getEnvironment)- where- toTexts (key, val) = (pack key, pack val)---- | Change the current directory-cd :: MonadIO io => FilePath -> io ()-cd path = liftIO (Filesystem.setWorkingDirectory path)---- | Get the current directory-pwd :: MonadIO io => io FilePath-pwd = liftIO Filesystem.getWorkingDirectory---- | Get the home directory-home :: MonadIO io => io FilePath-home = liftIO Filesystem.getHomeDirectory---- | Canonicalize a path-realpath :: MonadIO io => FilePath -> io FilePath-realpath path = liftIO (Filesystem.canonicalizePath path)--#ifdef mingw32_HOST_OS-fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag-fILE_ATTRIBUTE_REPARSE_POINT = 1024--reparsePoint :: Win32.FileAttributeOrFlag -> Bool-reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0-#endif--{-| Stream all immediate children of the given directory, excluding @\".\"@ and- @\"..\"@--}-ls :: FilePath -> Shell FilePath-ls path = Shell (\(FoldM step begin done) -> do- x0 <- begin- let path' = Filesystem.encodeString path- canRead <- fmap- Directory.readable- (Directory.getPermissions (deslash path'))-#ifdef mingw32_HOST_OS- reparse <- fmap reparsePoint (Win32.getFileAttributes path')- if (canRead && not reparse)- then bracket- (Win32.findFirstFile (Filesystem.encodeString (path </> "*")))- (\(h, _) -> Win32.findClose h)- (\(h, fdat) -> do- let loop x = do- file' <- Win32.getFindDataFileName fdat- let file = Filesystem.decodeString file'- x' <- if (file' /= "." && file' /= "..")- then step x (path </> file)- else return x- more <- Win32.findNextFile h fdat- if more then loop $! x' else done x'- loop $! x0 )- else done x0 )-#else- if canRead- then bracket (openDirStream path') closeDirStream (\dirp -> do- let loop x = do- file' <- readDirStream dirp- case file' of- "" -> done x- _ -> do- let file = Filesystem.decodeString file'- x' <- if (file' /= "." && file' /= "..")- then step x (path </> file)- else return x- loop $! x'- loop $! x0 )- else done x0 )-#endif--{-| This is used to remove the trailing slash from a path, because- `getPermissions` will fail if a path ends with a trailing slash--}-deslash :: String -> String-deslash [] = []-deslash (c0:cs0) = c0:go cs0- where- go [] = []- go ['\\'] = []- go (c:cs) = c:go cs---- | Stream all recursive descendents of the given directory-lstree :: FilePath -> Shell FilePath-lstree path = do- child <- ls path- isDir <- testdir child- if isDir- then return child <|> lstree child- else return child--{-| Stream all recursive descendents of the given directory-- This skips any directories that fail the supplied predicate--> lstree = lsif (\_ -> return True)--}-lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath-lsif predicate path = do- child <- ls path- isDir <- testdir child- if isDir- then do- continue <- liftIO (predicate child)- if continue- then return child <|> lsif predicate child- else return child- else return child--{-| Move a file or directory-- Works if the two paths are on the same filesystem.- If not, @mv@ will still work when dealing with a regular file,- but the operation will not be atomic--}-mv :: MonadIO io => FilePath -> FilePath -> io ()-mv oldPath newPath = liftIO $ catchIOError (Filesystem.rename oldPath newPath)- (\ioe -> if ioeGetErrorType ioe == UnsupportedOperation -- certainly EXDEV- then do- Filesystem.copyFile oldPath newPath- Filesystem.removeFile oldPath- else ioError ioe)--{-| Create a directory-- Fails if the directory is present--}-mkdir :: MonadIO io => FilePath -> io ()-mkdir path = liftIO (Filesystem.createDirectory False path)--{-| Create a directory tree (equivalent to @mkdir -p@)-- Does not fail if the directory is present--}-mktree :: MonadIO io => FilePath -> io ()-mktree path = liftIO (Filesystem.createTree path)---- | Copy a file-cp :: MonadIO io => FilePath -> FilePath -> io ()-cp oldPath newPath = liftIO (Filesystem.copyFile oldPath newPath)---- | Remove a file-rm :: MonadIO io => FilePath -> io ()-rm path = liftIO (Filesystem.removeFile path)---- | Remove a directory-rmdir :: MonadIO io => FilePath -> io ()-rmdir path = liftIO (Filesystem.removeDirectory path)--{-| Remove a directory tree (equivalent to @rm -r@)-- Use at your own risk--}-rmtree :: MonadIO io => FilePath -> io ()-rmtree path0 = liftIO (sh (loop path0))- where-#ifdef mingw32_HOST_OS- loop path = do- isDir <- testdir path- if isDir- then (do- child <- ls path- loop child ) <|> rmdir path- else rm path-#else- loop path = do- let path' = Filesystem.encodeString path- stat <- liftIO $ getSymbolicLinkStatus path'- let isLink = isSymbolicLink stat- isDir = isDirectory stat- if isLink- then rm path- else do- if isDir- then (do- child <- ls path- loop child ) <|> rmdir path- else rm path-#endif---- | Check if a file exists-testfile :: MonadIO io => FilePath -> io Bool-testfile path = liftIO (Filesystem.isFile path)---- | Check if a directory exists-testdir :: MonadIO io => FilePath -> io Bool-testdir path = liftIO (Filesystem.isDirectory path)---- | Check if a path exists-testpath :: MonadIO io => FilePath -> io Bool-testpath path = do- exists <- testfile path- if exists- then return exists- else testdir path--{-| Touch a file, updating the access and modification times to the current time-- Creates an empty file if it does not exist--}-touch :: MonadIO io => FilePath -> io ()-touch file = do- exists <- testfile file- liftIO (if exists-#ifdef mingw32_HOST_OS- then do- handle <- Win32.createFile- (Filesystem.encodeString file)- Win32.gENERIC_WRITE- Win32.fILE_SHARE_NONE- Nothing- Win32.oPEN_EXISTING- Win32.fILE_ATTRIBUTE_NORMAL- Nothing- (creationTime, _, _) <- Win32.getFileTime handle- systemTime <- Win32.getSystemTimeAsFileTime- Win32.setFileTime handle creationTime systemTime systemTime-#else- then touchFile (Filesystem.encodeString file)-#endif- else output file empty )--{-| Update a file or directory's user permissions--> chmod rwo "foo.txt" -- chmod u=rw foo.txt-> chmod executable "foo.txt" -- chmod u+x foo.txt-> chmod nonwritable "foo.txt" -- chmod u-x foo.txt--}-chmod- :: MonadIO io- => (Permissions -> Permissions)- -- ^ Permissions update function- -> FilePath- -- ^ Path- -> io Permissions- -- ^ Updated permissions-chmod modifyPermissions path = liftIO (do- let path' = deslash (Filesystem.encodeString path)- permissions <- Directory.getPermissions path'- let permissions' = modifyPermissions permissions- changed = permissions /= permissions'- when changed (Directory.setPermissions path' permissions')- return permissions' )---- | Get a file or directory's user permissions-getmod :: MonadIO io => FilePath -> io Permissions-getmod path = liftIO (do- let path' = deslash (Filesystem.encodeString path)- Directory.getPermissions path' )---- | Set a file or directory's user permissions-setmod :: MonadIO io => Permissions -> FilePath -> io ()-setmod permissions path = liftIO (do- let path' = deslash (Filesystem.encodeString path)- Directory.setPermissions path' permissions )---- | Copy a file or directory's permissions (analogous to @chmod --reference@)-copymod :: MonadIO io => FilePath -> FilePath -> io ()-copymod sourcePath targetPath = liftIO (do- let sourcePath' = deslash (Filesystem.encodeString sourcePath)- targetPath' = deslash (Filesystem.encodeString targetPath)- Directory.copyPermissions sourcePath' targetPath' )---- | @+r@-readable :: Permissions -> Permissions-readable = Directory.setOwnerReadable True---- | @-r@-nonreadable :: Permissions -> Permissions-nonreadable = Directory.setOwnerReadable False---- | @+w@-writable :: Permissions -> Permissions-writable = Directory.setOwnerWritable True---- | @-w@-nonwritable :: Permissions -> Permissions-nonwritable = Directory.setOwnerWritable False---- | @+x@-executable :: Permissions -> Permissions-executable = Directory.setOwnerExecutable True---- | @-x@-nonexecutable :: Permissions -> Permissions-nonexecutable = Directory.setOwnerExecutable False---- | @+s@-searchable :: Permissions -> Permissions-searchable = Directory.setOwnerSearchable True---- | @-s@-nonsearchable :: Permissions -> Permissions-nonsearchable = Directory.setOwnerSearchable False---- | @-r -w -x@-ooo :: Permissions -> Permissions-ooo = const Directory.emptyPermissions---- | @+r -w -x@-roo :: Permissions -> Permissions-roo = readable . ooo---- | @-r +w -x@-owo :: Permissions -> Permissions-owo = writable . ooo---- | @-r -w +x@-oox :: Permissions -> Permissions-oox = executable . ooo---- | @-r -w +s@-oos :: Permissions -> Permissions-oos = searchable . ooo---- | @+r +w -x@-rwo :: Permissions -> Permissions-rwo = readable . writable . ooo---- | @+r -w +x@-rox :: Permissions -> Permissions-rox = readable . executable . ooo---- | @+r -w +s@-ros :: Permissions -> Permissions-ros = readable . searchable . ooo---- | @-r +w +x@-owx :: Permissions -> Permissions-owx = writable . executable . ooo---- | @+r +w +x@-rwx :: Permissions -> Permissions-rwx = readable . writable . executable . ooo---- | @+r +w +s@-rws :: Permissions -> Permissions-rws = readable . writable . searchable . ooo--{-| Time how long a command takes in monotonic wall clock time-- Returns the duration alongside the return value--}-time :: MonadIO io => io a -> io (a, NominalDiffTime)-time io = do- TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic)- a <- io- TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic)- let t = fromIntegral ( seconds2 - seconds1)- + fromIntegral (nanoseconds2 - nanoseconds1) / 10^(9::Int)- return (a, fromRational t)---- | Get the system's host name-hostname :: MonadIO io => io Text-hostname = liftIO (fmap Text.pack getHostName)--{-| Sleep for the given duration-- A numeric literal argument is interpreted as seconds. In other words,- @(sleep 2.0)@ will sleep for two seconds.--}-sleep :: MonadIO io => NominalDiffTime -> io ()-sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int))))--{-| Exit with the given exit code-- An exit code of @0@ indicates success--}-exit :: MonadIO io => ExitCode -> io a-exit code = liftIO (exitWith code)---- | Throw an exception using the provided `Text` message-die :: MonadIO io => Text -> io a-die txt = liftIO (throwIO (userError (unpack txt)))--infixr 2 .||.-infixr 3 .&&.--{-| Analogous to `&&` in Bash-- Runs the second command only if the first one returns `ExitSuccess`--}-(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode-cmd1 .&&. cmd2 = do- r <- cmd1- case r of- ExitSuccess -> cmd2- _ -> return r--{-| Analogous to `||` in Bash-- Run the second command only if the first one returns `ExitFailure`--}-(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode-cmd1 .||. cmd2 = do- r <- cmd1- case r of- ExitFailure _ -> cmd2- _ -> return r--{-| Create a temporary directory underneath the given directory-- Deletes the temporary directory when done--}-mktempdir- :: MonadManaged managed- => FilePath- -- ^ Parent directory- -> Text- -- ^ Directory name template- -> managed FilePath-mktempdir parent prefix = using (do- let parent' = Filesystem.encodeString parent- let prefix' = unpack prefix- dir' <- managed (withTempDirectory parent' prefix')- return (Filesystem.decodeString dir'))--{-| Create a temporary file underneath the given directory-- Deletes the temporary file when done-- Note that this provides the `Handle` of the file in order to avoid a- potential race condition from the file being moved or deleted before you- have a chance to open the file. The `mktempfile` function provides a- simpler API if you don't need to worry about that possibility.--}-mktemp- :: MonadManaged managed- => FilePath- -- ^ Parent directory- -> Text- -- ^ File name template- -> managed (FilePath, Handle)-mktemp parent prefix = using (do- let parent' = Filesystem.encodeString parent- let prefix' = unpack prefix- (file', handle) <- managed (\k ->- withTempFile parent' prefix' (\file' handle -> k (file', handle)) )- return (Filesystem.decodeString file', handle) )--{-| Create a temporary file underneath the given directory-- Deletes the temporary file when done--}-mktempfile- :: MonadManaged managed- => FilePath- -- ^ Parent directory- -> Text- -- ^ File name template- -> managed FilePath-mktempfile parent prefix = using (do- let parent' = Filesystem.encodeString parent- let prefix' = unpack prefix- (file', handle) <- managed (\k ->- withTempFile parent' prefix' (\file' handle -> k (file', handle)) )- liftIO (hClose handle)- return (Filesystem.decodeString file') )---- | Fork a thread, acquiring an `Async` value-fork :: MonadManaged managed => IO a -> managed (Async a)-fork io = using (managed (withAsync io))---- | Read lines of `Text` from standard input-stdin :: Shell Text-stdin = inhandle IO.stdin---- | Read lines of `Text` from a file-input :: FilePath -> Shell Text-input file = do- handle <- using (readonly file)- inhandle handle---- | Read lines of `Text` from a `Handle`-inhandle :: Handle -> Shell Text-inhandle handle = Shell (\(FoldM step begin done) -> do- x0 <- begin- let loop x = do- eof <- IO.hIsEOF handle- if eof- then done x- else do- txt <- Text.hGetLine handle- x' <- step x txt- loop $! x'- loop $! x0 )---- | Stream lines of `Text` to standard output-stdout :: MonadIO io => Shell Text -> io ()-stdout s = sh (do- txt <- s- liftIO (echo txt) )---- | Stream lines of `Text` to a file-output :: MonadIO io => FilePath -> Shell Text -> io ()-output file s = sh (do- handle <- using (writeonly file)- txt <- s- liftIO (Text.hPutStrLn handle txt) )---- | Stream lines of `Text` to a `Handle`-outhandle :: MonadIO io => Handle -> Shell Text -> io ()-outhandle handle s = sh (do- txt <- s- liftIO (Text.hPutStrLn handle txt) )---- | Stream lines of `Text` to append to a file-append :: MonadIO io => FilePath -> Shell Text -> io ()-append file s = sh (do- handle <- using (appendonly file)- txt <- s- liftIO (Text.hPutStrLn handle txt) )---- | Stream lines of `Text` to standard error-stderr :: MonadIO io => Shell Text -> io ()-stderr s = sh (do- txt <- s- liftIO (err txt) )---- | Read in a stream's contents strictly-strict :: MonadIO io => Shell Text -> io Text-strict s = liftM Text.unlines (fold s list)---- | Acquire a `Managed` read-only `Handle` from a `FilePath`-readonly :: MonadManaged managed => FilePath -> managed Handle-readonly file = using (managed (Filesystem.withTextFile file IO.ReadMode))---- | Acquire a `Managed` write-only `Handle` from a `FilePath`-writeonly :: MonadManaged managed => FilePath -> managed Handle-writeonly file = using (managed (Filesystem.withTextFile file IO.WriteMode))---- | Acquire a `Managed` append-only `Handle` from a `FilePath`-appendonly :: MonadManaged managed => FilePath -> managed Handle-appendonly file = using (managed (Filesystem.withTextFile file IO.AppendMode))---- | Combine the output of multiple `Shell`s, in order-cat :: [Shell a] -> Shell a-cat = msum---- | Keep all lines that match the given `Pattern`-grep :: Pattern a -> Shell Text -> Shell Text-grep pattern s = do- txt <- s- _:_ <- return (match pattern txt)- return txt--{-| Replace all occurrences of a `Pattern` with its `Text` result-- `sed` performs substitution on a line-by-line basis, meaning that- substitutions may not span multiple lines. Additionally, substitutions may- occur multiple times within the same line, like the behavior of- @s/.../.../g@.-- Warning: Do not use a `Pattern` that matches the empty string, since it will- match an infinite number of times. `sed` tries to detect such `Pattern`s- and `die` with an error message if they occur, but this detection is- necessarily incomplete.--}-sed :: Pattern Text -> Shell Text -> Shell Text-sed pattern s = do- when (matchesEmpty pattern) (die message)- let pattern' = fmap Text.concat- (many (pattern <|> fmap Text.singleton anyChar))- txt <- s- txt':_ <- return (match pattern' txt)- return txt'- where- message = "sed: the given pattern matches the empty string"- matchesEmpty = not . null . flip match ""---- | Like `sed`, but operates in place on a `FilePath` (analogous to @sed -i@)-inplace :: MonadIO io => Pattern Text -> FilePath -> io ()-inplace pattern file = liftIO (runManaged (do- here <- pwd- (tmpfile, handle) <- mktemp here "turtle"- outhandle handle (sed pattern (input file))- liftIO (hClose handle)- copymod file tmpfile- mv tmpfile file ))----- | Search a directory recursively for all files matching the given `Pattern`-find :: Pattern a -> FilePath -> Shell FilePath-find pattern dir = do- path <- lstree dir- Right txt <- return (Filesystem.toText path)- _:_ <- return (match pattern txt)- return path---- | A Stream of @\"y\"@s-yes :: Shell Text-yes = fmap (\_ -> "y") endless---- | Number each element of a `Shell` (starting at 0)-nl :: Num n => Shell a -> Shell (n, a)-nl s = Shell _foldIO'- where- _foldIO' (FoldM step begin done) = _foldIO s (FoldM step' begin' done')- where- step' (x, n) a = do- x' <- step x (n, a)- let n' = n + 1- n' `seq` return (x', n')- begin' = do- x0 <- begin- return (x0, 0)- done' (x, _) = done x--data ZipState a b = Empty | HasA a | HasAB a b | Done--{-| Merge two `Shell`s together, element-wise-- If one `Shell` is longer than the other, the excess elements are- truncated--}-paste :: Shell a -> Shell b -> Shell (a, b)-paste sA sB = Shell _foldIOAB- where- _foldIOAB (FoldM stepAB beginAB doneAB) = do- x0 <- beginAB-- tvar <- STM.atomically (STM.newTVar Empty)-- let begin = return ()-- let stepA () a = STM.atomically (do- x <- STM.readTVar tvar- case x of- Empty -> STM.writeTVar tvar (HasA a)- Done -> return ()- _ -> STM.retry )- let doneA () = STM.atomically (do- x <- STM.readTVar tvar- case x of- Empty -> STM.writeTVar tvar Done- Done -> return ()- _ -> STM.retry )- let foldA = FoldM stepA begin doneA-- let stepB () b = STM.atomically (do- x <- STM.readTVar tvar- case x of- HasA a -> STM.writeTVar tvar (HasAB a b)- Done -> return ()- _ -> STM.retry )- let doneB () = STM.atomically (do- x <- STM.readTVar tvar- case x of- HasA _ -> STM.writeTVar tvar Done- Done -> return ()- _ -> STM.retry )- let foldB = FoldM stepB begin doneB-- withAsync (foldIO sA foldA) (\asyncA -> do- withAsync (foldIO sB foldB) (\asyncB -> do- let loop x = do- y <- STM.atomically (do- z <- STM.readTVar tvar- case z of- HasAB a b -> do- STM.writeTVar tvar Empty- return (Just (a, b))- Done -> return Nothing- _ -> STM.retry )- case y of- Nothing -> return x- Just ab -> do- x' <- stepAB x ab- loop $! x'- x' <- loop $! x0- wait asyncA- wait asyncB- doneAB x' ) )---- | A `Shell` that endlessly emits @()@-endless :: Shell ()-endless = Shell (\(FoldM step begin _) -> do- x0 <- begin- let loop x = do- x' <- step x ()- loop $! x'- loop $! x0 )---- | Limit a `Shell` to a fixed number of values-limit :: Int -> Shell a -> Shell a-limit n s = Shell (\(FoldM step begin done) -> do- ref <- newIORef 0 -- I feel so dirty- let step' x a = do- n' <- readIORef ref- writeIORef ref (n' + 1)- if n' < n then step x a else return x- foldIO s (FoldM step' begin done) )--{-| Limit a `Shell` to values that satisfy the predicate-- This terminates the stream on the first value that does not satisfy the- predicate--}-limitWhile :: (a -> Bool) -> Shell a -> Shell a-limitWhile predicate s = Shell (\(FoldM step begin done) -> do- ref <- newIORef True- let step' x a = do- b <- readIORef ref- let b' = b && predicate a- writeIORef ref b'- if b' then step x a else return x- foldIO s (FoldM step' begin done) )--{-| Cache a `Shell`'s output so that repeated runs of the script will reuse the- result of previous runs. You must supply a `FilePath` where the cached- result will be stored.-- The stored result is only reused if the `Shell` successfully ran to- completion without any exceptions. Note: on some platforms Ctrl-C will- flush standard input and signal end of file before killing the program,- which may trick the program into \"successfully\" completing.--}-cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a-cache file s = do- let cached = do- txt <- input file- case reads (Text.unpack txt) of- [(ma, "")] -> return ma- _ ->- die (format ("cache: Invalid data stored in "%w) file)- exists <- testfile file- mas <- fold (if exists then cached else empty) list- case [ () | Nothing <- mas ] of- _:_ -> select [ a | Just a <- mas ]- _ -> do- handle <- using (writeonly file)- let justs = do- a <- s- liftIO (Text.hPutStrLn handle (Text.pack (show (Just a))))- return a- let nothing = do- let n = Nothing :: Maybe ()- liftIO (Text.hPutStrLn handle (Text.pack (show n)))- empty- justs <|> nothing---- | Split a line into chunks delimited by the given `Pattern`-cut :: Pattern a -> Text -> [Text]-cut pattern txt = head (match (selfless chars `sepBy` pattern) txt)--- This `head` should be safe ... in theory---- | Get the current time-date :: MonadIO io => io UTCTime-date = liftIO getCurrentTime---- | Get the time a file was last modified-datefile :: MonadIO io => FilePath -> io UTCTime-datefile path = liftIO (Filesystem.getModified path)---- | Get the size of a file or a directory-du :: MonadIO io => FilePath -> io Size-du path = liftIO (fmap Size (Filesystem.getSize path))--{-| An abstract file size-- Specify the units you want by using an accessor like `kilobytes`-- The `Num` instance for `Size` interprets numeric literals as bytes--}-newtype Size = Size { _bytes :: Integer } deriving (Eq, Ord, Num)--instance Show Size where- show = show . _bytes--{-| `Format` a `Size` using a human readable representation-->>> format sz 42-"42 B"->>> format sz 2309-"2.309 KB"->>> format sz 949203-"949.203 MB"->>> format sz 1600000000-"1.600 GB"->>> format sz 999999999999999999-"999999.999 TB"--}-sz :: Format r (Size -> r)-sz = makeFormat (\(Size numBytes) ->- let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000- (numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000- (numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000- (numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000- in if numKilobytes <= 0- then format (d%" B" ) remainingBytes- else if numMegabytes == 0- then format (d%"."%d%" KB") remainingKilobytes remainingBytes- else if numGigabytes == 0- then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes- else if numTerabytes == 0- then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes- else format (d%"."%d%" TB") numTerabytes remainingGigabytes )---- | Extract a size in bytes-bytes :: Integral n => Size -> n-bytes = fromInteger . _bytes---- | @1 kilobyte = 1000 bytes@-kilobytes :: Integral n => Size -> n-kilobytes = (`div` 1000) . bytes---- | @1 megabyte = 1000 kilobytes@-megabytes :: Integral n => Size -> n-megabytes = (`div` 1000) . kilobytes---- | @1 gigabyte = 1000 megabytes@-gigabytes :: Integral n => Size -> n-gigabytes = (`div` 1000) . megabytes---- | @1 terabyte = 1000 gigabytes@-terabytes :: Integral n => Size -> n-terabytes = (`div` 1000) . gigabytes---- | @1 kibibyte = 1024 bytes@-kibibytes :: Integral n => Size -> n-kibibytes = (`div` 1024) . bytes---- | @1 mebibyte = 1024 kibibytes@-mebibytes :: Integral n => Size -> n-mebibytes = (`div` 1024) . kibibytes---- | @1 gibibyte = 1024 mebibytes@-gibibytes :: Integral n => Size -> n-gibibytes = (`div` 1024) . mebibytes---- | @1 tebibyte = 1024 gibibytes@-tebibytes :: Integral n => Size -> n-tebibytes = (`div` 1024) . gibibytes--{-| Count the number of characters in the stream (like @wc -c@)-- This uses the convention that the elements of the stream are implicitly- ended by newlines that are one character wide--}-countChars :: Integral n => Fold Text n-countChars = Control.Foldl.Text.length + charsPerNewline * countLines--charsPerNewline :: Num a => a-#ifdef mingw32_HOST_OS-charsPerNewline = 2-#else-charsPerNewline = 1-#endif---- | Count the number of words in the stream (like @wc -w@)-countWords :: Integral n => Fold Text n-countWords = premap Text.words (handles traverse genericLength)--{-| Count the number of lines in the stream (like @wc -l@)-- This uses the convention that each element of the stream represents one- line--}-countLines :: Integral n => Fold Text n-countLines = genericLength+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | This module provides a large suite of utilities that resemble Unix+-- utilities.+--+-- Many of these commands are just existing Haskell commands renamed to match+-- their Unix counterparts:+--+-- >>> :set -XOverloadedStrings+-- >>> cd "/tmp"+-- >>> pwd+-- FilePath "/tmp"+--+-- Some commands are `Shell`s that emit streams of values. `view` prints all+-- values in a `Shell` stream:+--+-- >>> view (ls "/usr")+-- FilePath "/usr/lib"+-- FilePath "/usr/src"+-- FilePath "/usr/sbin"+-- FilePath "/usr/include"+-- FilePath "/usr/share"+-- FilePath "/usr/games"+-- FilePath "/usr/local"+-- FilePath "/usr/bin"+-- >>> view (find (suffix "Browser.py") "/usr/lib")+-- FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py"+-- FilePath "/usr/lib/python3.4/idlelib/RemoteObjectBrowser.py"+-- FilePath "/usr/lib/python3.4/idlelib/PathBrowser.py"+-- FilePath "/usr/lib/python3.4/idlelib/ObjectBrowser.py"+--+-- Use `fold` to reduce the output of a `Shell` stream:+--+-- >>> import qualified Control.Foldl as Fold+-- >>> fold (ls "/usr") Fold.length+-- 8+-- >>> fold (find (suffix "Browser.py") "/usr/lib") Fold.head+-- Just (FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py")+--+-- Create files using `output`:+--+-- >>> output "foo.txt" ("123" <|> "456" <|> "ABC")+-- >>> realpath "foo.txt"+-- FilePath "/tmp/foo.txt"+--+-- Read in files using `input`:+--+-- >>> stdout (input "foo.txt")+-- 123+-- 456+-- ABC+--+-- Format strings in a type safe way using `format`:+--+-- >>> dir <- pwd+-- >>> format ("I am in the "%fp%" directory") dir+-- "I am in the /tmp directory"+--+-- Commands like `grep`, `sed` and `find` accept arbitrary `Pattern`s+--+-- >>> stdout (grep ("123" <|> "ABC") (input "foo.txt"))+-- 123+-- ABC+-- >>> let exclaim = fmap (<> "!") (plus digit)+-- >>> stdout (sed exclaim (input "foo.txt"))+-- 123!+-- 456!+-- ABC+--+-- Note that `grep` and `find` differ from their Unix counterparts by requiring+-- that the `Pattern` matches the entire line or file name by default. However,+-- you can optionally match the prefix, suffix, or interior of a line:+--+-- >>> stdout (grep (has "2") (input "foo.txt"))+-- 123+-- >>> stdout (grep (prefix "1") (input "foo.txt"))+-- 123+-- >>> stdout (grep (suffix "3") (input "foo.txt"))+-- 123+--+-- You can also build up more sophisticated `Shell` programs using `sh` in+-- conjunction with @do@ notation:+--+-- >{-# LANGUAGE OverloadedStrings #-}+-- >+-- >import Turtle+-- >+-- >main = sh example+-- >+-- >example = do+-- > -- Read in file names from "files1.txt" and "files2.txt"+-- > file <- fmap fromText (input "files1.txt" <|> input "files2.txt")+-- >+-- > -- Stream each file to standard output only if the file exists+-- > True <- liftIO (testfile file)+-- > line <- input file+-- > liftIO (echo line)+--+-- See "Turtle.Tutorial" for an extended tutorial explaining how to use this+-- library in greater detail.++module Turtle.Prelude (+ -- * IO+ echo+ , err+ , readline+ , Internal.readTextFile+ , Internal.writeTextFile+ , arguments+#if __GLASGOW_HASKELL__ >= 710+ , export+ , unset+#endif+ , need+ , env+ , cd+ , pwd+ , home+ , readlink+ , realpath+ , mv+ , mkdir+ , mktree+ , cp+ , cptree+ , cptreeL+#if !defined(mingw32_HOST_OS)+ , symlink+#endif+ , isNotSymbolicLink+ , rm+ , rmdir+ , rmtree+ , testfile+ , testdir+ , testpath+ , date+ , datefile+ , touch+ , time+ , hostname+ , which+ , whichAll+ , sleep+ , exit+ , die+ , (.&&.)+ , (.||.)++ -- * Managed+ , readonly+ , writeonly+ , appendonly+ , mktemp+ , mktempfile+ , mktempdir+ , fork+ , wait+ , pushd++ -- * Shell+ , stdin+ , input+ , inhandle+ , stdout+ , output+ , outhandle+ , append+ , stderr+ , strict+ , ls+ , lsif+ , lstree+ , lsdepth+ , cat+ , grep+ , grepText+ , sed+ , sedPrefix+ , sedSuffix+ , sedEntire+ , onFiles+ , inplace+ , inplacePrefix+ , inplaceSuffix+ , inplaceEntire+ , update+ , find+ , findtree+ , yes+ , nl+ , paste+ , endless+ , limit+ , limitWhile+ , cache+ , parallel+ , single+ , uniq+ , uniqOn+ , uniqBy+ , nub+ , nubOn+ , sort+ , sortOn+ , sortBy+ , toLines++ -- * Folds+ , countChars+ , countWords+ , countLines++ -- * Text+ , cut++ -- * Subprocess management+ , proc+ , shell+ , procs+ , shells+ , inproc+ , inshell+ , inprocWithErr+ , inshellWithErr+ , procStrict+ , shellStrict+ , procStrictWithErr+ , shellStrictWithErr++ , system+ , stream+ , streamWithErr+ , systemStrict+ , systemStrictWithErr++ -- * Permissions+ , Permissions(..)+ , chmod+ , getmod+ , setmod+ , copymod+ , readable, nonreadable+ , writable, nonwritable+ , executable, nonexecutable+ , ooo,roo,owo,oox,rwo,rox,owx,rwx++ -- * File size+ , du+ , Size(B, KB, MB, GB, TB, KiB, MiB, GiB, TiB)+ , sz+ , bytes+ , kilobytes+ , megabytes+ , gigabytes+ , terabytes+ , kibibytes+ , mebibytes+ , gibibytes+ , tebibytes++ -- * File status+ , PosixCompat.FileStatus+ , stat+ , lstat+ , fileSize+ , accessTime+ , modificationTime+ , statusChangeTime+ , PosixCompat.isBlockDevice+ , PosixCompat.isCharacterDevice+ , PosixCompat.isNamedPipe+ , PosixCompat.isRegularFile+ , PosixCompat.isDirectory+ , PosixCompat.isSymbolicLink+ , PosixCompat.isSocket+ , cmin+ , cmax++ -- * Headers+ , WithHeader(..)+ , header++ -- * Exceptions+ , ProcFailed(..)+ , ShellFailed(..)+ ) where++import Control.Applicative+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async+ (Async, withAsync, waitSTM, concurrently,+ Concurrently(..))+import qualified Control.Concurrent.Async+import Control.Concurrent.MVar (newMVar, modifyMVar_)+import qualified Control.Concurrent.STM as STM+import qualified Control.Concurrent.STM.TQueue as TQueue+import Control.Exception (Exception, bracket, bracket_, finally, mask, throwIO)+import Control.Foldl (Fold(..), genericLength, handles, list, premap)+import qualified Control.Foldl+import qualified Control.Foldl.Text+import Control.Monad (foldM, guard, liftM, msum, when, unless, (>=>), mfilter)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Managed (MonadManaged(..), managed, managed_, runManaged)+#ifdef mingw32_HOST_OS+import Data.Bits ((.&.))+#endif+import Data.IORef (newIORef, readIORef, writeIORef)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Monoid ((<>))+import Data.Ord (comparing)+import qualified Data.Set as Set+import Data.Text (Text, pack, unpack)+import Data.Time (NominalDiffTime, UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)+import Data.Traversable+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Typeable (Typeable)+import GHC.IO.Exception (IOErrorType(UnsupportedOperation))+import Network.HostName (getHostName)+import System.Clock (Clock(..), TimeSpec(..), getTime)+import System.Environment (+ getArgs,+#if __GLASGOW_HASKELL__ >= 710+ setEnv,+ unsetEnv,+#endif+#if __GLASGOW_HASKELL__ >= 708+ lookupEnv,+#endif+ getEnvironment )+import qualified System.Directory as Directory+import System.FilePath ((</>))+import qualified System.FilePath as FilePath+import System.Exit (ExitCode(..), exitWith)+import System.IO (Handle, hClose)+import qualified System.IO as IO+import System.IO.Temp (withTempDirectory, withTempFile)+import System.IO.Error+ (catchIOError, ioeGetErrorType, isPermissionError, isDoesNotExistError)+import qualified System.PosixCompat as PosixCompat+import qualified System.Process as Process+#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import System.Posix (+ openDirStream,+ readDirStream,+ closeDirStream,+ touchFile )+import System.Posix.Files (createSymbolicLink) +#endif+import Prelude hiding (lines)++import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy)+import Turtle.Shell+import Turtle.Format (Format, format, makeFormat, d, w, (%), fp)+import qualified Turtle.Internal as Internal+import Turtle.Line++{-| Run a command using @execvp@, retrieving the exit code++ The command inherits @stdout@ and @stderr@ for the current process+-}+proc+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell Line+ -- ^ Lines of standard input+ -> io ExitCode+ -- ^ Exit code+proc cmd args =+ system+ ( (Process.proc (unpack cmd) (map unpack args))+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.Inherit+ , Process.std_err = Process.Inherit+ } )++{-| Run a command line using the shell, retrieving the exit code++ This command is more powerful than `proc`, but highly vulnerable to code+ injection if you template the command line with untrusted input++ The command inherits @stdout@ and @stderr@ for the current process+-}+shell+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell Line+ -- ^ Lines of standard input+ -> io ExitCode+ -- ^ Exit code+shell cmdLine =+ system+ ( (Process.shell (unpack cmdLine))+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.Inherit+ , Process.std_err = Process.Inherit+ } )++data ProcFailed = ProcFailed+ { procCommand :: Text+ , procArguments :: [Text]+ , procExitCode :: ExitCode+ } deriving (Show, Typeable)++instance Exception ProcFailed++{-| This function is identical to `proc` except this throws `ProcFailed` for+ non-zero exit codes+-}+procs+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell Line+ -- ^ Lines of standard input+ -> io ()+procs cmd args s = do+ exitCode <- proc cmd args s+ case exitCode of+ ExitSuccess -> return ()+ _ -> liftIO (throwIO (ProcFailed cmd args exitCode))++data ShellFailed = ShellFailed+ { shellCommandLine :: Text+ , shellExitCode :: ExitCode+ } deriving (Show, Typeable)++instance Exception ShellFailed++{-| This function is identical to `shell` except this throws `ShellFailed` for+ non-zero exit codes+-}+shells+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell Line+ -- ^ Lines of standard input+ -> io ()+ -- ^ Exit code+shells cmdline s = do+ exitCode <- shell cmdline s+ case exitCode of+ ExitSuccess -> return ()+ _ -> liftIO (throwIO (ShellFailed cmdline exitCode))++{-| Run a command using @execvp@, retrieving the exit code and stdout as a+ non-lazy blob of Text++ The command inherits @stderr@ for the current process+-}+procStrict+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell Line+ -- ^ Lines of standard input+ -> io (ExitCode, Text)+ -- ^ Exit code and stdout+procStrict cmd args =+ systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args))++{-| Run a command line using the shell, retrieving the exit code and stdout as a+ non-lazy blob of Text++ This command is more powerful than `proc`, but highly vulnerable to code+ injection if you template the command line with untrusted input++ The command inherits @stderr@ for the current process+-}+shellStrict+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell Line+ -- ^ Lines of standard input+ -> io (ExitCode, Text)+ -- ^ Exit code and stdout+shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine))++{-| Run a command using @execvp@, retrieving the exit code, stdout, and stderr+ as a non-lazy blob of Text+-}+procStrictWithErr+ :: MonadIO io+ => Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell Line+ -- ^ Lines of standard input+ -> io (ExitCode, Text, Text)+ -- ^ (Exit code, stdout, stderr)+procStrictWithErr cmd args =+ systemStrictWithErr (Process.proc (Text.unpack cmd) (map Text.unpack args))++{-| Run a command line using the shell, retrieving the exit code, stdout, and+ stderr as a non-lazy blob of Text++ This command is more powerful than `proc`, but highly vulnerable to code+ injection if you template the command line with untrusted input+-}+shellStrictWithErr+ :: MonadIO io+ => Text+ -- ^ Command line+ -> Shell Line+ -- ^ Lines of standard input+ -> io (ExitCode, Text, Text)+ -- ^ (Exit code, stdout, stderr)+shellStrictWithErr cmdLine =+ systemStrictWithErr (Process.shell (Text.unpack cmdLine))++-- | Halt an `Async` thread, re-raising any exceptions it might have thrown+halt :: Async a -> IO ()+halt a = do+ m <- Control.Concurrent.Async.poll a+ case m of+ Nothing -> Control.Concurrent.Async.cancel a+ Just (Left e) -> throwIO e+ Just (Right _) -> return ()++{-| `system` generalizes `shell` and `proc` by allowing you to supply your own+ custom `CreateProcess`. This is for advanced users who feel comfortable+ using the lower-level @process@ API+-}+system+ :: MonadIO io+ => Process.CreateProcess+ -- ^ Command+ -> Shell Line+ -- ^ Lines of standard input+ -> io ExitCode+ -- ^ Exit code+system p s = liftIO (do+ let open = do+ (m, Nothing, Nothing, ph) <- Process.createProcess p+ case m of+ Just hIn -> IO.hSetBuffering hIn IO.LineBuffering+ _ -> return ()+ return (m, ph)++ -- Prevent double close+ mvar <- newMVar False+ let close handle = do+ modifyMVar_ mvar (\finalized -> do+ unless finalized (Internal.ignoreSIGPIPE (hClose handle))+ return True )+ let close' (Just hIn, ph) = do+ close hIn+ Process.terminateProcess ph+ close' (Nothing , ph) = do+ Process.terminateProcess ph++ let handle (Just hIn, ph) = do+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn+ mask (\restore ->+ withAsync (feedIn restore) (\a ->+ restore (Process.waitForProcess ph) `finally` halt a) )+ handle (Nothing , ph) = do+ Process.waitForProcess ph++ bracket open close' handle )+++{-| `systemStrict` generalizes `shellStrict` and `procStrict` by allowing you to+ supply your own custom `CreateProcess`. This is for advanced users who feel+ comfortable using the lower-level @process@ API+-}+systemStrict+ :: MonadIO io+ => Process.CreateProcess+ -- ^ Command+ -> Shell Line+ -- ^ Lines of standard input+ -> io (ExitCode, Text)+ -- ^ Exit code and stdout+systemStrict p s = liftIO (do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.Inherit+ }++ let open = do+ (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')+ IO.hSetBuffering hIn IO.LineBuffering+ return (hIn, hOut, ph)++ -- Prevent double close+ mvar <- newMVar False+ let close handle = do+ modifyMVar_ mvar (\finalized -> do+ unless finalized (Internal.ignoreSIGPIPE (hClose handle))+ return True )++ bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn++ concurrently+ (mask (\restore ->+ withAsync (feedIn restore) (\a ->+ restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) ))+ (Text.hGetContents hOut) ) )++{-| `systemStrictWithErr` generalizes `shellStrictWithErr` and+ `procStrictWithErr` by allowing you to supply your own custom+ `CreateProcess`. This is for advanced users who feel comfortable using+ the lower-level @process@ API+-}+systemStrictWithErr+ :: MonadIO io+ => Process.CreateProcess+ -- ^ Command+ -> Shell Line+ -- ^ Lines of standard input+ -> io (ExitCode, Text, Text)+ -- ^ Exit code and stdout+systemStrictWithErr p s = liftIO (do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.CreatePipe+ }++ let open = do+ (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')+ IO.hSetBuffering hIn IO.LineBuffering+ return (hIn, hOut, hErr, ph)++ -- Prevent double close+ mvar <- newMVar False+ let close handle = do+ modifyMVar_ mvar (\finalized -> do+ unless finalized (Internal.ignoreSIGPIPE (hClose handle))+ return True )++ bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, hErr, ph) -> do+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore =+ restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn++ runConcurrently $ (,,)+ <$> Concurrently (mask (\restore ->+ withAsync (feedIn restore) (\a ->+ restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) ))+ <*> Concurrently (Text.hGetContents hOut)+ <*> Concurrently (Text.hGetContents hErr) ) )++{-| Run a command using @execvp@, streaming @stdout@ as lines of `Text`++ The command inherits @stderr@ for the current process+-}+inproc+ :: Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell Line+ -- ^ Lines of standard input+ -> Shell Line+ -- ^ Lines of standard output+inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args))++{-| Run a command line using the shell, streaming @stdout@ as lines of `Text`++ This command is more powerful than `inproc`, but highly vulnerable to code+ injection if you template the command line with untrusted input++ The command inherits @stderr@ for the current process++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+inshell+ :: Text+ -- ^ Command line+ -> Shell Line+ -- ^ Lines of standard input+ -> Shell Line+ -- ^ Lines of standard output+inshell cmd = stream (Process.shell (unpack cmd))++waitForProcessThrows :: Process.ProcessHandle -> IO ()+waitForProcessThrows ph = do+ exitCode <- Process.waitForProcess ph+ case exitCode of+ ExitSuccess -> return ()+ ExitFailure _ -> Control.Exception.throwIO exitCode++{-| `stream` generalizes `inproc` and `inshell` by allowing you to supply your+ own custom `CreateProcess`. This is for advanced users who feel comfortable+ using the lower-level @process@ API++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+stream+ :: Process.CreateProcess+ -- ^ Command+ -> Shell Line+ -- ^ Lines of standard input+ -> Shell Line+ -- ^ Lines of standard output+stream p s = do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.Inherit+ }++ let open = do+ (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')+ IO.hSetBuffering hIn IO.LineBuffering+ return (hIn, hOut, ph)++ -- Prevent double close+ mvar <- liftIO (newMVar False)+ let close handle = do+ modifyMVar_ mvar (\finalized -> do+ unless finalized (Internal.ignoreSIGPIPE (hClose handle))+ return True )++ (hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph)))+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore = restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn++ a <- using+ (managed (\k ->+ mask (\restore -> withAsync (feedIn restore) (restore . k))))+ inhandle hOut <|> (liftIO (waitForProcessThrows ph *> halt a) *> empty)++{-| `streamWithErr` generalizes `inprocWithErr` and `inshellWithErr` by allowing+ you to supply your own custom `CreateProcess`. This is for advanced users+ who feel comfortable using the lower-level @process@ API++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+streamWithErr+ :: Process.CreateProcess+ -- ^ Command+ -> Shell Line+ -- ^ Lines of standard input+ -> Shell (Either Line Line)+ -- ^ Lines of standard output+streamWithErr p s = do+ let p' = p+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.CreatePipe+ }++ let open = do+ (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')+ IO.hSetBuffering hIn IO.LineBuffering+ return (hIn, hOut, hErr, ph)++ -- Prevent double close+ mvar <- liftIO (newMVar False)+ let close handle = do+ modifyMVar_ mvar (\finalized -> do+ unless finalized (Internal.ignoreSIGPIPE (hClose handle))+ return True )++ (hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph)))+ let feedIn :: (forall a. IO a -> IO a) -> IO ()+ feedIn restore = restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn++ queue <- liftIO TQueue.newTQueueIO+ let forwardOut :: (forall a. IO a -> IO a) -> IO ()+ forwardOut restore =+ restore (sh (do+ line <- inhandle hOut+ liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right line)))) ))+ `finally` STM.atomically (TQueue.writeTQueue queue Nothing)+ let forwardErr :: (forall a. IO a -> IO a) -> IO ()+ forwardErr restore =+ restore (sh (do+ line <- inhandle hErr+ liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left line)))) ))+ `finally` STM.atomically (TQueue.writeTQueue queue Nothing)+ let drain = Shell (\(FoldShell step begin done) -> do+ let loop x numNothing+ | numNothing < 2 = do+ m <- STM.atomically (TQueue.readTQueue queue)+ case m of+ Nothing -> loop x $! numNothing + 1+ Just e -> do+ x' <- step x e+ loop x' numNothing+ | otherwise = return x+ x1 <- loop begin (0 :: Int)+ done x1 )++ a <- using+ (managed (\k ->+ mask (\restore -> withAsync (feedIn restore) (restore . k)) ))+ b <- using+ (managed (\k ->+ mask (\restore -> withAsync (forwardOut restore) (restore . k)) ))+ c <- using+ (managed (\k ->+ mask (\restore -> withAsync (forwardErr restore) (restore . k)) ))+ let l `also` r = do+ _ <- l <|> (r *> STM.retry)+ _ <- r+ return ()+ let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c))+ drain <|> (liftIO (waitForProcessThrows ph *> waitAll) *> empty)++{-| Run a command using the shell, streaming @stdout@ and @stderr@ as lines of+ `Text`. Lines from @stdout@ are wrapped in `Right` and lines from @stderr@+ are wrapped in `Left`.++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+inprocWithErr+ :: Text+ -- ^ Command+ -> [Text]+ -- ^ Arguments+ -> Shell Line+ -- ^ Lines of standard input+ -> Shell (Either Line Line)+ -- ^ Lines of either standard output (`Right`) or standard error (`Left`)+inprocWithErr cmd args =+ streamWithErr (Process.proc (unpack cmd) (map unpack args))++{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as lines+ of `Text`. Lines from @stdout@ are wrapped in `Right` and lines from+ @stderr@ are wrapped in `Left`.++ This command is more powerful than `inprocWithErr`, but highly vulnerable to+ code injection if you template the command line with untrusted input++ Throws an `ExitCode` exception if the command returns a non-zero exit code+-}+inshellWithErr+ :: Text+ -- ^ Command line+ -> Shell Line+ -- ^ Lines of standard input+ -> Shell (Either Line Line)+ -- ^ Lines of either standard output (`Right`) or standard error (`Left`)+inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd))++{-| Print exactly one line to @stdout@++ To print more than one line see `Turtle.Format.printf`, which also supports+ formatted output+-}+echo :: MonadIO io => Line -> io ()+echo line = liftIO (Text.putStrLn (lineToText line))++-- | Print exactly one line to @stderr@+err :: MonadIO io => Line -> io ()+err line = liftIO (Text.hPutStrLn IO.stderr (lineToText line))++{-| Read in a line from @stdin@++ Returns `Nothing` if at end of input+-}+readline :: MonadIO io => io (Maybe Line)+readline = liftIO (do+ eof <- IO.isEOF+ if eof+ then return Nothing+ else fmap (Just . unsafeTextToLine . pack) getLine )++-- | Get command line arguments in a list+arguments :: MonadIO io => io [Text]+arguments = liftIO (fmap (map pack) getArgs)++#if __GLASGOW_HASKELL__ >= 710+{-| Set or modify an environment variable++ Note: This will change the current environment for all of your program's+ threads since this modifies the global state of the process+-}+export :: MonadIO io => Text -> Text -> io ()+export key val = liftIO (setEnv (unpack key) (unpack val))++-- | Delete an environment variable+unset :: MonadIO io => Text -> io ()+unset key = liftIO (unsetEnv (unpack key))+#endif++-- | Look up an environment variable+need :: MonadIO io => Text -> io (Maybe Text)+#if __GLASGOW_HASKELL__ >= 708+need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key)))+#else+need key = liftM (lookup key) env+#endif++-- | Retrieve all environment variables+env :: MonadIO io => io [(Text, Text)]+env = liftIO (fmap (fmap toTexts) getEnvironment)+ where+ toTexts (key, val) = (pack key, pack val)++{-| Change the current directory++ Note: This will change the current directory for all of your program's+ threads since this modifies the global state of the process+-}+cd :: MonadIO io => FilePath -> io ()+cd path = liftIO (Directory.setCurrentDirectory path)++{-| Change the current directory. Once the current 'Shell' is done, it returns+back to the original directory.++>>> :set -XOverloadedStrings+>>> cd "/"+>>> view (pushd "/tmp" >> pwd)+FilePath "/tmp"+>>> pwd+FilePath "/"+-}+pushd :: MonadManaged managed => FilePath -> managed ()+pushd path = do+ cwd <- pwd+ using (managed_ (bracket_ (cd path) (cd cwd)))++-- | Get the current directory+pwd :: MonadIO io => io FilePath+pwd = liftIO Directory.getCurrentDirectory++-- | Get the home directory+home :: MonadIO io => io FilePath+home = liftIO Directory.getHomeDirectory++-- | Get the path pointed to by a symlink+readlink :: MonadIO io => FilePath -> io FilePath+readlink path = liftIO (Directory.getSymbolicLinkTarget path)++-- | Canonicalize a path+realpath :: MonadIO io => FilePath -> io FilePath+realpath path = liftIO (Directory.canonicalizePath path)++#ifdef mingw32_HOST_OS+fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag+fILE_ATTRIBUTE_REPARSE_POINT = 1024++reparsePoint :: Win32.FileAttributeOrFlag -> Bool+reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0+#endif++{-| Stream all immediate children of the given directory, excluding @\".\"@ and+ @\"..\"@+-}+ls :: FilePath -> Shell FilePath+ls path = Shell (\(FoldShell step begin done) -> do+ let path' = path+ canRead <- fmap+ Directory.readable+ (Directory.getPermissions (deslash path'))+#ifdef mingw32_HOST_OS+ reparse <- fmap reparsePoint (Win32.getFileAttributes path')+ if (canRead && not reparse)+ then bracket+ (Win32.findFirstFile (path </> "*"))+ (\(h, _) -> Win32.findClose h)+ (\(h, fdat) -> do+ let loop x = do+ file <- Win32.getFindDataFileName fdat+ x' <- if (file /= "." && file /= "..")+ then step x (path </> file)+ else return x+ more <- Win32.findNextFile h fdat+ if more then loop $! x' else done x'+ loop $! begin )+ else done begin )+#else+ if canRead+ then bracket (openDirStream path') closeDirStream (\dirp -> do+ let loop x = do+ file <- readDirStream dirp+ case file of+ "" -> done x+ _ -> do+ x' <- if (file /= "." && file /= "..")+ then step x (path </> file)+ else return x+ loop $! x'+ loop $! begin )+ else done begin )+#endif++{-| This is used to remove the trailing slash from a path, because+ `getPermissions` will fail if a path ends with a trailing slash+-}+deslash :: String -> String+deslash [] = []+deslash (c0:cs0) = c0:go cs0+ where+ go [] = []+ go ['\\'] = []+ go (c:cs) = c:go cs++-- | Stream all recursive descendents of the given directory+lstree :: FilePath -> Shell FilePath+lstree path = do+ child <- ls path+ isDir <- testdir child+ if isDir+ then return child <|> lstree child+ else return child+++{- | Stream the recursive descendents of a given directory+ between a given minimum and maximum depth+-}+lsdepth :: Int -> Int -> FilePath -> Shell FilePath+lsdepth mn mx path =+ lsdepthHelper 1 mn mx path+ where+ lsdepthHelper :: Int -> Int -> Int -> FilePath -> Shell FilePath+ lsdepthHelper depth l u p = + if depth > u+ then empty+ else do+ child <- ls p+ isDir <- testdir child+ if isDir+ then if depth >= l+ then return child <|> lsdepthHelper (depth + 1) l u child+ else lsdepthHelper (depth + 1) l u child+ else if depth >= l+ then return child+ else empty++{-| Stream all recursive descendents of the given directory++ This skips any directories that fail the supplied predicate++> lstree = lsif (\_ -> return True)+-}+lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath+lsif predicate path = do+ child <- ls path+ isDir <- testdir child+ if isDir+ then do+ continue <- liftIO (predicate child)+ if continue+ then return child <|> lsif predicate child+ else return child+ else return child++{-| Move a file or directory++ Works if the two paths are on the same filesystem.+ If not, @mv@ will still work when dealing with a regular file,+ but the operation will not be atomic+-}+mv :: MonadIO io => FilePath -> FilePath -> io ()+mv oldPath newPath = liftIO $ catchIOError (Directory.renameFile oldPath newPath)+ (\ioe -> if ioeGetErrorType ioe == UnsupportedOperation -- certainly EXDEV+ then do+ Directory.copyFile oldPath newPath+ Directory.removeFile oldPath+ else ioError ioe)++{-| Create a directory++ Fails if the directory is present+-}+mkdir :: MonadIO io => FilePath -> io ()+mkdir path = liftIO (Directory.createDirectory path)++{-| Create a directory tree (equivalent to @mkdir -p@)++ Does not fail if the directory is present+-}+mktree :: MonadIO io => FilePath -> io ()+mktree path = liftIO (Directory.createDirectoryIfMissing True path)++-- | Copy a file+cp :: MonadIO io => FilePath -> FilePath -> io ()+cp oldPath newPath = liftIO (Directory.copyFile oldPath newPath)++#if !defined(mingw32_HOST_OS)+-- | Create a symlink from one @FilePath@ to another+symlink :: MonadIO io => FilePath -> FilePath -> io ()+symlink a b = liftIO $ createSymbolicLink (fp2fp a) (fp2fp b)+ where+ fp2fp = unpack . format fp + +#endif++{-| Returns `True` if the given `FilePath` is not a symbolic link++ This comes in handy in conjunction with `lsif`:++ > lsif isNotSymbolicLink+-}+isNotSymbolicLink :: MonadIO io => FilePath -> io Bool+isNotSymbolicLink = fmap (not . PosixCompat.isSymbolicLink) . lstat++-- | Copy a directory tree and preserve symbolic links+cptree :: MonadIO io => FilePath -> FilePath -> io ()+cptree oldTree newTree = sh (do+ oldPath <- lsif isNotSymbolicLink oldTree++ -- The `system-filepath` library treats a path like "/tmp" as a file and not+ -- a directory and fails to strip it as a prefix from `/tmp/foo`. Adding+ -- `(</> "")` to the end of the path makes clear that the path is a+ -- directory+ Just suffix <- return (Internal.stripPrefix (oldTree <> [ FilePath.pathSeparator ]) oldPath)++ let newPath = newTree </> suffix++ isFile <- testfile oldPath++ fileStatus <- lstat oldPath++ if PosixCompat.isSymbolicLink fileStatus+ then do+ oldTarget <- liftIO (PosixCompat.readSymbolicLink oldPath)++ mktree (FilePath.takeDirectory newPath)++ liftIO (PosixCompat.createSymbolicLink oldTarget newPath)+ else if isFile+ then do+ mktree (FilePath.takeDirectory newPath)++ cp oldPath newPath+ else do+ mktree newPath )++-- | Copy a directory tree and dereference symbolic links+cptreeL :: MonadIO io => FilePath -> FilePath -> io ()+cptreeL oldTree newTree = sh (do+ oldPath <- lstree oldTree+ Just suffix <- return (Internal.stripPrefix (oldTree ++ "/") oldPath)+ let newPath = newTree </> suffix+ isFile <- testfile oldPath+ if isFile+ then mktree (FilePath.takeDirectory newPath) >> cp oldPath newPath+ else mktree newPath )+++-- | Remove a file+rm :: MonadIO io => FilePath -> io ()+rm path = liftIO (Directory.removeFile path)++-- | Remove a directory+rmdir :: MonadIO io => FilePath -> io ()+rmdir path = liftIO (Directory.removeDirectory path)++{-| Remove a directory tree (equivalent to @rm -r@)++ Use at your own risk+-}+rmtree :: MonadIO io => FilePath -> io ()+rmtree path0 = liftIO (sh (loop path0))+ where+ loop path = do+ linkstat <- lstat path+ let isLink = PosixCompat.isSymbolicLink linkstat+ isDir = PosixCompat.isDirectory linkstat+ if isLink+ then rm path+ else do+ if isDir+ then (do+ child <- ls path+ loop child ) <|> rmdir path+ else rm path++-- | Check if a file exists+testfile :: MonadIO io => FilePath -> io Bool+testfile path = liftIO (Directory.doesFileExist path)++-- | Check if a directory exists+testdir :: MonadIO io => FilePath -> io Bool+testdir path = liftIO (Directory.doesDirectoryExist path)++-- | Check if a path exists+testpath :: MonadIO io => FilePath -> io Bool+testpath path = do+ exists <- testfile path+ if exists+ then return exists+ else testdir path++{-| Touch a file, updating the access and modification times to the current time++ Creates an empty file if it does not exist+-}+touch :: MonadIO io => FilePath -> io ()+touch file = do+ exists <- testfile file+ liftIO (if exists+#ifdef mingw32_HOST_OS+ then do+ handle <- Win32.createFile+ file+ Win32.gENERIC_WRITE+ Win32.fILE_SHARE_NONE+ Nothing+ Win32.oPEN_EXISTING+ Win32.fILE_ATTRIBUTE_NORMAL+ Nothing+ (creationTime, _, _) <- Win32.getFileTime handle+ systemTime <- Win32.getSystemTimeAsFileTime+ Win32.setFileTime handle (Just creationTime) (Just systemTime) (Just systemTime)+#else+ then touchFile file+#endif+ else output file empty )++{-| This type is the same as @"System.Directory".`Directory.Permissions`@+ type except combining the `Directory.executable` and+ `Directory.searchable` fields into a single `executable` field for+ consistency with the Unix @chmod@. This simplification is still entirely+ consistent with the behavior of "System.Directory", which treats the two+ fields as interchangeable.+-}+data Permissions = Permissions+ { _readable :: Bool+ , _writable :: Bool+ , _executable :: Bool+ } deriving (Eq, Read, Ord, Show)++{-| Under the hood, "System.Directory" does not distinguish between+ `Directory.executable` and `Directory.searchable`. They both+ translate to the same `System.Posix.ownerExecuteMode` permission. That+ means that we can always safely just set the `Directory.executable`+ field and safely leave the `Directory.searchable` field as `False`+ because the two fields are combined with (`||`) to determine whether to set+ the executable bit.+-}+toSystemDirectoryPermissions :: Permissions -> Directory.Permissions+toSystemDirectoryPermissions p =+ ( Directory.setOwnerReadable (_readable p)+ . Directory.setOwnerWritable (_writable p)+ . Directory.setOwnerExecutable (_executable p)+ ) Directory.emptyPermissions++fromSystemDirectoryPermissions :: Directory.Permissions -> Permissions+fromSystemDirectoryPermissions p = Permissions+ { _readable = Directory.readable p+ , _writable = Directory.writable p+ , _executable =+ Directory.executable p || Directory.searchable p+ }++{-| Update a file or directory's user permissions++> chmod rwo "foo.txt" -- chmod u=rw foo.txt+> chmod executable "foo.txt" -- chmod u+x foo.txt+> chmod nonwritable "foo.txt" -- chmod u-w foo.txt++ The meaning of each permission is:++ * `readable` (@+r@ for short): For files, determines whether you can read+ from that file (such as with `input`). For directories, determines+ whether or not you can list the directory contents (such as with `ls`).+ Note: if a directory is not readable then `ls` will stream an empty list+ of contents++ * `writable` (@+w@ for short): For files, determines whether you can write+ to that file (such as with `output`). For directories, determines whether+ you can create a new file underneath that directory.++ * `executable` (@+x@ for short): For files, determines whether or not that+ file is executable (such as with `proc`). For directories, determines+ whether or not you can read or execute files underneath that directory+ (such as with `input` or `proc`)+-}+chmod+ :: MonadIO io+ => (Permissions -> Permissions)+ -- ^ Permissions update function+ -> FilePath+ -- ^ Path+ -> io Permissions+ -- ^ Updated permissions+chmod modifyPermissions path = liftIO (do+ let path' = deslash path+ permissions <- Directory.getPermissions path'+ let permissions' = fromSystemDirectoryPermissions permissions+ let permissions'' = modifyPermissions permissions'+ changed = permissions' /= permissions''+ let permissions''' = toSystemDirectoryPermissions permissions''+ when changed (Directory.setPermissions path' permissions''')+ return permissions'' )++-- | Get a file or directory's user permissions+getmod :: MonadIO io => FilePath -> io Permissions+getmod path = liftIO (do+ let path' = deslash path+ permissions <- Directory.getPermissions path'+ return (fromSystemDirectoryPermissions permissions))++-- | Set a file or directory's user permissions+setmod :: MonadIO io => Permissions -> FilePath -> io ()+setmod permissions path = liftIO (do+ let path' = deslash path+ Directory.setPermissions path' (toSystemDirectoryPermissions permissions) )++-- | Copy a file or directory's permissions (analogous to @chmod --reference@)+copymod :: MonadIO io => FilePath -> FilePath -> io ()+copymod sourcePath targetPath = liftIO (do+ let sourcePath' = deslash sourcePath+ targetPath' = deslash targetPath+ Directory.copyPermissions sourcePath' targetPath' )++-- | @+r@+readable :: Permissions -> Permissions+readable p = p { _readable = True }++-- | @-r@+nonreadable :: Permissions -> Permissions+nonreadable p = p { _readable = False }++-- | @+w@+writable :: Permissions -> Permissions+writable p = p { _writable = True }++-- | @-w@+nonwritable :: Permissions -> Permissions+nonwritable p = p { _writable = False }++-- | @+x@+executable :: Permissions -> Permissions+executable p = p { _executable = True }++-- | @-x@+nonexecutable :: Permissions -> Permissions+nonexecutable p = p { _executable = False }++-- | @-r -w -x@+ooo :: Permissions -> Permissions+ooo _ = Permissions+ { _readable = False+ , _writable = False+ , _executable = False+ }++-- | @+r -w -x@+roo :: Permissions -> Permissions+roo = readable . ooo++-- | @-r +w -x@+owo :: Permissions -> Permissions+owo = writable . ooo++-- | @-r -w +x@+oox :: Permissions -> Permissions+oox = executable . ooo++-- | @+r +w -x@+rwo :: Permissions -> Permissions+rwo = readable . writable . ooo++-- | @+r -w +x@+rox :: Permissions -> Permissions+rox = readable . executable . ooo++-- | @-r +w +x@+owx :: Permissions -> Permissions+owx = writable . executable . ooo++-- | @+r +w +x@+rwx :: Permissions -> Permissions+rwx = readable . writable . executable . ooo++{-| Time how long a command takes in monotonic wall clock time++ Returns the duration alongside the return value+-}+time :: MonadIO io => io a -> io (a, NominalDiffTime)+time io = do+ TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic)+ a <- io+ TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic)+ let t = fromIntegral ( seconds2 - seconds1)+ + fromIntegral (nanoseconds2 - nanoseconds1) / 10^(9::Int)+ return (a, fromRational t)++-- | Get the system's host name+hostname :: MonadIO io => io Text+hostname = liftIO (fmap Text.pack getHostName)++-- | Show the full path of an executable file+which :: MonadIO io => FilePath -> io (Maybe FilePath)+which cmd = fold (whichAll cmd) Control.Foldl.head++-- | Show all matching executables in PATH, not just the first+whichAll :: FilePath -> Shell FilePath+whichAll cmd = do+ Just paths <- need "PATH"+ path <- select (fmap Text.unpack (Text.splitOn ":" paths))+ let path' = path </> cmd++ True <- testfile path'++ let handler :: IOError -> IO Bool+ handler e =+ if isPermissionError e || isDoesNotExistError e+ then return False+ else throwIO e++ let getIsExecutable = fmap _executable (getmod path')+ isExecutable <- liftIO (getIsExecutable `catchIOError` handler)++ guard isExecutable+ return path'++{-| Sleep for the given duration++ A numeric literal argument is interpreted as seconds. In other words,+ @(sleep 2.0)@ will sleep for two seconds.+-}+sleep :: MonadIO io => NominalDiffTime -> io ()+sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int))))++{-| Exit with the given exit code++ An exit code of @0@ indicates success+-}+exit :: MonadIO io => ExitCode -> io a+exit code = liftIO (exitWith code)++-- | Throw an exception using the provided `Text` message+die :: MonadIO io => Text -> io a+die txt = liftIO (throwIO (userError (unpack txt)))++infixr 2 .||.+infixr 3 .&&.++{-| Analogous to `&&` in Bash++ Runs the second command only if the first one returns `ExitSuccess`+-}+(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode+cmd1 .&&. cmd2 = do+ r <- cmd1+ case r of+ ExitSuccess -> cmd2+ _ -> return r++{-| Analogous to `||` in Bash++ Run the second command only if the first one returns `ExitFailure`+-}+(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode+cmd1 .||. cmd2 = do+ r <- cmd1+ case r of+ ExitFailure _ -> cmd2+ _ -> return r++{-| Create a temporary directory underneath the given directory++ Deletes the temporary directory when done+-}+mktempdir+ :: MonadManaged managed+ => FilePath+ -- ^ Parent directory+ -> Text+ -- ^ Directory name template+ -> managed FilePath+mktempdir parent prefix = using (do+ let prefix' = unpack prefix+ managed (withTempDirectory parent prefix'))++{-| Create a temporary file underneath the given directory++ Deletes the temporary file when done++ Note that this provides the `Handle` of the file in order to avoid a+ potential race condition from the file being moved or deleted before you+ have a chance to open the file. The `mktempfile` function provides a+ simpler API if you don't need to worry about that possibility.+-}+mktemp+ :: MonadManaged managed+ => FilePath+ -- ^ Parent directory+ -> Text+ -- ^ File name template+ -> managed (FilePath, Handle)+mktemp parent prefix = using (do+ let prefix' = unpack prefix+ (file', handle) <- managed (\k ->+ withTempFile parent prefix' (\file' handle -> k (file', handle)) )+ return (file', handle) )++{-| Create a temporary file underneath the given directory++ Deletes the temporary file when done+-}+mktempfile+ :: MonadManaged managed+ => FilePath+ -- ^ Parent directory+ -> Text+ -- ^ File name template+ -> managed FilePath+mktempfile parent prefix = using (do+ let prefix' = unpack prefix+ (file', handle) <- managed (\k ->+ withTempFile parent prefix' (\file' handle -> k (file', handle)) )+ liftIO (hClose handle)+ return file' )++-- | Fork a thread, acquiring an `Async` value+fork :: MonadManaged managed => IO a -> managed (Async a)+fork io = using (managed (withAsync io))++-- | Wait for an `Async` action to complete+wait :: MonadIO io => Async a -> io a+wait a = liftIO (Control.Concurrent.Async.wait a)++-- | Read lines of `Text` from standard input+stdin :: Shell Line+stdin = inhandle IO.stdin++-- | Read lines of `Text` from a file+input :: FilePath -> Shell Line+input file = do+ handle <- using (readonly file)+ inhandle handle++-- | Read lines of `Text` from a `Handle`+inhandle :: Handle -> Shell Line+inhandle handle = Shell (\(FoldShell step begin done) -> do+ let loop x = do+ eof <- IO.hIsEOF handle+ if eof+ then done x+ else do+ txt <- Text.hGetLine handle+ x' <- step x (unsafeTextToLine txt)+ loop $! x'+ loop $! begin )++-- | Stream lines of `Text` to standard output+stdout :: MonadIO io => Shell Line -> io ()+stdout s = sh (do+ line <- s+ liftIO (echo line) )++-- | Stream lines of `Text` to a file+output :: MonadIO io => FilePath -> Shell Line -> io ()+output file s = sh (do+ handle <- using (writeonly file)+ line <- s+ liftIO (Text.hPutStrLn handle (lineToText line)) )++-- | Stream lines of `Text` to a `Handle`+outhandle :: MonadIO io => Handle -> Shell Line -> io ()+outhandle handle s = sh (do+ line <- s+ liftIO (Text.hPutStrLn handle (lineToText line)) )++-- | Stream lines of `Text` to append to a file+append :: MonadIO io => FilePath -> Shell Line -> io ()+append file s = sh (do+ handle <- using (appendonly file)+ line <- s+ liftIO (Text.hPutStrLn handle (lineToText line)) )++-- | Stream lines of `Text` to standard error+stderr :: MonadIO io => Shell Line -> io ()+stderr s = sh (do+ line <- s+ liftIO (err line) )++-- | Read in a stream's contents strictly+strict :: MonadIO io => Shell Line -> io Text+strict s = liftM linesToText (fold s list)++-- | Acquire a `Managed` read-only `Handle` from a `FilePath`+readonly :: MonadManaged managed => FilePath -> managed Handle+readonly file = using (managed (IO.withFile file IO.ReadMode))++-- | Acquire a `Managed` write-only `Handle` from a `FilePath`+writeonly :: MonadManaged managed => FilePath -> managed Handle+writeonly file = using (managed (IO.withFile file IO.WriteMode))++-- | Acquire a `Managed` append-only `Handle` from a `FilePath`+appendonly :: MonadManaged managed => FilePath -> managed Handle+appendonly file = using (managed (IO.withFile file IO.AppendMode))++-- | Combine the output of multiple `Shell`s, in order+cat :: [Shell a] -> Shell a+cat = msum++grepWith :: (b -> Text) -> Pattern a -> Shell b -> Shell b+grepWith f pattern' = mfilter (not . null . match pattern' . f)++-- | Keep all lines that match the given `Pattern`+grep :: Pattern a -> Shell Line -> Shell Line+grep = grepWith lineToText++-- | Keep every `Text` element that matches the given `Pattern`+grepText :: Pattern a -> Shell Text -> Shell Text+grepText = grepWith id++{-| Replace all occurrences of a `Pattern` with its `Text` result++ `sed` performs substitution on a line-by-line basis, meaning that+ substitutions may not span multiple lines. Additionally, substitutions may+ occur multiple times within the same line, like the behavior of+ @s\/...\/...\/g@.++ Warning: Do not use a `Pattern` that matches the empty string, since it will+ match an infinite number of times. `sed` tries to detect such `Pattern`s+ and `die` with an error message if they occur, but this detection is+ necessarily incomplete.+-}+sed :: Pattern Text -> Shell Line -> Shell Line+sed pattern' s = do+ when (matchesEmpty pattern') (die message)+ let pattern'' = fmap Text.concat+ (many (pattern' <|> fmap Text.singleton anyChar))+ line <- s+ txt':_ <- return (match pattern'' (lineToText line))+ select (textToLines txt')+ where+ message = "sed: the given pattern matches the empty string"+ matchesEmpty = not . null . flip match ""++{-| Like `sed`, but the provided substitution must match the beginning of the+ line+-}+sedPrefix :: Pattern Text -> Shell Line -> Shell Line+sedPrefix pattern' s = do+ line <- s+ txt':_ <- return (match ((pattern' <> chars) <|> chars) (lineToText line))+ select (textToLines txt')++-- | Like `sed`, but the provided substitution must match the end of the line+sedSuffix :: Pattern Text -> Shell Line -> Shell Line+sedSuffix pattern' s = do+ line <- s+ txt':_ <- return (match ((chars <> pattern') <|> chars) (lineToText line))+ select (textToLines txt')++-- | Like `sed`, but the provided substitution must match the entire line+sedEntire :: Pattern Text -> Shell Line -> Shell Line+sedEntire pattern' s = do+ line <- s+ txt':_ <- return (match (pattern' <|> chars)(lineToText line))+ select (textToLines txt')++-- | Make a `Shell Text -> Shell Text` function work on `FilePath`s instead.+-- | Ignores any paths which cannot be decoded as valid `Text`.+onFiles :: (Shell Text -> Shell Text) -> Shell FilePath -> Shell FilePath+onFiles f = fmap Text.unpack . f . fmap Text.pack++-- | Like `sed`, but operates in place on a `FilePath` (analogous to @sed -i@)+inplace :: MonadIO io => Pattern Text -> FilePath -> io ()+inplace = update . sed++-- | Like `sedPrefix`, but operates in place on a `FilePath`+inplacePrefix :: MonadIO io => Pattern Text -> FilePath -> io ()+inplacePrefix = update . sedPrefix++-- | Like `sedSuffix`, but operates in place on a `FilePath`+inplaceSuffix :: MonadIO io => Pattern Text -> FilePath -> io ()+inplaceSuffix = update . sedSuffix++-- | Like `sedEntire`, but operates in place on a `FilePath`+inplaceEntire :: MonadIO io => Pattern Text -> FilePath -> io ()+inplaceEntire = update . sedEntire++{-| Update a file in place using a `Shell` transformation++ For example, this is used to implement the @inplace*@ family of utilities+-}+update :: MonadIO io => (Shell Line -> Shell Line) -> FilePath -> io ()+update f file = liftIO (runManaged (do+ here <- pwd++ (tmpfile, handle) <- mktemp here "turtle"++ outhandle handle (f (input file))++ liftIO (hClose handle)++ copymod file tmpfile++ mv tmpfile file ))++-- | Search a directory recursively for all files matching the given `Pattern`+find :: Pattern a -> FilePath -> Shell FilePath+find pattern' dir = do+ path <- lsif isNotSymlink dir++ let txt = Text.pack path++ _:_ <- return (match pattern' txt)++ return path+ where+ isNotSymlink :: FilePath -> IO Bool+ isNotSymlink file = do+ file_stat <- lstat file+ return (not (PosixCompat.isSymbolicLink file_stat))++-- | Filter a shell of FilePaths according to a given pattern+findtree :: Pattern a -> Shell FilePath -> Shell FilePath+findtree pat files = do+ path <- files++ let txt = Text.pack path++ _:_ <- return (match pat txt)++ return path++{- | Check if a file was last modified after a given+ timestamp+-} +cmin :: MonadIO io => UTCTime -> FilePath -> io Bool+cmin t file = do+ status <- lstat file+ return (adapt status)+ where+ adapt x = posixSecondsToUTCTime (modificationTime x) > t++{- | Check if a file was last modified before a given+ timestamp+-} +cmax :: MonadIO io => UTCTime -> FilePath -> io Bool+cmax t file = do+ status <- lstat file+ return (adapt status)+ where+ adapt x = posixSecondsToUTCTime (modificationTime x) < t+ +-- | A Stream of @\"y\"@s+yes :: Shell Line+yes = fmap (\_ -> "y") endless++-- | Number each element of a `Shell` (starting at 0)+nl :: Num n => Shell a -> Shell (n, a)+nl s = Shell _foldShell'+ where+ _foldShell' (FoldShell step begin done) = _foldShell s (FoldShell step' begin' done')+ where+ step' (x, n) a = do+ x' <- step x (n, a)+ let n' = n + 1+ n' `seq` return (x', n')+ begin' = (begin, 0)+ done' (x, _) = done x++data ZipState a b = Empty | HasA a | HasAB a b | Done++{-| Merge two `Shell`s together, element-wise++ If one `Shell` is longer than the other, the excess elements are+ truncated+-}+paste :: Shell a -> Shell b -> Shell (a, b)+paste sA sB = Shell _foldShellAB+ where+ _foldShellAB (FoldShell stepAB beginAB doneAB) = do+ tvar <- STM.atomically (STM.newTVar Empty)++ let begin = ()++ let stepA () a = STM.atomically (do+ x <- STM.readTVar tvar+ case x of+ Empty -> STM.writeTVar tvar (HasA a)+ Done -> return ()+ _ -> STM.retry )+ let doneA () = STM.atomically (do+ x <- STM.readTVar tvar+ case x of+ Empty -> STM.writeTVar tvar Done+ Done -> return ()+ _ -> STM.retry )+ let foldA = FoldShell stepA begin doneA++ let stepB () b = STM.atomically (do+ x <- STM.readTVar tvar+ case x of+ HasA a -> STM.writeTVar tvar (HasAB a b)+ Done -> return ()+ _ -> STM.retry )+ let doneB () = STM.atomically (do+ x <- STM.readTVar tvar+ case x of+ HasA _ -> STM.writeTVar tvar Done+ Done -> return ()+ _ -> STM.retry )+ let foldB = FoldShell stepB begin doneB++ withAsync (_foldShell sA foldA) (\asyncA -> do+ withAsync (_foldShell sB foldB) (\asyncB -> do+ let loop x = do+ y <- STM.atomically (do+ z <- STM.readTVar tvar+ case z of+ HasAB a b -> do+ STM.writeTVar tvar Empty+ return (Just (a, b))+ Done -> return Nothing+ _ -> STM.retry )+ case y of+ Nothing -> return x+ Just ab -> do+ x' <- stepAB x ab+ loop $! x'+ x' <- loop $! beginAB+ wait asyncA+ wait asyncB+ doneAB x' ) )++-- | A `Shell` that endlessly emits @()@+endless :: Shell ()+endless = Shell (\(FoldShell step begin _) -> do+ let loop x = do+ x' <- step x ()+ loop $! x'+ loop $! begin )++{-| Limit a `Shell` to a fixed number of values++ NOTE: This is not lazy and will still consume the entire input stream.+ There is no way to implement a lazy version of this utility.+-}+limit :: Int -> Shell a -> Shell a+limit n s = Shell (\(FoldShell step begin done) -> do+ ref <- newIORef 0 -- I feel so dirty+ let step' x a = do+ n' <- readIORef ref+ writeIORef ref (n' + 1)+ if n' < n then step x a else return x+ _foldShell s (FoldShell step' begin done) )++{-| Limit a `Shell` to values that satisfy the predicate++ This terminates the stream on the first value that does not satisfy the+ predicate+-}+limitWhile :: (a -> Bool) -> Shell a -> Shell a+limitWhile predicate s = Shell (\(FoldShell step begin done) -> do+ ref <- newIORef True+ let step' x a = do+ b <- readIORef ref+ let b' = b && predicate a+ writeIORef ref b'+ if b' then step x a else return x+ _foldShell s (FoldShell step' begin done) )++{-| Cache a `Shell`'s output so that repeated runs of the script will reuse the+ result of previous runs. You must supply a `FilePath` where the cached+ result will be stored.++ The stored result is only reused if the `Shell` successfully ran to+ completion without any exceptions. Note: on some platforms Ctrl-C will+ flush standard input and signal end of file before killing the program,+ which may trick the program into \"successfully\" completing.+-}+cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a+cache file s = do+ let cached = do+ line <- input file+ case reads (Text.unpack (lineToText line)) of+ [(ma, "")] -> return ma+ _ ->+ die (format ("cache: Invalid data stored in "%w) file)+ exists <- testfile file+ mas <- fold (if exists then cached else empty) list+ case [ () | Nothing <- mas ] of+ _:_ -> select [ a | Just a <- mas ]+ _ -> do+ handle <- using (writeonly file)+ let justs = do+ a <- s+ liftIO (Text.hPutStrLn handle (Text.pack (show (Just a))))+ return a+ let nothing = do+ let n = Nothing :: Maybe ()+ liftIO (Text.hPutStrLn handle (Text.pack (show n)))+ empty+ justs <|> nothing++{-| Run a list of IO actions in parallel using fork and wait.+++>>> view (parallel [(sleep 3) >> date, date, date])+2016-12-01 17:22:10.83296 UTC+2016-12-01 17:22:07.829876 UTC+2016-12-01 17:22:07.829963 UTC++-}+parallel :: [IO a] -> Shell a+parallel = traverse fork >=> select >=> wait++-- | Split a line into chunks delimited by the given `Pattern`+cut :: Pattern a -> Text -> [Text]+cut pattern' txt = head (match (selfless chars `sepBy` pattern') txt)+-- This `head` should be safe ... in theory++-- | Get the current time+date :: MonadIO io => io UTCTime+date = liftIO getCurrentTime++-- | Get the time a file was last modified+datefile :: MonadIO io => FilePath -> io UTCTime+datefile path = liftIO (Directory.getModificationTime path)++-- | Get the size of a file or a directory+du :: MonadIO io => FilePath -> io Size+du path = liftIO (do+ isDir <- testdir path+ size <- do+ if isDir+ then do+ let sizes = do+ child <- lstree path+ True <- testfile child+ liftIO (Directory.getFileSize child)+ fold sizes Control.Foldl.sum+ else Directory.getFileSize path+ return (Size size) )++{-| An abstract file size++ Specify the units you want by using an accessor like `kilobytes`++ The `Num` instance for `Size` interprets numeric literals as bytes+-}+newtype Size = Size { _bytes :: Integer } deriving (Eq, Ord, Num)++instance Show Size where+ show = show . _bytes++{-| `Format` a `Size` using a human readable representation++>>> format sz 42+"42 B"+>>> format sz 2309+"2.309 KB"+>>> format sz 949203+"949.203 KB"+>>> format sz 1600000000+"1.600 GB"+>>> format sz 999999999999999999+"999999.999 TB"+-}+sz :: Format r (Size -> r)+sz = makeFormat (\(Size numBytes) ->+ let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000+ (numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000+ (numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000+ (numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000+ in if numKilobytes <= 0+ then format (d%" B" ) remainingBytes+ else if numMegabytes == 0+ then format (d%"."%d%" KB") remainingKilobytes remainingBytes+ else if numGigabytes == 0+ then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes+ else if numTerabytes == 0+ then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes+ else format (d%"."%d%" TB") numTerabytes remainingGigabytes )++{-| Construct a 'Size' from an integer in bytes++>>> format sz (B 42)+"42 B"+-}+pattern B :: Integral n => n -> Size+pattern B { bytes } <- (fromInteger . _bytes -> bytes)+ where+ B = fromIntegral+{-# COMPLETE B #-}++{-| Construct a 'Size' from an integer in kilobytes++>>> format sz (KB 42)+"42.0 KB"+>>> let B n = KB 1 in n+1000+-}+pattern KB :: Integral n => n -> Size+pattern KB { kilobytes } <- (\(B x) -> x `div` 1000 -> kilobytes)+ where+ KB = B . (* 1000)+{-# COMPLETE KB #-}++{-| Construct a 'Size' from an integer in megabytes++>>> format sz (MB 42)+"42.0 MB"+>>> let KB n = MB 1 in n+1000+-}+pattern MB :: Integral n => n -> Size+pattern MB { megabytes } <- (\(KB x) -> x `div` 1000 -> megabytes)+ where+ MB = KB . (* 1000)+{-# COMPLETE MB #-}++{-| Construct a 'Size' from an integer in gigabytes++>>> format sz (GB 42)+"42.0 GB"+>>> let MB n = GB 1 in n+1000+-}+pattern GB :: Integral n => n -> Size+pattern GB { gigabytes } <- (\(MB x) -> x `div` 1000 -> gigabytes)+ where+ GB = MB . (* 1000)+{-# COMPLETE GB #-}++{-| Construct a 'Size' from an integer in terabytes++>>> format sz (TB 42)+"42.0 TB"+>>> let GB n = TB 1 in n+1000+-}+pattern TB :: Integral n => n -> Size+pattern TB { terabytes } <- (\(GB x) -> x `div` 1000 -> terabytes)+ where+ TB = GB . (* 1000)+{-# COMPLETE TB #-}++{-| Construct a 'Size' from an integer in kibibytes++>>> format sz (KiB 42)+"43.8 KB"+>>> let B n = KiB 1 in n+1024+-}+pattern KiB :: Integral n => n -> Size+pattern KiB { kibibytes } <- (\(B x) -> x `div` 1024 -> kibibytes)+ where+ KiB = B . (* 1024)+{-# COMPLETE KiB #-}++{-| Construct a 'Size' from an integer in mebibytes++>>> format sz (MiB 42)+"44.40 MB"+>>> let KiB n = MiB 1 in n+1024+-}+pattern MiB :: Integral n => n -> Size+pattern MiB { mebibytes } <- (\(KiB x) -> x `div` 1024 -> mebibytes)+ where+ MiB = KiB . (* 1024)+{-# COMPLETE MiB #-}++{-| Construct a 'Size' from an integer in gibibytes++>>> format sz (GiB 42)+"45.97 GB"+>>> let MiB n = GiB 1 in n+1024+-}+pattern GiB :: Integral n => n -> Size+pattern GiB { gibibytes } <- (\(MiB x) -> x `div` 1024 -> gibibytes)+ where+ GiB = MiB . (* 1024)+{-# COMPLETE GiB #-}++{-| Construct a 'Size' from an integer in tebibytes++>>> format sz (TiB 42)+"46.179 TB"+>>> let GiB n = TiB 1 in n+1024+-}+pattern TiB :: Integral n => n -> Size+pattern TiB { tebibytes } <- (\(GiB x) -> x `div` 1024 -> tebibytes)+ where+ TiB = GiB . (* 1024)+{-# COMPLETE TiB #-}++-- | Extract a size in bytes+bytes :: Integral n => Size -> n++-- | @1 kilobyte = 1000 bytes@+kilobytes :: Integral n => Size -> n++-- | @1 megabyte = 1000 kilobytes@+megabytes :: Integral n => Size -> n++-- | @1 gigabyte = 1000 megabytes@+gigabytes :: Integral n => Size -> n++-- | @1 terabyte = 1000 gigabytes@+terabytes :: Integral n => Size -> n++-- | @1 kibibyte = 1024 bytes@+kibibytes :: Integral n => Size -> n++-- | @1 mebibyte = 1024 kibibytes@+mebibytes :: Integral n => Size -> n++-- | @1 gibibyte = 1024 mebibytes@+gibibytes :: Integral n => Size -> n++-- | @1 tebibyte = 1024 gibibytes@+tebibytes :: Integral n => Size -> n++{-| Count the number of characters in the stream (like @wc -c@)++ This uses the convention that the elements of the stream are implicitly+ ended by newlines that are one character wide+-}+countChars :: Integral n => Fold Line n+countChars =+ premap lineToText Control.Foldl.Text.length ++ charsPerNewline * countLines++charsPerNewline :: Num a => a+#ifdef mingw32_HOST_OS+charsPerNewline = 2+#else+charsPerNewline = 1+#endif++-- | Count the number of words in the stream (like @wc -w@)+countWords :: Integral n => Fold Line n+countWords = premap (Text.words . lineToText) (handles traverse genericLength)++{-| Count the number of lines in the stream (like @wc -l@)++ This uses the convention that each element of the stream represents one+ line+-}+countLines :: Integral n => Fold Line n+countLines = genericLength++-- | Get the status of a file+stat :: MonadIO io => FilePath -> io PosixCompat.FileStatus+stat = liftIO . PosixCompat.getFileStatus++-- | Size of the file in bytes. Does not follow symlinks+fileSize :: PosixCompat.FileStatus -> Size+fileSize = fromIntegral . PosixCompat.fileSize++-- | Time of last access+accessTime :: PosixCompat.FileStatus -> POSIXTime+accessTime = realToFrac . PosixCompat.accessTime++-- | Time of last modification+modificationTime :: PosixCompat.FileStatus -> POSIXTime+modificationTime = realToFrac . PosixCompat.modificationTime++-- | Time of last status change (i.e. owner, group, link count, mode, etc.)+statusChangeTime :: PosixCompat.FileStatus -> POSIXTime+statusChangeTime = realToFrac . PosixCompat.statusChangeTime++-- | Get the status of a file, but don't follow symbolic links+lstat :: MonadIO io => FilePath -> io PosixCompat.FileStatus+lstat = liftIO . PosixCompat.getSymbolicLinkStatus++data WithHeader a+ = Header a+ -- ^ The first line with the header+ | Row a a+ -- ^ Every other line: 1st element is header, 2nd element is original row+ deriving (Show)++data Pair a b = Pair !a !b++header :: Shell a -> Shell (WithHeader a)+header (Shell k) = Shell k'+ where+ k' (FoldShell step begin done) = k (FoldShell step' begin' done')+ where+ step' (Pair x Nothing ) a = do+ x' <- step x (Header a)+ return (Pair x' (Just a))+ step' (Pair x (Just a)) b = do+ x' <- step x (Row a b)+ return (Pair x' (Just a))++ begin' = Pair begin Nothing++ done' (Pair x _) = done x++-- | Returns the result of a 'Shell' that outputs a single line.+-- Note that if no lines / more than 1 line is produced by the Shell, this function will `die` with an error message.+--+-- > main = do+-- > directory <- single (inshell "pwd" empty)+-- > print directory+single :: MonadIO io => Shell a -> io a+single s = do+ as <- fold s Control.Foldl.list+ case as of+ [a] -> return a+ _ -> do+ let msg = format ("single: expected 1 line of input but there were "%d%" lines of input") (length as)+ die msg++-- | Filter adjacent duplicate elements:+--+-- >>> view (uniq (select [1,1,2,1,3]))+-- 1+-- 2+-- 1+-- 3+uniq :: Eq a => Shell a -> Shell a+uniq = uniqOn id++-- | Filter adjacent duplicates determined after applying the function to the element:+--+-- >>> view (uniqOn fst (select [(1,'a'),(1,'b'),(2,'c'),(1,'d'),(3,'e')]))+-- (1,'a')+-- (2,'c')+-- (1,'d')+-- (3,'e')+uniqOn :: Eq b => (a -> b) -> Shell a -> Shell a+uniqOn f = uniqBy (\a a' -> f a == f a')++-- | Filter adjacent duplicate elements determined via the given function:+--+-- >>> view (uniqBy (==) (select [1,1,2,1,3]))+-- 1+-- 2+-- 1+-- 3+uniqBy :: (a -> a -> Bool) -> Shell a -> Shell a+uniqBy cmp s = Shell $ \(FoldShell step begin done) -> do+ let step' (x, Just a') a | cmp a a' = return (x, Just a)+ step' (x, _) a = (, Just a) <$> step x a+ begin' = (begin, Nothing)+ done' (x, _) = done x+ foldShell s (FoldShell step' begin' done')++-- | Return a new `Shell` that discards duplicates from the input `Shell`:+--+-- >>> view (nub (select [1, 1, 2, 3, 3, 4, 3]))+-- 1+-- 2+-- 3+-- 4+nub :: Ord a => Shell a -> Shell a+nub = nubOn id++-- | Return a new `Shell` that discards duplicates determined via the given function from the input `Shell`:+--+-- >>> view (nubOn id (select [1, 1, 2, 3, 3, 4, 3]))+-- 1+-- 2+-- 3+-- 4+nubOn :: Ord b => (a -> b) -> Shell a -> Shell a+nubOn f s = Shell $ \(FoldShell step begin done) -> do+ let step' (x, bs) a | Set.member (f a) bs = return (x, bs)+ | otherwise = (, Set.insert (f a) bs) <$> step x a+ begin' = (begin, Set.empty)+ done' (x, _) = done x+ foldShell s (FoldShell step' begin' done')++-- | Return a list of the sorted elements of the given `Shell`, keeping duplicates:+--+-- >>> sort (select [1,4,2,3,3,7])+-- [1,2,3,3,4,7]+sort :: (Functor io, MonadIO io, Ord a) => Shell a -> io [a]+sort = sortOn id++-- | Return a list of the elements of the given `Shell`, sorted after applying the given function and keeping duplicates:+--+-- >>> sortOn id (select [1,4,2,3,3,7])+-- [1,2,3,3,4,7]+sortOn :: (Functor io, MonadIO io, Ord b) => (a -> b) -> Shell a -> io [a]+sortOn f = sortBy (comparing f)++-- | Return a list of the elements of the given `Shell`, sorted by the given function and keeping duplicates:+--+-- >>> sortBy (comparing fst) (select [(1,'a'),(4,'b'),(2,'c'),(3,'d'),(3,'e'),(7,'f')])+-- [(1,'a'),(2,'c'),(3,'d'),(3,'e'),(4,'b'),(7,'f')]+sortBy :: (Functor io, MonadIO io) => (a -> a -> Ordering) -> Shell a -> io [a]+sortBy f s = List.sortBy f <$> fold s list++{-| Group an arbitrary stream of `Text` into newline-delimited `Line`s++>>> stdout (toLines ("ABC" <|> "DEF" <|> "GHI")+ABCDEFGHI+>>> stdout (toLines empty) -- Note that this always emits at least 1 `Line`++>>> stdout (toLines ("ABC\nDEF" <|> "" <|> "GHI\nJKL"))+ABC+DEFGHI+JKL+-}+toLines :: Shell Text -> Shell Line+toLines (Shell k) = Shell k'+ where+ k' (FoldShell step begin done) =+ k (FoldShell step' begin' done')+ where+ step' (Pair x prefix) text = do+ let suffix :| lines = Turtle.Line.textToLines text++ let line = prefix <> suffix++ let lines' = line :| lines++ x' <- foldM step x (NonEmpty.init lines')++ let prefix' = NonEmpty.last lines'++ return (Pair x' prefix')++ begin' = (Pair begin "")++ done' (Pair x prefix) = do+ x' <- step x prefix+ done x'
src/Turtle/Shell.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-| You can think of `Shell` as @[]@ + `IO` + `Managed`. In fact, you can embed@@ -47,9 +50,8 @@ `Shell` you build must satisfy this law: > -- For every shell `s`:-> _foldIO s (FoldM step begin done) = do-> x <- begin-> x' <- _foldIO s (FoldM step (return x) return)+> _foldShell s (FoldShell step begin done) = do+> x' <- _foldShell s (FoldShell step begin return) > done x' ... which is a fancy way of saying that your `Shell` must call @\'begin\'@@@ -59,8 +61,13 @@ module Turtle.Shell ( -- * Shell Shell(..)+ , FoldShell(..)+ , _foldIO+ , _Shell , foldIO+ , foldShell , fold+ , reduce , sh , view @@ -68,29 +75,87 @@ , select , liftIO , using+ , fromIO ) where import Control.Applicative import Control.Monad (MonadPlus(..), ap)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Managed (MonadManaged(..), with)+import qualified Control.Monad.Fail as Fail import Control.Foldl (Fold(..), FoldM(..)) import qualified Control.Foldl as Foldl+import Data.Foldable (Foldable)+import qualified Data.Foldable import Data.Monoid import Data.String (IsString(..)) import Prelude -- Fix redundant import warnings +{-| This is similar to @`Control.Foldl.FoldM` `IO`@ except that the @begin@+ field is pure++ This small difference is necessary to implement a well-behaved `MonadCatch`+ instance for `Shell`+-}+data FoldShell a b = forall x . FoldShell (x -> a -> IO x) x (x -> IO b)+ -- | A @(Shell a)@ is a protected stream of @a@'s with side effects-newtype Shell a = Shell { _foldIO :: forall r . FoldM IO a r -> IO r }+newtype Shell a = Shell { _foldShell:: forall r . FoldShell a r -> IO r } +data Maybe' a = Just' !a | Nothing'++translate :: FoldM IO a b -> FoldShell a b+translate (FoldM step begin done) = FoldShell step' Nothing' done'+ where+ step' Nothing' a = do+ x <- begin+ x' <- step x a+ return $! Just' x'+ step' (Just' x) a = do+ x' <- step x a+ return $! Just' x'++ done' Nothing' = do+ x <- begin+ done x+ done' (Just' x) = do+ done x+ -- | Use a @`FoldM` `IO`@ to reduce the stream of @a@'s produced by a `Shell` foldIO :: MonadIO io => Shell a -> FoldM IO a r -> io r foldIO s f = liftIO (_foldIO s f) +{-| Provided for backwards compatibility with versions of @turtle-1.4.*@ and+ older+-}+_foldIO :: Shell a -> FoldM IO a r -> IO r+_foldIO s foldM = _foldShell s (translate foldM)++-- | Provided for ease of migration from versions of @turtle-1.4.*@ and older+_Shell :: (forall r . FoldM IO a r -> IO r) -> Shell a+_Shell f = Shell (f . adapt)+ where+ adapt (FoldShell step begin done) = FoldM step (return begin) done++-- | Use a `FoldShell` to reduce the stream of @a@'s produced by a `Shell`+foldShell :: MonadIO io => Shell a -> FoldShell a b -> io b+foldShell s f = liftIO (_foldShell s f)+ -- | Use a `Fold` to reduce the stream of @a@'s produced by a `Shell` fold :: MonadIO io => Shell a -> Fold a b -> io b fold s f = foldIO s (Foldl.generalize f) +-- | Flipped version of 'fold'. Useful for reducing a stream of data+--+-- ==== __Example__+-- Sum a `Shell` of numbers:+--+-- >>> select [1, 2, 3] & reduce Fold.sum+-- 6+reduce :: MonadIO io => Fold a b -> Shell a -> io b+reduce = flip fold+ -- | Run a `Shell` to completion, discarding any unused values sh :: MonadIO io => Shell a -> io () sh s = fold s (pure ())@@ -102,34 +167,33 @@ liftIO (print x) ) instance Functor Shell where- fmap f s = Shell (\(FoldM step begin done) ->+ fmap f s = Shell (\(FoldShell step begin done) -> let step' x a = step x (f a)- in _foldIO s (FoldM step' begin done) )+ in _foldShell s (FoldShell step' begin done) ) instance Applicative Shell where pure = return (<*>) = ap instance Monad Shell where- return a = Shell (\(FoldM step begin done) -> do- x <- begin- x' <- step x a- done x' )+ return a = Shell (\(FoldShell step begin done) -> do+ x <- step begin a+ done x ) - m >>= f = Shell (\(FoldM step0 begin0 done0) -> do- let step1 x a = _foldIO (f a) (FoldM step0 (return x) return)- _foldIO m (FoldM step1 begin0 done0) )+ m >>= f = Shell (\(FoldShell step0 begin0 done0) -> do+ let step1 x a = _foldShell (f a) (FoldShell step0 x return)+ _foldShell m (FoldShell step1 begin0 done0) ) - fail _ = mzero+#if!(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif instance Alternative Shell where- empty = Shell (\(FoldM _ begin done) -> do- x <- begin- done x )+ empty = Shell (\(FoldShell _ begin done) -> done begin) - s1 <|> s2 = Shell (\(FoldM step begin done) -> do- x <- _foldIO s1 (FoldM step begin return)- _foldIO s2 (FoldM step (return x) done) )+ s1 <|> s2 = Shell (\(FoldShell step begin done) -> do+ x <- _foldShell s1 (FoldShell step begin return)+ _foldShell s2 (FoldShell step x done) ) instance MonadPlus Shell where mzero = empty@@ -137,18 +201,30 @@ mplus = (<|>) instance MonadIO Shell where- liftIO io = Shell (\(FoldM step begin done) -> do- x <- begin- a <- io- x' <- step x a- done x' )+ liftIO io = Shell (\(FoldShell step begin done) -> do+ a <- io+ x <- step begin a+ done x ) instance MonadManaged Shell where- using resource = Shell (\(FoldM step begin done) -> do- x <- begin- x' <- with resource (step x)- done x' )+ using resource = Shell (\(FoldShell step begin done) -> do+ x <- with resource (step begin)+ done x ) +instance MonadThrow Shell where+ throwM e = Shell (\_ -> throwM e)++instance MonadCatch Shell where+ m `catch` k = Shell (\f-> _foldShell m f `catch` (\e -> _foldShell (k e) f))++instance Fail.MonadFail Shell where+ fail _ = mzero++#if __GLASGOW_HASKELL__ >= 804+instance Monoid a => Semigroup (Shell a) where+ (<>) = mappend+#endif+ instance Monoid a => Monoid (Shell a) where mempty = pure mempty mappend = liftA2 mappend@@ -164,10 +240,26 @@ fromString str = pure (fromString str) -- | Convert a list to a `Shell` that emits each element of the list-select :: [a] -> Shell a-select as = Shell (\(FoldM step begin done) -> do- x0 <- begin+select :: Foldable f => f a -> Shell a+select as = Shell (\(FoldShell step begin done) -> do let step' a k x = do x' <- step x a k $! x'- foldr step' done as $! x0 )+ Data.Foldable.foldr step' done as $! begin )++-- | Convert an `IO` action that returns a `Maybe` into a `Shell`+fromIO :: IO (Maybe a) -> Shell a+fromIO io =+ Shell+ (\(FoldShell step begin done) -> do+ let loop x = do+ m <- io+ case m of+ Just a -> do+ x' <- step x a+ loop x'+ Nothing -> do+ done x++ loop begin+ )
src/Turtle/Tutorial.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoCPP #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-| Use @turtle@ if you want to write light-weight and maintainable shell@@ -46,7 +47,7 @@ can install a Haskell compiler if one is not already present. If you are curious about how these two lines work, they are described here: - <https://github.com/commercialhaskell/stack/blob/master/doc/GUIDE.md#ghcrunghc>+ <https://github.com/commercialhaskell/stack/blob/master/doc/GUIDE.md#script-interpreter> If you want to make a Windows script independently executable outside of a Git Bash environment, you can either (A) compile the script into an@@ -115,6 +116,9 @@ -- * Conclusion -- $conclusion + -- * Nix scripts+ -- $nix+ -- * FAQ -- $faq ) where@@ -128,7 +132,7 @@ -- -- @ -- #!\/usr\/bin\/env stack--- \-\- stack \-\-install-ghc runghc \-\-package turtle+-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- {-\# LANGUAGE OverloadedStrings \#-} --@@ -193,7 +197,7 @@ -- difference: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} --@@ -210,7 +214,7 @@ -- program this way instead: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -226,7 +230,7 @@ -- permits definitions. If you were to insert a statement at the top-level: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -243,7 +247,7 @@ -- command: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} --@@ -269,7 +273,7 @@ -- -- @ -- #!\/usr\/bin\/env stack--- \-\- stack \-\-install-ghc runghc \-\-package turtle+-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- import Turtle --@@ -297,7 +301,7 @@ -- within a larger subroutine: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > import Turtle --@@ -359,7 +363,7 @@ -- following script to find out what happens if we choose `echo` instead: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > import Turtle -- > @@ -373,7 +377,7 @@ -- > $ ./example.hs -- > -- > example.hs:8:10:--- > Couldn't match expected type `Text' with actual type `UTCTime'+-- > Couldn't match expected type `Line' with actual type `UTCTime' -- > In the first argument of `echo', namely `time' -- > In a stmt of a 'do' block: echo time -- > In the expression:@@ -382,13 +386,14 @@ -- > echo time } -- -- The error points to the last line of our program: @(example.hs:8:10)@ means--- line 8, column 10 of our program. If you study the error message closely--- you'll see that the `echo` function expects a `Text` value, but we passed it--- @\'time\'@, which was a `UTCTime` value. Although the error is at the end of--- our script, Haskell catches this error before even running the script. When--- we \"interpret\" a Haskell script the Haskell compiler actually compiles the--- script without any optimizations to generate a temporary executable and then--- runs the executable, much like Perl does for Perl scripts.+-- line 8, column 10 of our program. If you study the error message closely+-- you'll see that the `echo` function expects a `Line` value (a piece of text+-- without newlines), but we passed it @\'time\'@, which was a `UTCTime` value.+-- Although the error is at the end of our script, Haskell catches this error+-- before even running the script. When we \"interpret\" a Haskell script the+-- Haskell compiler actually compiles the script without any optimizations to+-- generate a temporary executable and then runs the executable, much like Perl+-- does for Perl scripts. -- -- You might wonder: \"where are the types?\" None of the above programs had -- any type signatures or type annotations, yet the compiler still detected type@@ -446,14 +451,21 @@ -- -- @ -- Prelude Turtle> :type echo--- echo :: `Text` -> `IO` ()+-- echo :: `Line` -> `IO` () -- @ -- -- The above type says that `echo` is a function whose argument is a value of--- type `Text` and whose result is a subroutine (`IO`) with an empty return+-- type `Line` and whose result is a subroutine (`IO`) with an empty return -- value (denoted @\'()\'@). ----- Now we can understand the type error: `echo` expects a `Text` argument but+-- `Line` is a wrapper around `Text` and represents a `Text` value with no+-- internal newlines:+--+-- @+-- newtype `Line` = `Line` `Text`+-- @+--+-- Now we can understand the type error: `echo` expects a `Line` argument but -- `datefile` returns a `UTCTime`, which is not the same thing. Unlike Bash, -- not everything is `Text` in Haskell and the compiler will not cast or coerce -- types for you.@@ -472,16 +484,18 @@ -- `print`. -- -- This library provides a helper function that lets you convert any type that--- implements `Show` into a `Text` value:+-- implements `Show` into any other type that implements `IsString`: -- -- @ -- \-\- This behaves like Python's \`repr\` function--- `repr` :: `Show` a => a -> `Text`+-- `repr` :: (`Show` a, `IsString` b) => a -> b -- @ -- -- You could therefore implement `print` in terms of `echo` and `repr`: -- -- > print x = echo (repr x)+--+-- ... which works because `Line` implements `IsString` -- $shell --@@ -490,7 +504,7 @@ -- @turtle@: -- -- @--- $ stack ghci+-- \$ stack ghci -- Prelude> :set -XOverloadedStrings -- Prelude> import Turtle -- Prelude Turtle> `cd` \"/tmp\"@@ -556,7 +570,7 @@ -- Let's illustrate this by adding types to our original script: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > import Turtle -- > @@ -590,17 +604,17 @@ -- > -- v v -- > main :: IO () ----- Not every top-level value has to be a subroutine, though. For example, you--- can define unadorned `Text` values at the top-level, as we saw previously:+-- Not every top-level value has to be a subroutine, though. For example, you+-- can define unadorned `Line` values at the top-level, as we saw previously: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Turtle -- > --- > str :: Text+-- > str :: Line -- > str = "Hello!" -- > -- > main :: IO ()@@ -614,7 +628,7 @@ -- Let's test this out by providing an incorrect type for @\'str\'@: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -638,21 +652,21 @@ -- > In an equation for `str': str = "Hello, world!" -- > -- > example.hs:11:13:--- > Couldn't match expected type `Text' with actual type `Int'+-- > Couldn't match expected type `Line' with actual type `Int' -- > In the first argument of `echo', namely `str' -- > In the expression: echo str -- > In an equation for `main': main = echo str -- -- The first error message relates to the @OverloadedStrings@ extensions. When -- we enable @OverloadedStrings@ the compiler overloads string literals,--- interpreting them as any type that implements the `IsString` interface. The+-- interpreting them as any type that implements the `IsString` interface. The -- error message says that `Int` does not implement the `IsString` interface so -- the compiler cannot interpret a string literal as an `Int`. On the other--- hand the `Text` and `Turtle.FilePath` types do implement `IsString`, which--- is why we can interpret string literals as `Text` or `Turtle.FilePath`--- values.+-- hand the `Text`, `Line` and `Turtle.FilePath` types do implement `IsString`,+-- which is why we can interpret string literals as `Text`, `Line` or+-- `Turtle.FilePath` values. ----- The second error message says that `echo` expects a `Text` value, but we+-- The second error message says that `echo` expects a `Line` value, but we -- declared @str@ to be an `Int`, so the compiler aborts compilation, requiring -- us to either fix or delete our type signature. --@@ -666,13 +680,13 @@ -- a string: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Turtle -- > --- > str :: Text+-- > str :: Line -- > str = 4 -- > -- > main :: IO ()@@ -683,16 +697,16 @@ -- > $ ./example.hs -- > -- > example.hs:8:7:--- > No instance for (Num Text)+-- > No instance for (Num Line) -- > arising from the literal `4'--- > Possible fix: add an instance declaration for (Num Text)+-- > Possible fix: add an instance declaration for (Num Line) -- > In the expression: 4 -- > In an equation for `str': str = 4 -- -- Haskell also automatically overloads numeric literals, too. The compiler -- interprets integer literals as any type that implements the `Num` interface.--- The `Text` type does not implement the `Num` interface, so we cannot--- interpret integer literals as `Text` strings.+-- The `Line` type does not implement the `Num` interface, so we cannot+-- interpret integer literals as `Line` strings. -- $system --@@ -702,7 +716,7 @@ -- -- @ -- #!\/usr\/bin\/env stack--- \-\- stack \-\-install-ghc runghc \-\-package turtle+-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- {-\# LANGUAGE OverloadedStrings \#-} --@@ -733,7 +747,7 @@ -- @ -- `shell` -- :: Text -- Command line--- -> Shell Text -- Standard input (as lines of \`Text\`)+-- -> Shell Line -- Standard input (as lines of \`Text\`) -- -> IO `ExitCode` -- Exit code of the shell command -- @ --@@ -747,7 +761,7 @@ -- -- @ -- #!\/usr\/bin\/env stack--- \-\- stack \-\-install-ghc runghc \-\-package turtle+-- \-\- stack \-\-resolver lts-10.2 script -- -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -774,7 +788,7 @@ -- `proc` -- :: Text -- Program -- -> [Text] -- Arguments--- -> Shell Text -- Standard input (as lines of \`Text\`)+-- -> Shell Line -- Standard input (as lines of \`Text\`) -- -> IO ExitCode -- Exit code of the shell command -- @ --@@ -868,9 +882,9 @@ -- > FilePath "/tmp/.X0-lock" -- > FilePath "/tmp/pulse-PKdhtXMmr18n" -- > FilePath "/tmp/pulse-xHYcZ3zmN3Fv"--- > FilePath "/tmp/tracker-gabriel"+-- > FilePath "/tmp/tracker-gabriella" -- > FilePath "/tmp/pulse-PYi1hSlWgNj2"--- > FilePath "/tmp/orbit-gabriel"+-- > FilePath "/tmp/orbit-gabriella" -- > FilePath "/tmp/ssh-vREYGbWGpiCa" -- > FilePath "/tmp/.ICE-unix --@@ -928,7 +942,7 @@ -- @ -- Prelude Turtle> view (`liftIO` readline) -- ABC\<Enter\>--- Just \"ABC\"+-- Just (Line "ABC") -- @ -- -- Another way to say that is:@@ -977,9 +991,9 @@ -- > FilePath "/tmp/.X0-lock" -- > FilePath "/tmp/pulse-PKdhtXMmr18n" -- > FilePath "/tmp/pulse-xHYcZ3zmN3Fv"--- > FilePath "/tmp/tracker-gabriel"+-- > FilePath "/tmp/tracker-gabriella" -- > FilePath "/tmp/pulse-PYi1hSlWgNj2"--- > FilePath "/tmp/orbit-gabriel"+-- > FilePath "/tmp/orbit-gabriella" -- > FilePath "/tmp/ssh-vREYGbWGpiCa" -- > FilePath "/tmp/.ICE-unix" -- > FilePath "/usr/lib"@@ -1020,7 +1034,7 @@ -- We can use `select` to implement loops within a `Shell`: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} --@@ -1042,6 +1056,34 @@ -- > (2,3) -- > (2,4) --+-- This is because `Shell` behaves like a list comprehension, running each+-- following command once for each element in the stream. This implies that+-- an `Shell` stream that produces 0 elements will short-circuit and prevent+-- subsequent commands from being run.+--+-- > -- This stream emits 0 elements but still has side effects+-- > inner :: Shell a+-- > inner = do+-- > x <- select [1, 2]+-- > y <- select [3, 4]+-- > liftIO (print (x, y))+-- > empty+-- > +-- > outer :: Shell ()+-- > outer = do+-- > inner+-- > liftIO (echo "This step will never run")+--+-- If you want to run a `Shell` stream just for its side effects, wrap the+-- `Shell` with `sh`. This ensures that you don't alter the surrounding+-- `Shell`'s control flow by unintentionally running subsequent commands zero+-- times or multiple times:+--+-- > outer :: Shell ()+-- > outer = do+-- > sh inner+-- > liftIO (echo "Now this step will exactly once")+-- -- This uses the `sh` utility instead of `view`. The only difference is that -- `sh` doesn't print any values (since `print` is doing that already): --@@ -1067,11 +1109,41 @@ -- > FilePath "/tmp/.X0-lock" -- > FilePath "/tmp/pulse-PKdhtXMmr18n" -- > FilePath "/tmp/pulse-xHYcZ3zmN3Fv"--- > FilePath "/tmp/tracker-gabriel"+-- > FilePath "/tmp/tracker-gabriella" -- > FilePath "/tmp/pulse-PYi1hSlWgNj2"--- > FilePath "/tmp/orbit-gabriel"+-- > FilePath "/tmp/orbit-gabriella" -- > FilePath "/tmp/ssh-vREYGbWGpiCa" -- > FilePath "/tmp/.ICE-unix"+--+-- You can filter streams using @"Control.Monad".`Control.Monad.mfilter`@, like+-- this:+--+-- >>> view (select [1..10])+-- 1+-- 2+-- 3+-- 4+-- 5+-- 6+-- 7+-- 8+-- 9+-- 10+-- >>> view (mfilter even (select [1..10]))+-- 2+-- 4+-- 6+-- 8+-- 10+--+-- This works because `Control.Monad.mfilter`'s implementation is equivalent to:+--+-- > mfilter predicate stream = do+-- > element <- stream+-- > if predicate element then return element else empty+--+-- In other words, `Control.Monad.mfilter` loops over each @element@ of the+-- @stream@ and only `return`s the element if the @predicate@ is `True` -- $folds --@@ -1092,8 +1164,8 @@ -- @ -- Prelude Turtle Fold> `fold` (ls \"\/tmp\") Fold.list -- [FilePath \"\/tmp\/.X11-unix\",FilePath \"\/tmp\/.X0-lock\",FilePath \"\/tmp\/pulse-PKd--- htXMmr18n\",FilePath \"\/tmp\/pulse-xHYcZ3zmN3Fv\",FilePath \"\/tmp\/tracker-gabriel--- \",FilePath \"\/tmp\/pulse-PYi1hSlWgNj2\",FilePath \"\/tmp\/orbit-gabriel\",FilePath +-- htXMmr18n\",FilePath \"\/tmp\/pulse-xHYcZ3zmN3Fv\",FilePath \"\/tmp\/tracker-gabriella+-- \",FilePath \"\/tmp\/pulse-PYi1hSlWgNj2\",FilePath \"\/tmp\/orbit-gabriella\",FilePath -- \"\/tmp\/ssh-vREYGbWGpiCa\",FilePath \"\/tmp\/.ICE-unix\"] -- @ --@@ -1112,13 +1184,13 @@ -- For example, you can write to standard output using the `stdout` utility: -- -- @--- `stdout` :: Shell Text -> IO ()+-- `stdout` :: Shell Line -> IO () -- `stdout` s = sh (do -- txt <- s -- liftIO (echo txt) ) -- @ ----- `stdout` outputs each `Text` value on its own line:+-- `stdout` outputs each `Line` value on its own line: -- -- > Prelude Turtle> stdout "Line 1" -- > Line 1@@ -1126,18 +1198,18 @@ -- > Line 1 -- > Line 2 ----- Another useful stream is `stdin`, which emits one line of `Text` per line of+-- Another useful stream is `stdin`, which emits one `Line` value per line of -- standard input: -- -- @--- `stdin` :: Shell Text+-- `stdin` :: Shell Line -- @ -- -- Let's combine `stdin` and `stdout` to forward all input from standard input -- to standard output: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} --@@ -1182,9 +1254,9 @@ -- > .X0-lock -- > pulse-PKdhtXMmr18n -- > pulse-xHYcZ3zmN3Fv--- > tracker-gabriel+-- > tracker-gabriella -- > pulse-PYi1hSlWgNj2--- > orbit-gabriel+-- > orbit-gabriella -- > ssh-vREYGbWGpiCa -- > .ICE-unix --@@ -1193,8 +1265,8 @@ -- @ -- `inshell` -- :: Text -- Command line--- -> Shell Text -- Standard input to feed to program--- -> Shell Text -- Standard output produced by program+-- -> Shell Line -- Standard input to feed to program+-- -> Shell Line -- Standard output produced by program -- @ -- -- This means you can use `inshell` to embed arbitrary external utilities as@@ -1211,8 +1283,8 @@ -- `inproc` -- :: Text -- Program -- -> [Text] -- Arguments--- -> Shell Text -- Standard input to feed to program--- -> Shell Text -- Standard output produced by program+-- -> Shell Line -- Standard input to feed to program+-- -> Shell Line -- Standard output produced by program -- @ -- -- Using `inproc`, you would write:@@ -1237,7 +1309,7 @@ -- Let's look at the type of `grep`: -- -- @--- `grep` :: Pattern a -> Shell Text -> Shell Text+-- `grep` :: Pattern a -> Shell Line -> Shell Line -- @ -- -- The first argument of `grep` is actually a `Pattern`, which implements@@ -1378,7 +1450,7 @@ -- a `Shell`: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1404,7 +1476,7 @@ -- file and directory are still cleaned up correctly: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1421,10 +1493,10 @@ -- $monadio ----- If you are sick of having type `liftIO` everywhere, you can omit it. This--- is because all subroutines in @turtle@ are overloaded using the `MonadIO`--- type class, like our original `pwd` command where we first encountered the--- the `MonadIO` type:+-- If you are sick of having to type `liftIO` everywhere, you can omit it.+-- This is because all subroutines in @turtle@ are overloaded using the+-- `MonadIO` type class, like our original `pwd` command where we first+-- encountered the the `MonadIO` type: -- -- @ -- Prelude Turtle> :type pwd@@ -1468,7 +1540,7 @@ -- to: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1495,7 +1567,7 @@ -- positional arguments for the source and destination file, you can write: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > -- cp.hs -- >@@ -1509,7 +1581,7 @@ -- > <*> argPath "dest" "The destination file" -- > -- > main = do--- > (src, dest) <- options "A simple `cp` script" parser+-- > (src, dest) <- options "A simple `cp` utility" parser -- > cp src dest -- -- If you run the script without any arguments, you will get an auto-generated@@ -1560,7 +1632,7 @@ -- -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1609,7 +1681,7 @@ -- as short-hands for the flags: -- -- > #!/usr/bin/env stack--- > -- stack --install-ghc runghc --package turtle+-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1654,7 +1726,7 @@ -- > -- > parser :: Parser Command -- > parser--- > = fmap IncreaseVolume +-- > = fmap IncreaseVolume -- > (subcommand "up" "Turn the volume up" -- > (argInt "amount" "How much to increase the volume") ) -- > <|> fmap DecreaseVolume@@ -1664,8 +1736,8 @@ -- > main = do -- > x <- options "Volume adjuster" parser -- > case x of--- > IncreaseVolume n -> echo (format ("Increasing the volume by "%d) n)--- > DecreaseVolume n -> echo (format ("Decreasing the volume by "%d) n)+-- > IncreaseVolume n -> printf ("Increasing the volume by "%d%"\n") n+-- > DecreaseVolume n -> printf ("Decreasing the volume by "%d%"\n") n -- -- This will provide `--help` output at both the top level and for each -- subcommand:@@ -1721,12 +1793,37 @@ -- If you have more questions or need help learning the library, ask a question -- on Stack Overflow under the @haskell-turtle@ tag. For bugs or feature -- requests, create an issue on Github at--- <https://github.com/Gabriel439/Haskell-Turtle-Library/issues>+-- <https://github.com/Gabriella439/turtle/issues> -- -- This library provides an extended suite of Unix-like utilities, but would -- still benefit from adding more utilities for better parity with the Unix -- ecosystem. Pull requests to add new utilities are highly welcome! +-- $nix+--+-- You can also turn `turtle` scripts into runnable scripts using Nix, like+-- this:+--+-- > #! /usr/bin/env nix-shell+-- > #! nix-shell -i runghc --packages "ghc.withPackages (x: [ x.turtle ])"+-- > +-- > {-# LANGUAGE OverloadedStrings #-}+-- > +-- > import Turtle+-- > +-- > main = echo "Hello, world!"+--+-- ... or create an auto-reloading script like this:+--+-- > #! /usr/bin/env nix-shell+-- > #! nix-shell -i "ghcid -T main" --packages ghcid "ghc.withPackages (x: [ x.turtle ])"+-- > +-- > {-# LANGUAGE OverloadedStrings #-}+-- > +-- > import Turtle+-- > +-- > main = echo "Hello, world!"+ -- $faq -- -- These are the most frequently asked questions from new users:@@ -1777,3 +1874,11 @@ -- /Answer:/ Use `runManaged`, `sh`, or (`<|>`) (all resources acquired in the -- left stream will close before beginning the right stream). Alternatively, -- use `with` to acquire a resource for a limited scope.+--+-- /Question:/ How do I use @turtle@ to run another shell as a subprocess?+--+-- /Answer:/ Use `Turtle.system` in conjunction with the `process` library,+-- like this:+--+-- > Turtle.system (System.Process.proc "/bin/sh" []) empty+
test/Main.hs view
@@ -3,4 +3,8 @@ import Test.DocTest main :: IO ()-main = doctest ["src/Turtle/Pattern.hs", "src/Turtle/Format.hs"]+main = doctest+ [ "src/Turtle/Pattern.hs"+ , "src/Turtle/Format.hs"+ , "src/Turtle/Line.hs"+ ]
+ test/RegressionBrokenPipe.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad+import System.Timeout+import Turtle+import qualified Turtle.Bytes as Bytes++main :: IO ()+main = do+ echo "proc (text)"+ void $ timeout duration $ forever $ proc "true" [] message+ echo "procStrict (text)"+ void $ timeout duration $ forever $ procStrict "true" [] message+ echo "procStrictWithErr (text)"+ void $ timeout duration $ forever $ procStrictWithErr "true" [] message+ echo "proc (bytes)"+ void $ timeout duration $ forever $ Bytes.proc "true" [] message+ echo "procStrict (bytes)"+ void $ timeout duration $ forever $ Bytes.procStrict "true" [] message+ echo "procStrictWithErr (bytes)"+ void $ timeout duration $ forever $ Bytes.procStrictWithErr "true" [] message+ where+ message :: IsString s => s+ message = "foobarbaz"+ duration = 3 * 10^ (6 :: Int)
+ test/RegressionMaskingException.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}++import Turtle++-- This test fails by hanging+main :: IO ()+main = runManaged (do+ _ <- fork (shells "while true; do sleep 1; done" empty)+ sleep 1+ return () )
+ test/cptree.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++import Turtle+import System.IO.Temp (withSystemTempDirectory)+import qualified Control.Monad.Fail as Fail+import Control.Monad (unless)++check :: String -> Bool-> IO ()+check errorMessage successs = unless successs $ Fail.fail errorMessage++main :: IO ()+main = withSystemTempDirectory "tempDir" (runTest . fromString)++runTest :: Turtle.FilePath -> IO ()+runTest tempDir = do+ let srcDirectory = tempDir </> "src"++ mktree $ srcDirectory </> "directory"+ touch $ srcDirectory </> "directory" </> "file"++ let destDirectory = tempDir </> "dest"++ cptree srcDirectory destDirectory++ testdir (destDirectory </> "directory") >>= check "cptree did not preserve directory"+ testfile (destDirectory </> "directory" </> "file") >>= check "cptree did not preserve directory"
+ test/system-filepath.hs view
@@ -0,0 +1,226 @@+{-# Language CPP #-}+{-# Options_GHC -Wno-deprecations #-}++module Main (main) where++import Test.Tasty+import Test.Tasty.HUnit+import Turtle++main :: IO ()+main = defaultMain $ testGroup "system-filepath tests"+ [ test_Root+ , test_Directory+ , test_Parent+ , test_CommonPrefix+ , test_StripPrefix+ , test_Collapse+ , test_Filename+ , test_Dirname+ , test_Basename+ , test_Absolute+ , test_Relative+ , test_SplitDirectories+ , test_SplitExtension+ ]++test_Root :: TestTree+test_Root = testCase "root" $ do+ "" @=? root ""+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ "c:\\" @=? root "c:\\"+ "c:\\" @=? root "c:\\foo"+#else+ "/" @=? root "/"+ "/" @=? root "/foo"+#endif+ "" @=? root "foo"++test_Directory :: TestTree+test_Directory = testCase "directory" $ do+ "./" @=? directory ""+ "/" @=? directory "/"+ "/foo/" @=? directory "/foo/bar"+ "/foo/bar/" @=? directory "/foo/bar/"+ "./" @=? directory "."+ "../" @=? directory ".."+ "../" @=? directory "../foo"+ "../foo/" @=? directory "../foo/"+ "./" @=? directory "foo"+ "foo/" @=? directory "foo/bar"++test_Parent :: TestTree+test_Parent = testCase "parent" $ do+ -- The behavior in the presence of `.` / `..` is messed up, but that's how+ -- the old system-filepath package worked, so we're preserving that for+ -- backwards compatibility (for now)+ "./" @=? parent ""+ "./" @=? parent "."+ "./" @=? parent ".."+ "/" @=? parent "/.."+ "/" @=? parent "/."+ "./" @=? parent "./."+ "./" @=? parent "./.."+ "../" @=? parent "../.."+ "../" @=? parent "../."++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ "c:\\" @=? parent "c:\\"+#else+ "/" @=? parent "/"+#endif+ "./" @=? parent "foo"+ "./" @=? parent "./foo"+ "./foo/" @=? parent "foo/bar"+ "./foo/" @=? parent "foo/bar/"+ "./foo/" @=? parent "./foo/bar"+ "/" @=? parent "/foo"+ "/foo/" @=? parent "/foo/bar"++test_Filename :: TestTree+test_Filename = testCase "filename" $ do+ "" @=? filename ""+ "" @=? filename "."+ "" @=? filename ".."+ "" @=? filename "/"+ "" @=? filename "/foo/"+ "bar" @=? filename "/foo/bar"+ "bar.txt" @=? filename "/foo/bar.txt"++test_Dirname :: TestTree+test_Dirname = testCase "dirname" $ do+ "" @=? dirname ""+ "" @=? dirname "/"+ "" @=? dirname "foo"+ ".." @=? dirname ".."+ "foo" @=? dirname "foo/bar"+ "bar" @=? dirname "foo/bar/"+ "bar" @=? dirname "foo/bar/baz.txt"++ -- the directory name will be re-parsed to a file name.+ let dirnameExts q = snd (splitExtensions (dirname q))+ ["d"] @=? dirnameExts "foo.d/bar"++test_Basename :: TestTree+test_Basename = testCase "basename" $ do+ "" @=? basename ".."+ "" @=? basename "/"+ "" @=? basename "."+ ".txt" @=? basename ".txt"+ "foo" @=? basename "foo.txt"+ "bar" @=? basename "foo/bar.txt"++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ "bar" @=? basename "c:\\foo\\bar"+ "bar" @=? basename "c:\\foo\\bar.txt"+#else+ "bar" @=? basename "/foo/bar"+ "bar" @=? basename "/foo/bar.txt"+#endif++test_Absolute :: TestTree+test_Absolute = testCase "absolute" $ do+ let myAssert q = assertBool ("absolute " ++ show q) $ absolute q+ let myAssert' q = assertBool ("not $ absolute " ++ show q) $ not $ absolute q++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ myAssert "c:\\"+ myAssert "c:\\foo\\bar"+ myAssert' ""+ myAssert' "foo\\bar"+ myAssert' "\\foo\\bar"+#else+ myAssert "/"+ myAssert "/foo/bar"+ myAssert' ""+ myAssert' "foo/bar"+#endif+++test_Relative :: TestTree+test_Relative = testCase "relative" $ do+ let myAssert q = assertBool ("relative " ++ show q) $ relative q+ let myAssert' q = assertBool ("not $ relative " ++ show q) $ not $ relative q++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ myAssert' "c:\\"+ myAssert' "c:\\foo\\bar"+ myAssert ""+ myAssert "foo\\bar"+#else+ myAssert' "/"+ myAssert' "/foo/bar"+ myAssert ""+ myAssert "foo/bar"+#endif++test_CommonPrefix :: TestTree+test_CommonPrefix = testCase "commonPrefix" $ do+ "" @=? commonPrefix []+ "./" @=? commonPrefix [".", "."]+ "" @=? commonPrefix [".", ".."]+ "foo/" @=? commonPrefix ["foo/bar", "foo/baz"]+ "foo/a.b" @=? commonPrefix ["foo/a.b.c", "foo/a.b.d"]+ "" @=? commonPrefix ["foo/", "bar/"]++test_StripPrefix :: TestTree+test_StripPrefix = testCase "stripPrefix" $ do+ Just "" @=? stripPrefix "" ""+ Just "/" @=? stripPrefix "" "/"+ Just "" @=? stripPrefix "/" "/"+ Just "foo" @=? stripPrefix "/" "/foo"+ Just "foo" @=? stripPrefix "./" "./foo"+ Just "foo.ext" @=? stripPrefix "./" "./foo.ext"+ Just "foo/bar" @=? stripPrefix "/" "/foo/bar"+ Just "bar" @=? stripPrefix "/foo/" "/foo/bar"+ Just "bar/baz" @=? stripPrefix "/foo/" "/foo/bar/baz"+ Just ".txt" @=? stripPrefix "/foo/bar" "/foo/bar.txt"+ Just ".gz" @=? stripPrefix "/foo/bar.txt" "/foo/bar.txt.gz"++ -- Test ignoring non-matching prefixes+ Nothing @=? stripPrefix "/foo" "/foo/bar"+ Nothing @=? stripPrefix "/foo/bar/baz" "/foo"+ Nothing @=? stripPrefix "/foo/baz/" "/foo/bar/qux"+ Nothing @=? stripPrefix "/foo/bar/baz" "/foo/bar/qux"++test_Collapse :: TestTree+test_Collapse = testCase "collapse" $ do+ -- This behavior differs from the old `system-filepath` package, but this+ -- behavior is more correct in the presence of symlinks+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ "foo\\..\\bar" @=? collapse "foo/../bar"+ "foo\\bar" @=? collapse "foo/bar"+ "foo\\bar" @=? collapse "foo/./bar"+#else+ "foo/../bar" @=? collapse "foo/../bar"+ "foo/bar" @=? collapse "foo/bar"+ "foo/bar" @=? collapse "foo/./bar"+#endif++test_SplitDirectories :: TestTree+test_SplitDirectories = testCase "splitDirectories" $ do+ [] @=? splitDirectories ""+ ["./"] @=? splitDirectories "."+ ["../"] @=? splitDirectories ".."+ ["foo/", "../"] @=? splitDirectories "foo/.."+ ["foo/", "./"] @=? splitDirectories "foo/."+ ["/"] @=? splitDirectories "/"+ ["/", "a"] @=? splitDirectories "/a"+ ["/", "ab/", "cd"] @=? splitDirectories "/ab/cd"+ ["/", "ab/", "cd/"] @=? splitDirectories "/ab/cd/"+ ["ab/", "cd"] @=? splitDirectories "ab/cd"+ ["ab/", "cd/"] @=? splitDirectories "ab/cd/"+ ["ab/", "cd.txt"] @=? splitDirectories "ab/cd.txt"+ ["ab/", "cd/", ".txt"] @=? splitDirectories "ab/cd/.txt"+ ["ab/", "./", "cd"] @=? splitDirectories "ab/./cd"++test_SplitExtension :: TestTree+test_SplitExtension = testCase "splitExtension" $ do+ ("", Nothing) @=? splitExtension ""+ ("foo", Nothing) @=? splitExtension "foo"+ ("foo", Just "") @=? splitExtension "foo."+ ("foo", Just "a") @=? splitExtension "foo.a"+ ("foo.a/", Nothing) @=? splitExtension "foo.a/"+ ("foo.a/bar", Nothing) @=? splitExtension "foo.a/bar"+ ("foo.a/bar", Just "b") @=? splitExtension "foo.a/bar.b"+ ("foo.a/bar.b", Just "c") @=? splitExtension "foo.a/bar.b.c"
turtle.cabal view
@@ -1,14 +1,13 @@ Name: turtle-Version: 1.2.8+Version: 1.6.2 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-File: LICENSE-Copyright: 2015 Gabriel Gonzalez-Author: Gabriel Gonzalez-Maintainer: Gabriel439@gmail.com-Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1-Bug-Reports: https://github.com/Gabriel439/Haskell-Turtle-Library/issues+Copyright: 2015 Gabriella Gonzalez+Author: Gabriella Gonzalez+Maintainer: GenuineGabriella@gmail.com+Bug-Reports: https://github.com/Gabriella439/turtle/issues Synopsis: Shell programming, Haskell-style Description: @turtle@ is a reimplementation of the Unix command line environment in Haskell so that you can use Haskell as both a shell and a scripting@@ -22,7 +21,7 @@ . * Portability: Works on Windows, OS X, and Linux .- * Exception safety: Safely acquire and release resources + * Exception safety: Safely acquire and release resources . * Streaming: Transform or fold command output in constant space .@@ -30,7 +29,7 @@ . * Formatting: Type-safe @printf@-style text formatting .- * Modern: Supports @text@ and @system-filepath@+ * Modern: Supports @text@ . Read "Turtle.Tutorial" for a detailed tutorial or "Turtle.Prelude" for a quick-start guide@@ -40,42 +39,82 @@ then you should also check out the @Shelly@ library which provides similar functionality. Category: System++Tested-With:+ GHC == 9.6.1+ GHC == 9.4.4+ GHC == 9.2.7+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2++Extra-Source-Files:+ CHANGELOG.md+ Source-Repository head Type: git- Location: https://github.com/Gabriel439/Haskell-Turtle-Library+ Location: https://github.com/Gabriella439/turtle +Flag new-deps+ Description: Use new versions of ansi-wl-pprint and optparse-applicative+ Manual: False+ Default: True+ Library HS-Source-Dirs: src Build-Depends:- base >= 4.6 && < 5 ,- async >= 2.0.0.0 && < 2.2,- clock >= 0.4.1.2 && < 0.8,- directory >= 1.0.7 && < 1.3,- foldl >= 1.1 && < 1.3,- hostname < 1.1,- managed >= 1.0.3 && < 1.1,- process >= 1.0.1.1 && < 1.5,- system-filepath >= 0.3.1 && < 0.5,- system-fileio >= 0.2.1 && < 0.4,- stm < 2.5,- temporary < 1.3,- text < 1.3,- time < 1.7,- transformers >= 0.2.0.0 && < 0.6,- optparse-applicative >= 0.11 && < 0.13,- optional-args >= 1.0 && < 2.0+ -- 2021-09-07: Turtle.Prelude uses GHC-8.0 features, so base >= 4.9+ base >= 4.9 && < 5 ,+ async >= 2.0.0.0 && < 2.3 ,+ bytestring >= 0.9.1.8 && < 0.12,+ clock >= 0.4.1.2 && < 0.9 ,+ containers >= 0.5.0.0 && < 0.7 ,+ directory >= 1.3.1.0 && < 1.4 ,+ exceptions >= 0.4 && < 0.11,+ filepath >= 1.4.1.2 && < 1.5 ,+ foldl >= 1.1 && < 1.5 ,+ hostname < 1.1 ,+ managed >= 1.0.3 && < 1.1 ,+ process >= 1.0.1.1 && < 1.7 ,+ stm < 2.6 ,+ streaming-commons < 0.3 ,+ temporary < 1.4 ,+ text >= 1.0.0 && < 2.1 ,+ time < 1.13,+ transformers >= 0.2.0.0 && < 0.7 ,+ optional-args >= 1.0 && < 2.0 ,+ unix-compat >= 0.4 && < 0.8 if os(windows)- Build-Depends: Win32 >= 2.2.0.1 && < 2.4+ Build-Depends: Win32 >= 2.12 else- Build-Depends: unix >= 2.5.1.0 && < 2.8+ Build-Depends: unix >= 2.5.1.0 && < 2.9++ -- A possible Cabal issue makes it try an old version of ansi-wl-pprint+ -- even though a newer would work.+ -- See discussion in https://github.com/Gabriella439/turtle/pull/446+ if flag(new-deps)+ Build-Depends: ansi-wl-pprint >= 1.0 && < 1.1 ,+ optparse-applicative >= 0.18 && < 0.19+ else+ Build-Depends: ansi-wl-pprint >= 0.6 && < 1.0 ,+ optparse-applicative >= 0.16 && < 0.18+ Exposed-Modules: Turtle,+ Turtle.Bytes, Turtle.Format, Turtle.Pattern, Turtle.Shell, Turtle.Options,+ Turtle.Line, Turtle.Prelude, Turtle.Tutorial+ Other-Modules:+ Turtle.Internal GHC-Options: -Wall Default-Language: Haskell2010 @@ -87,8 +126,53 @@ Default-Language: Haskell2010 Build-Depends: base >= 4 && < 5 ,- doctest >= 0.7 && < 0.12+ doctest >= 0.7 +test-suite regression-broken-pipe+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: test+ Main-Is: RegressionBrokenPipe.hs+ GHC-Options: -Wall -threaded+ Default-Language: Haskell2010+ Build-Depends:+ base >= 4 && < 5,+ turtle++test-suite regression-masking-exception+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: test+ Main-Is: RegressionMaskingException.hs+ GHC-Options: -Wall -threaded+ Default-Language: Haskell2010+ Build-Depends:+ base >= 4 && < 5,+ turtle++test-suite cptree+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: test+ Main-Is: cptree.hs+ GHC-Options: -Wall -threaded+ Default-Language: Haskell2010+ Build-Depends:+ base >= 4 && < 5,+ temporary,+ filepath >= 0.4,+ turtle++test-suite system-filepath-tests+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: test+ Main-Is: system-filepath.hs+ GHC-Options: -Wall -threaded+ Default-Language: Haskell2010+ Build-Depends:+ base,+ filepath,+ tasty >=1.4 && <1.5,+ tasty-hunit >=0.10 && <0.11,+ turtle+ benchmark bench Type: exitcode-stdio-1.0 HS-Source-Dirs: bench@@ -96,7 +180,7 @@ GHC-Options: -O2 -Wall -threaded Default-Language: Haskell2010 Build-Depends:- base >= 4 && < 5 ,- criterion >= 0.4 && < 2 ,- text < 1.3,+ base >= 4 && < 5 ,+ tasty-bench >= 0.3.1 ,+ text < 1.3, turtle