diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,251 @@ +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` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017 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. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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] diff --git a/src/Turtle.hs b/src/Turtle.hs --- a/src/Turtle.hs +++ b/src/Turtle.hs @@ -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 @@ -77,7 +73,8 @@ , 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 @@ -87,6 +84,7 @@ , ExitCode(..) , IsString(..) , (&) + , (<&>) ) where import Turtle.Format @@ -119,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 @@ -129,25 +141,18 @@ , 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 __GLASGOW_HASKELL__ >= 710 @@ -160,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 diff --git a/src/Turtle/Bytes.hs b/src/Turtle/Bytes.hs --- a/src/Turtle/Bytes.hs +++ b/src/Turtle/Bytes.hs @@ -16,6 +16,12 @@ , append , stderr , strict + , compress + , decompress + , WindowBits(..) + , Zlib.defaultWindowBits + , fromUTF8 + , toUTF8 -- * Subprocess management , proc @@ -40,18 +46,18 @@ import Control.Applicative import Control.Concurrent.Async (Async, Concurrently(..)) -import Control.Foldl (FoldM(..)) 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 Filesystem.Path (FilePath) -import Prelude hiding (FilePath) +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(..), fold, sh) +import Turtle.Shell (Shell(..), FoldShell(..), fold, sh) import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.STM as STM @@ -62,7 +68,10 @@ 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 @@ -89,8 +98,7 @@ The chunks are not necessarily aligned to line boundaries -} inhandle :: Handle -> Shell ByteString -inhandle handle = Shell (\(FoldM step begin done) -> do - x0 <- begin +inhandle handle = Shell (\(FoldShell step begin done) -> do let loop x = do eof <- System.IO.hIsEOF handle if eof @@ -99,7 +107,7 @@ bytes <- Data.ByteString.hGetSome handle defaultChunkSize x' <- step x bytes loop $! x' - loop $! x0 ) + loop $! begin ) where -- Copied from `Data.ByteString.Lazy.Internal` defaultChunkSize :: Int @@ -485,9 +493,18 @@ -- ^ 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 @@ -512,26 +529,28 @@ mvar <- liftIO (MVar.newMVar False) let close handle = do MVar.modifyMVar_ mvar (\finalized -> do - Control.Monad.unless finalized (System.IO.hClose handle) + 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 (sh (do + restore (ignoreSIGPIPE (sh (do bytes <- s - liftIO (Data.ByteString.hPut hIn bytes) ) ) + 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 (Process.waitForProcess ph *> halt a) *> empty) + 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 @@ -556,15 +575,15 @@ mvar <- liftIO (MVar.newMVar False) let close handle = do MVar.modifyMVar_ mvar (\finalized -> do - Control.Monad.unless finalized (System.IO.hClose handle) + 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 (sh (do + restore (ignoreSIGPIPE (sh (do bytes <- s - liftIO (Data.ByteString.hPut hIn bytes) ) ) + liftIO (Data.ByteString.hPut hIn bytes) ) ) ) `Exception.finally` close hIn queue <- liftIO TQueue.newTQueueIO @@ -580,8 +599,7 @@ bytes <- inhandle hErr liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left bytes)))) )) `Exception.finally` STM.atomically (TQueue.writeTQueue queue Nothing) - let drain = Shell (\(FoldM step begin done) -> do - x0 <- begin + let drain = Shell (\(FoldShell step begin done) -> do let loop x numNothing | numNothing < 2 = do m <- STM.atomically (TQueue.readTQueue queue) @@ -591,7 +609,7 @@ x' <- step x e loop x' numNothing | otherwise = return x - x1 <- loop x0 (0 :: Int) + x1 <- loop begin (0 :: Int) done x1 ) a <- using @@ -611,12 +629,13 @@ _ <- r return () let waitAll = STM.atomically (Async.waitSTM a `also` (Async.waitSTM b `also` Async.waitSTM c)) - drain <|> (liftIO (Process.waitForProcess ph *> waitAll) *> empty) + 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`. This does /not/ throw an exception if the - command returns a non-zero exit code + @stderr@ are wrapped in `Left`. + + Throws an `ExitCode` exception if the command returns a non-zero exit code -} inprocWithErr :: Text @@ -633,11 +652,12 @@ {-| 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 does /not/ throw an - exception if the command returns a non-zero exit code + 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 @@ -647,3 +667,136 @@ -> 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 diff --git a/src/Turtle/Format.hs b/src/Turtle/Format.hs --- a/src/Turtle/Format.hs +++ b/src/Turtle/Format.hs @@ -42,10 +42,11 @@ module Turtle.Format ( -- * Format - Format + Format (..) , (%) , format , printf + , eprintf , makeFormat -- * Parameters @@ -73,9 +74,9 @@ 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 @@ -113,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)) @@ -205,9 +214,9 @@ l :: Format r (Line -> r) l = makeFormat Turtle.Line.lineToText --- | `Format` a `Filesystem.Path.CurrentOS.FilePath` into `Text` +-- | `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) diff --git a/src/Turtle/Internal.hs b/src/Turtle/Internal.hs --- a/src/Turtle/Internal.hs +++ b/src/Turtle/Internal.hs @@ -1,11 +1,17 @@ -module Turtle.Internal - ( ignoreSIGPIPE - ) where +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 @@ -14,3 +20,230 @@ | 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, []) diff --git a/src/Turtle/Line.hs b/src/Turtle/Line.hs --- a/src/Turtle/Line.hs +++ b/src/Turtle/Line.hs @@ -62,6 +62,11 @@ 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 diff --git a/src/Turtle/Options.hs b/src/Turtle/Options.hs --- a/src/Turtle/Options.hs +++ b/src/Turtle/Options.hs @@ -17,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 @@ -71,6 +71,7 @@ , subcommand , subcommandGroup , options + , optionsExt ) where @@ -82,9 +83,7 @@ import Data.Optional import Control.Applicative import Control.Monad.IO.Class -import Filesystem.Path.CurrentOS (FilePath, fromText) import Options.Applicative (Parser) -import Prelude hiding (FilePath) import Text.PrettyPrint.ANSI.Leijen (Doc, displayS, renderCompact) import Turtle.Line (Line) @@ -107,6 +106,30 @@ 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 @@ -135,6 +158,21 @@ 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 @@ -197,7 +235,7 @@ -- | 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 @@ -237,14 +275,14 @@ -- | 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 diff --git a/src/Turtle/Pattern.hs b/src/Turtle/Pattern.hs --- a/src/Turtle/Pattern.hs +++ b/src/Turtle/Pattern.hs @@ -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` diff --git a/src/Turtle/Prelude.hs b/src/Turtle/Prelude.hs --- a/src/Turtle/Prelude.hs +++ b/src/Turtle/Prelude.hs @@ -3,6 +3,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- | This module provides a large suite of utilities that resemble Unix -- utilities. @@ -108,8 +111,8 @@ echo , err , readline - , Filesystem.readTextFile - , Filesystem.writeTextFile + , Internal.readTextFile + , Internal.writeTextFile , arguments #if __GLASGOW_HASKELL__ >= 710 , export @@ -120,12 +123,18 @@ , cd , pwd , home + , readlink , realpath , mv , mkdir , mktree , cp , cptree + , cptreeL +#if !defined(mingw32_HOST_OS) + , symlink +#endif + , isNotSymbolicLink , rm , rmdir , rmtree @@ -169,12 +178,22 @@ , ls , lsif , lstree + , lsdepth , cat , grep + , grepText , sed + , sedPrefix + , sedSuffix + , sedEntire , onFiles , inplace + , inplacePrefix + , inplaceSuffix + , inplaceEntire + , update , find + , findtree , yes , nl , paste @@ -184,6 +203,15 @@ , cache , parallel , single + , uniq + , uniqOn + , uniqBy + , nub + , nubOn + , sort + , sortOn + , sortBy + , toLines -- * Folds , countChars @@ -214,7 +242,7 @@ , systemStrictWithErr -- * Permissions - , Permissions + , Permissions(..) , chmod , getmod , setmod @@ -222,12 +250,11 @@ , readable, nonreadable , writable, nonwritable , executable, nonexecutable - , searchable, nonsearchable - , ooo,roo,owo,oox,oos,rwo,rox,ros,owx,rwx,rws + , ooo,roo,owo,oox,rwo,rox,owx,rwx -- * File size , du - , Size + , Size(B, KB, MB, GB, TB, KiB, MiB, GiB, TiB) , sz , bytes , kilobytes @@ -254,6 +281,8 @@ , PosixCompat.isDirectory , PosixCompat.isSymbolicLink , PosixCompat.isSocket + , cmin + , cmax -- * Headers , WithHeader(..) @@ -274,26 +303,29 @@ 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, FoldM(..), genericLength, handles, list, premap) +import Control.Foldl (Fold(..), genericLength, handles, list, premap) import qualified Control.Foldl import qualified Control.Foldl.Text -import Control.Monad (guard, liftM, msum, when, unless, (>=>)) +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) +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 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) @@ -307,8 +339,9 @@ lookupEnv, #endif getEnvironment ) -import System.Directory (Permissions) 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 @@ -325,13 +358,14 @@ readDirStream, closeDirStream, touchFile ) +import System.Posix.Files (createSymbolicLink) #endif -import Prelude hiding (FilePath) +import Prelude hiding (lines) import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy) import Turtle.Shell -import Turtle.Format (Format, format, makeFormat, d, w, (%)) -import Turtle.Internal (ignoreSIGPIPE) +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 @@ -531,7 +565,7 @@ mvar <- newMVar False let close handle = do modifyMVar_ mvar (\finalized -> do - unless finalized (ignoreSIGPIPE (hClose handle)) + unless finalized (Internal.ignoreSIGPIPE (hClose handle)) return True ) let close' (Just hIn, ph) = do close hIn @@ -542,7 +576,7 @@ let handle (Just hIn, ph) = do let feedIn :: (forall a. IO a -> IO a) -> IO () feedIn restore = - restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn mask (\restore -> withAsync (feedIn restore) (\a -> restore (Process.waitForProcess ph) `finally` halt a) ) @@ -580,13 +614,13 @@ mvar <- newMVar False let close handle = do modifyMVar_ mvar (\finalized -> do - unless finalized (ignoreSIGPIPE (hClose handle)) + 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 (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn concurrently (mask (\restore -> @@ -623,13 +657,13 @@ mvar <- newMVar False let close handle = do modifyMVar_ mvar (\finalized -> do - unless finalized (ignoreSIGPIPE (hClose handle)) + 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 (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn + restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn runConcurrently $ (,,) <$> Concurrently (mask (\restore -> @@ -659,6 +693,8 @@ 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 @@ -669,9 +705,18 @@ -- ^ 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 @@ -696,21 +741,23 @@ mvar <- liftIO (newMVar False) let close handle = do modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) + 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 (outhandle hIn s) `finally` close hIn + 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 (Process.waitForProcess ph *> halt a) *> empty) + 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 @@ -735,12 +782,12 @@ mvar <- liftIO (newMVar False) let close handle = do modifyMVar_ mvar (\finalized -> do - unless finalized (hClose handle) + 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 (outhandle hIn s) `finally` close hIn + feedIn restore = restore (Internal.ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn queue <- liftIO TQueue.newTQueueIO let forwardOut :: (forall a. IO a -> IO a) -> IO () @@ -755,8 +802,7 @@ line <- inhandle hErr liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left line)))) )) `finally` STM.atomically (TQueue.writeTQueue queue Nothing) - let drain = Shell (\(FoldM step begin done) -> do - x0 <- begin + let drain = Shell (\(FoldShell step begin done) -> do let loop x numNothing | numNothing < 2 = do m <- STM.atomically (TQueue.readTQueue queue) @@ -766,7 +812,7 @@ x' <- step x e loop x' numNothing | otherwise = return x - x1 <- loop x0 (0 :: Int) + x1 <- loop begin (0 :: Int) done x1 ) a <- using @@ -783,12 +829,13 @@ _ <- r return () let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c)) - drain <|> (liftIO (Process.waitForProcess ph *> waitAll) *> empty) + 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`. This does /not/ throw an exception if the command - returns a non-zero exit code + are wrapped in `Left`. + + Throws an `ExitCode` exception if the command returns a non-zero exit code -} inprocWithErr :: Text @@ -802,14 +849,14 @@ 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 + @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 @@ -848,7 +895,11 @@ arguments = liftIO (fmap (map pack) getArgs) #if __GLASGOW_HASKELL__ >= 710 --- | Set or modify an environment variable +{-| 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)) @@ -871,9 +922,13 @@ where toTexts (key, val) = (pack key, pack val) --- | Change the current directory +{-| 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 (Filesystem.setWorkingDirectory path) +cd path = liftIO (Directory.setCurrentDirectory path) {-| Change the current directory. Once the current 'Shell' is done, it returns back to the original directory. @@ -892,15 +947,19 @@ -- | Get the current directory pwd :: MonadIO io => io FilePath -pwd = liftIO Filesystem.getWorkingDirectory +pwd = liftIO Directory.getCurrentDirectory -- | Get the home directory home :: MonadIO io => io FilePath -home = liftIO Filesystem.getHomeDirectory +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 (Filesystem.canonicalizePath path) +realpath path = liftIO (Directory.canonicalizePath path) #ifdef mingw32_HOST_OS fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag @@ -914,9 +973,8 @@ @\"..\"@ -} ls :: FilePath -> Shell FilePath -ls path = Shell (\(FoldM step begin done) -> do - x0 <- begin - let path' = Filesystem.encodeString path +ls path = Shell (\(FoldShell step begin done) -> do + let path' = path canRead <- fmap Directory.readable (Directory.getPermissions (deslash path')) @@ -924,34 +982,32 @@ reparse <- fmap reparsePoint (Win32.getFileAttributes path') if (canRead && not reparse) then bracket - (Win32.findFirstFile (Filesystem.encodeString (path "*"))) + (Win32.findFirstFile (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' /= "..") + 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 $! x0 ) - else done x0 ) + 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 + file <- readDirStream dirp + case file of "" -> done x _ -> do - let file = Filesystem.decodeString file' - x' <- if (file' /= "." && file' /= "..") + x' <- if (file /= "." && file /= "..") then step x (path file) else return x loop $! x' - loop $! x0 ) - else done x0 ) + loop $! begin ) + else done begin ) #endif {-| This is used to remove the trailing slash from a path, because @@ -974,6 +1030,29 @@ 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 @@ -999,11 +1078,11 @@ but the operation will not be atomic -} mv :: MonadIO io => FilePath -> FilePath -> io () -mv oldPath newPath = liftIO $ catchIOError (Filesystem.rename oldPath newPath) +mv oldPath newPath = liftIO $ catchIOError (Directory.renameFile oldPath newPath) (\ioe -> if ioeGetErrorType ioe == UnsupportedOperation -- certainly EXDEV then do - Filesystem.copyFile oldPath newPath - Filesystem.removeFile oldPath + Directory.copyFile oldPath newPath + Directory.removeFile oldPath else ioError ioe) {-| Create a directory @@ -1011,41 +1090,88 @@ Fails if the directory is present -} mkdir :: MonadIO io => FilePath -> io () -mkdir path = liftIO (Filesystem.createDirectory False path) +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 (Filesystem.createTree path) +mktree path = liftIO (Directory.createDirectoryIfMissing True path) -- | Copy a file cp :: MonadIO io => FilePath -> FilePath -> io () -cp oldPath newPath = liftIO (Filesystem.copyFile oldPath newPath) +cp oldPath newPath = liftIO (Directory.copyFile oldPath newPath) --- | Copy a directory tree +#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 <- lstree oldTree + 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 (Filesystem.stripPrefix (oldTree "") oldPath) + 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 (Filesystem.directory newPath) >> cp oldPath newPath + then mktree (FilePath.takeDirectory newPath) >> cp oldPath newPath else mktree newPath ) + -- | Remove a file rm :: MonadIO io => FilePath -> io () -rm path = liftIO (Filesystem.removeFile path) +rm path = liftIO (Directory.removeFile path) -- | Remove a directory rmdir :: MonadIO io => FilePath -> io () -rmdir path = liftIO (Filesystem.removeDirectory path) +rmdir path = liftIO (Directory.removeDirectory path) {-| Remove a directory tree (equivalent to @rm -r@) @@ -1069,11 +1195,11 @@ -- | Check if a file exists testfile :: MonadIO io => FilePath -> io Bool -testfile path = liftIO (Filesystem.isFile path) +testfile path = liftIO (Directory.doesFileExist path) -- | Check if a directory exists testdir :: MonadIO io => FilePath -> io Bool -testdir path = liftIO (Filesystem.isDirectory path) +testdir path = liftIO (Directory.doesDirectoryExist path) -- | Check if a path exists testpath :: MonadIO io => FilePath -> io Bool @@ -1094,7 +1220,7 @@ #ifdef mingw32_HOST_OS then do handle <- Win32.createFile - (Filesystem.encodeString file) + file Win32.gENERIC_WRITE Win32.fILE_SHARE_NONE Nothing @@ -1103,17 +1229,70 @@ Nothing (creationTime, _, _) <- Win32.getFileTime handle systemTime <- Win32.getSystemTimeAsFileTime - Win32.setFileTime handle creationTime systemTime systemTime + Win32.setFileTime handle (Just creationTime) (Just systemTime) (Just systemTime) #else - then touchFile (Filesystem.encodeString file) + 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 +> 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 @@ -1124,67 +1303,66 @@ -> io Permissions -- ^ Updated permissions chmod modifyPermissions path = liftIO (do - let path' = deslash (Filesystem.encodeString path) + let path' = deslash path permissions <- Directory.getPermissions path' - let permissions' = modifyPermissions permissions - changed = permissions /= permissions' - when changed (Directory.setPermissions path' permissions') - return permissions' ) + 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 (Filesystem.encodeString path) - Directory.getPermissions path' ) + 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 (Filesystem.encodeString path) - Directory.setPermissions path' permissions ) + 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 (Filesystem.encodeString sourcePath) - targetPath' = deslash (Filesystem.encodeString targetPath) + let sourcePath' = deslash sourcePath + targetPath' = deslash targetPath Directory.copyPermissions sourcePath' targetPath' ) -- | @+r@ readable :: Permissions -> Permissions -readable = Directory.setOwnerReadable True +readable p = p { _readable = True } -- | @-r@ nonreadable :: Permissions -> Permissions -nonreadable = Directory.setOwnerReadable False +nonreadable p = p { _readable = False } -- | @+w@ writable :: Permissions -> Permissions -writable = Directory.setOwnerWritable True +writable p = p { _writable = True } -- | @-w@ nonwritable :: Permissions -> Permissions -nonwritable = Directory.setOwnerWritable False +nonwritable p = p { _writable = False } -- | @+x@ executable :: Permissions -> Permissions -executable = Directory.setOwnerExecutable True +executable p = p { _executable = 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 +nonexecutable p = p { _executable = False } -- | @-r -w -x@ ooo :: Permissions -> Permissions -ooo = const Directory.emptyPermissions +ooo _ = Permissions + { _readable = False + , _writable = False + , _executable = False + } -- | @+r -w -x@ roo :: Permissions -> Permissions @@ -1198,10 +1376,6 @@ 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 @@ -1210,10 +1384,6 @@ 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 @@ -1222,10 +1392,6 @@ 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 @@ -1251,20 +1417,21 @@ whichAll :: FilePath -> Shell FilePath whichAll cmd = do Just paths <- need "PATH" - path <- select (Filesystem.splitSearchPathString . Text.unpack $ paths) + path <- select (fmap Text.unpack (Text.splitOn ":" paths)) let path' = path cmd True <- testfile path' - let handler :: IOError -> IO Permissions + let handler :: IOError -> IO Bool handler e = if isPermissionError e || isDoesNotExistError e - then return Directory.emptyPermissions + then return False else throwIO e - perms <- liftIO (getmod path' `catchIOError` handler) + let getIsExecutable = fmap _executable (getmod path') + isExecutable <- liftIO (getIsExecutable `catchIOError` handler) - guard (Directory.executable perms) + guard isExecutable return path' {-| Sleep for the given duration @@ -1323,10 +1490,8 @@ -- ^ 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')) + managed (withTempDirectory parent prefix')) {-| Create a temporary file underneath the given directory @@ -1345,11 +1510,10 @@ -- ^ 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) ) + withTempFile parent prefix' (\file' handle -> k (file', handle)) ) + return (file', handle) ) {-| Create a temporary file underneath the given directory @@ -1363,12 +1527,11 @@ -- ^ 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)) ) + withTempFile parent prefix' (\file' handle -> k (file', handle)) ) liftIO (hClose handle) - return (Filesystem.decodeString file') ) + return file' ) -- | Fork a thread, acquiring an `Async` value fork :: MonadManaged managed => IO a -> managed (Async a) @@ -1390,8 +1553,7 @@ -- | Read lines of `Text` from a `Handle` inhandle :: Handle -> Shell Line -inhandle handle = Shell (\(FoldM step begin done) -> do - x0 <- begin +inhandle handle = Shell (\(FoldShell step begin done) -> do let loop x = do eof <- IO.hIsEOF handle if eof @@ -1400,7 +1562,7 @@ txt <- Text.hGetLine handle x' <- step x (unsafeTextToLine txt) loop $! x' - loop $! x0 ) + loop $! begin ) -- | Stream lines of `Text` to standard output stdout :: MonadIO io => Shell Line -> io () @@ -1440,27 +1602,31 @@ -- | Acquire a `Managed` read-only `Handle` from a `FilePath` readonly :: MonadManaged managed => FilePath -> managed Handle -readonly file = using (managed (Filesystem.withTextFile file IO.ReadMode)) +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 (Filesystem.withTextFile file IO.WriteMode)) +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 (Filesystem.withTextFile file IO.AppendMode)) +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 pattern s = do - line <- s - _:_ <- return (match pattern (lineToText line)) - return 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 @@ -1474,43 +1640,88 @@ 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)) +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)) + 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 Filesystem.fromText . f . getRights . fmap Filesystem.toText - where - getRights :: forall a. Shell (Either a Text) -> Shell Text - getRights s = s >>= either (const empty) return - +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 pattern file = liftIO (runManaged (do - here <- pwd +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 (sed pattern (input file)) + + outhandle handle (f (input file)) + liftIO (hClose handle) + copymod file tmpfile - mv tmpfile file )) + mv tmpfile file )) -- | Search a directory recursively for all files matching the given `Pattern` find :: Pattern a -> FilePath -> Shell FilePath -find pattern dir = do +find pattern' dir = do path <- lsif isNotSymlink dir - Right txt <- return (Filesystem.toText path) - _:_ <- return (match pattern txt) + + let txt = Text.pack path + + _:_ <- return (match pattern' txt) + return path where isNotSymlink :: FilePath -> IO Bool @@ -1518,23 +1729,52 @@ 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 _foldIO' +nl s = Shell _foldShell' where - _foldIO' (FoldM step begin done) = _foldIO s (FoldM step' begin' done') + _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' = do - x0 <- begin - return (x0, 0) + begin' = (begin, 0) done' (x, _) = done x data ZipState a b = Empty | HasA a | HasAB a b | Done @@ -1545,14 +1785,12 @@ truncated -} paste :: Shell a -> Shell b -> Shell (a, b) -paste sA sB = Shell _foldIOAB +paste sA sB = Shell _foldShellAB where - _foldIOAB (FoldM stepAB beginAB doneAB) = do - x0 <- beginAB - + _foldShellAB (FoldShell stepAB beginAB doneAB) = do tvar <- STM.atomically (STM.newTVar Empty) - let begin = return () + let begin = () let stepA () a = STM.atomically (do x <- STM.readTVar tvar @@ -1566,7 +1804,7 @@ Empty -> STM.writeTVar tvar Done Done -> return () _ -> STM.retry ) - let foldA = FoldM stepA begin doneA + let foldA = FoldShell stepA begin doneA let stepB () b = STM.atomically (do x <- STM.readTVar tvar @@ -1580,10 +1818,10 @@ HasA _ -> STM.writeTVar tvar Done Done -> return () _ -> STM.retry ) - let foldB = FoldM stepB begin doneB + let foldB = FoldShell stepB begin doneB - withAsync (foldIO sA foldA) (\asyncA -> do - withAsync (foldIO sB foldB) (\asyncB -> do + withAsync (_foldShell sA foldA) (\asyncA -> do + withAsync (_foldShell sB foldB) (\asyncB -> do let loop x = do y <- STM.atomically (do z <- STM.readTVar tvar @@ -1598,29 +1836,32 @@ Just ab -> do x' <- stepAB x ab loop $! x' - x' <- loop $! x0 + x' <- loop $! beginAB wait asyncA wait asyncB doneAB x' ) ) -- | A `Shell` that endlessly emits @()@ endless :: Shell () -endless = Shell (\(FoldM step begin _) -> do - x0 <- begin +endless = Shell (\(FoldShell step begin _) -> do let loop x = do x' <- step x () loop $! x' - loop $! x0 ) + loop $! begin ) --- | Limit a `Shell` to a fixed number of values +{-| 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 (\(FoldM step begin done) -> do +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 - foldIO s (FoldM step' begin done) ) + _foldShell s (FoldShell step' begin done) ) {-| Limit a `Shell` to values that satisfy the predicate @@ -1628,14 +1869,14 @@ predicate -} limitWhile :: (a -> Bool) -> Shell a -> Shell a -limitWhile predicate s = Shell (\(FoldM step begin done) -> do +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 - foldIO s (FoldM step' begin done) ) + _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 @@ -1684,7 +1925,7 @@ -- | 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) +cut pattern' txt = head (match (selfless chars `sepBy` pattern') txt) -- This `head` should be safe ... in theory -- | Get the current time @@ -1693,7 +1934,7 @@ -- | Get the time a file was last modified datefile :: MonadIO io => FilePath -> io UTCTime -datefile path = liftIO (Filesystem.getModified path) +datefile path = liftIO (Directory.getModificationTime path) -- | Get the size of a file or a directory du :: MonadIO io => FilePath -> io Size @@ -1705,9 +1946,9 @@ let sizes = do child <- lstree path True <- testfile child - liftIO (Filesystem.getSize child) + liftIO (Directory.getFileSize child) fold sizes Control.Foldl.sum - else Filesystem.getSize path + else Directory.getFileSize path return (Size size) ) {-| An abstract file size @@ -1750,41 +1991,147 @@ 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 -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@) @@ -1817,7 +2164,7 @@ -- | Get the status of a file stat :: MonadIO io => FilePath -> io PosixCompat.FileStatus -stat = liftIO . PosixCompat.getFileStatus . Filesystem.encodeString +stat = liftIO . PosixCompat.getFileStatus -- | Size of the file in bytes. Does not follow symlinks fileSize :: PosixCompat.FileStatus -> Size @@ -1837,7 +2184,7 @@ -- | Get the status of a file, but don't follow symbolic links lstat :: MonadIO io => FilePath -> io PosixCompat.FileStatus -lstat = liftIO . PosixCompat.getSymbolicLinkStatus . Filesystem.encodeString +lstat = liftIO . PosixCompat.getSymbolicLinkStatus data WithHeader a = Header a @@ -1851,7 +2198,7 @@ header :: Shell a -> Shell (WithHeader a) header (Shell k) = Shell k' where - k' (FoldM step begin done) = k (FoldM step' begin' done') + k' (FoldShell step begin done) = k (FoldShell step' begin' done') where step' (Pair x Nothing ) a = do x' <- step x (Header a) @@ -1860,23 +2207,138 @@ x' <- step x (Row a b) return (Pair x' (Just a)) - begin' = do - x <- begin - return (Pair x Nothing) + begin' = Pair begin Nothing done' (Pair x _) = done x --- | Returns the result of a 'Shell' that outputs a single --- line: +-- | 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 --- > Just directory <- single (inshell "pwd" empty) +-- > directory <- single (inshell "pwd" empty) -- > print directory -single :: MonadIO io => Shell a -> io (Maybe a) +single :: MonadIO io => Shell a -> io a single s = do as <- fold s Control.Foldl.list case as of - [a] -> return (Just a) + [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' diff --git a/src/Turtle/Shell.hs b/src/Turtle/Shell.hs --- a/src/Turtle/Shell.hs +++ b/src/Turtle/Shell.hs @@ -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,12 +75,15 @@ , 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) @@ -82,17 +92,70 @@ 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 ()) @@ -104,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 @@ -139,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 @@ -167,9 +241,25 @@ -- | Convert a list to a `Shell` that emits each element of the list select :: Foldable f => f a -> Shell a -select as = Shell (\(FoldM step begin done) -> do - x0 <- begin +select as = Shell (\(FoldShell step begin done) -> do let step' a k x = do x' <- step x a k $! x' - Data.Foldable.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 + ) diff --git a/src/Turtle/Tutorial.hs b/src/Turtle/Tutorial.hs --- a/src/Turtle/Tutorial.hs +++ b/src/Turtle/Tutorial.hs @@ -47,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: - + 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 @@ -116,6 +116,9 @@ -- * Conclusion -- $conclusion + -- * Nix scripts + -- $nix + -- * FAQ -- $faq ) where @@ -129,7 +132,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -194,7 +197,7 @@ -- difference: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -211,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 #-} -- > @@ -227,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 #-} -- > @@ -244,7 +247,7 @@ -- command: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -270,7 +273,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- import Turtle -- @@ -298,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 -- @@ -360,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 -- > @@ -567,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 -- > @@ -605,7 +608,7 @@ -- 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 #-} -- > @@ -625,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 #-} -- > @@ -677,7 +680,7 @@ -- a string: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -713,7 +716,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- \ -- -- #!\/bin\/bash -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -758,7 +761,7 @@ -- -- @ -- #!\/usr\/bin\/env stack --- \-\- stack \-\-install-ghc runghc \-\-package turtle +-- \-\- stack \-\-resolver lts-10.2 script -- -- {-\# LANGUAGE OverloadedStrings \#-} -- @@ -879,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 -- @@ -988,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" @@ -1031,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 #-} -- @@ -1053,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): -- @@ -1078,9 +1109,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" -- @@ -1133,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\"] -- @ -- @@ -1178,7 +1209,7 @@ -- to standard output: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > -- #!/bin/bash -- > {-# LANGUAGE OverloadedStrings #-} -- @@ -1223,9 +1254,9 @@ -- > .X0-lock -- > pulse-PKdhtXMmr18n -- > pulse-xHYcZ3zmN3Fv --- > tracker-gabriel +-- > tracker-gabriella -- > pulse-PYi1hSlWgNj2 --- > orbit-gabriel +-- > orbit-gabriella -- > ssh-vREYGbWGpiCa -- > .ICE-unix -- @@ -1419,7 +1450,7 @@ -- a `Shell`: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1445,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 #-} -- > @@ -1462,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 @@ -1509,7 +1540,7 @@ -- to: -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1536,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 -- > @@ -1550,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 @@ -1601,7 +1632,7 @@ -- -- -- > #!/usr/bin/env stack --- > -- stack --install-ghc runghc --package turtle +-- > -- stack --resolver lts-10.2 script -- > -- > {-# LANGUAGE OverloadedStrings #-} -- > @@ -1650,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 #-} -- > @@ -1762,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 --- +-- -- -- 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: @@ -1818,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 + diff --git a/test/cptree.hs b/test/cptree.hs --- a/test/cptree.hs +++ b/test/cptree.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} import Turtle -import Filesystem.Path.CurrentOS () 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 errorMessage +check errorMessage successs = unless successs $ Fail.fail errorMessage main :: IO () main = withSystemTempDirectory "tempDir" (runTest . fromString) diff --git a/test/system-filepath.hs b/test/system-filepath.hs new file mode 100644 --- /dev/null +++ b/test/system-filepath.hs @@ -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" diff --git a/turtle.cabal b/turtle.cabal --- a/turtle.cabal +++ b/turtle.cabal @@ -1,14 +1,13 @@ Name: turtle -Version: 1.3.6 +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 @@ -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,40 +39,70 @@ 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 , - ansi-wl-pprint >= 0.6 && < 0.7 , - async >= 2.0.0.0 && < 2.2 , - bytestring >= 0.9.1.8 && < 0.11, - clock >= 0.4.1.2 && < 0.8 , - directory >= 1.0.7 && < 1.4 , - foldl >= 1.1 && < 1.4 , + -- 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 , - semigroups >= 0.5.0 && < 0.19, - 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.9 , - transformers >= 0.2.0.0 && < 0.6 , - optparse-applicative >= 0.13 && < 0.15, + 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.5 + 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, @@ -97,7 +126,7 @@ 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 @@ -128,9 +157,22 @@ Build-Depends: base >= 4 && < 5, temporary, - system-filepath >= 0.4, + 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 @@ -138,10 +180,7 @@ GHC-Options: -O2 -Wall -threaded Default-Language: Haskell2010 Build-Depends: - base >= 4 && < 5 , - text < 1.3, + base >= 4 && < 5 , + tasty-bench >= 0.3.1 , + text < 1.3, turtle - if impl(ghc < 7.8) - Build-Depends: criterion >= 0.4 && < 1.1.4.0 - else - Build-Depends: criterion >= 0.4 && < 1.3