module Turtle.Prelude (
echo
, err
, readline
, Filesystem.readTextFile
, Filesystem.writeTextFile
, arguments
#if MIN_VERSION_base(4,7,0)
, export
, unset
#endif
#if MIN_VERSION_base(4,6,0)
, need
#endif
, env
, cd
, pwd
, home
, realpath
, mv
, mkdir
, mktree
, cp
, rm
, rmdir
, rmtree
, testfile
, testdir
, testpath
, date
, datefile
, touch
, time
, hostname
, sleep
, exit
, die
, (.&&.)
, (.||.)
, readonly
, writeonly
, appendonly
, mktemp
, mktempfile
, mktempdir
, fork
, wait
, inproc
, inshell
, inprocWithErr
, inshellWithErr
, stdin
, input
, inhandle
, stdout
, output
, outhandle
, append
, stderr
, strict
, ls
, lsif
, lstree
, cat
, grep
, sed
, inplace
, find
, yes
, nl
, paste
, endless
, limit
, limitWhile
, cache
, countChars
, countWords
, countLines
, cut
, proc
, shell
, system
, procs
, shells
, procStrict
, shellStrict
, Permissions
, chmod
, getmod
, setmod
, copymod
, readable, nonreadable
, writable, nonwritable
, executable, nonexecutable
, searchable, nonsearchable
, ooo,roo,owo,oox,oos,rwo,rox,ros,owx,rwx,rws
, du
, Size
, sz
, bytes
, kilobytes
, megabytes
, gigabytes
, terabytes
, kibibytes
, mebibytes
, gibibytes
, tebibytes
, ProcFailed(..)
, ShellFailed(..)
) where
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
(Async, withAsync, withAsyncWithUnmask, wait, waitSTM, concurrently)
import Control.Concurrent.MVar (newMVar, modifyMVar_)
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TQueue as TQueue
import Control.Exception (Exception, bracket, finally, mask_, throwIO)
import Control.Foldl (Fold, FoldM(..), genericLength, handles, list, premap)
import qualified Control.Foldl.Text
import Control.Monad (liftM, msum, when, unless)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (MonadManaged(..), managed, runManaged)
#ifdef mingw32_HOST_OS
import Data.Bits ((.&.))
#endif
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Text (Text, pack, unpack)
import Data.Time (NominalDiffTime, UTCTime, getCurrentTime)
import Data.Traversable
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Typeable (Typeable)
import qualified Filesystem
import Filesystem.Path.CurrentOS (FilePath, (</>))
import qualified Filesystem.Path.CurrentOS as Filesystem
import GHC.IO.Exception (IOErrorType(UnsupportedOperation))
import Network.HostName (getHostName)
import System.Clock (Clock(..), TimeSpec(..), getTime)
import System.Environment (
getArgs,
#if MIN_VERSION_base(4,7,0)
setEnv,
unsetEnv,
#endif
#if MIN_VERSION_base(4,6,0)
lookupEnv,
#endif
getEnvironment )
import System.Directory (Permissions)
import qualified System.Directory as Directory
import System.Exit (ExitCode(..), exitWith)
import System.IO (Handle, hClose)
import qualified System.IO as IO
import System.IO.Temp (withTempDirectory, withTempFile)
import System.IO.Error (catchIOError, ioeGetErrorType)
import qualified System.Process as Process
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
#else
import System.Posix (
openDirStream,
readDirStream,
closeDirStream,
touchFile,
getSymbolicLinkStatus,
isDirectory,
isSymbolicLink )
#endif
import Prelude hiding (FilePath)
import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy)
import Turtle.Shell
import Turtle.Format (Format, format, makeFormat, d, w, (%))
proc
:: MonadIO io
=> Text
-> [Text]
-> Shell Text
-> io ExitCode
proc cmd args =
system
( (Process.proc (unpack cmd) (map unpack args))
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.Inherit
, Process.std_err = Process.Inherit
} )
shell
:: MonadIO io
=> Text
-> Shell Text
-> io ExitCode
shell cmdLine =
system
( (Process.shell (unpack cmdLine))
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.Inherit
, Process.std_err = Process.Inherit
} )
data ProcFailed = ProcFailed
{ procCommand :: Text
, procArguments :: [Text]
, procExitCode :: ExitCode
} deriving (Show, Typeable)
instance Exception ProcFailed
procs
:: MonadIO io
=> Text
-> [Text]
-> Shell Text
-> io ()
procs cmd args s = do
exitCode <- proc cmd args s
case exitCode of
ExitSuccess -> return ()
_ -> liftIO (throwIO (ProcFailed cmd args exitCode))
data ShellFailed = ShellFailed
{ shellCommandLine :: Text
, shellExitCode :: ExitCode
} deriving (Show, Typeable)
instance Exception ShellFailed
shells
:: MonadIO io
=> Text
-> Shell Text
-> io ()
shells cmdline s = do
exitCode <- shell cmdline s
case exitCode of
ExitSuccess -> return ()
_ -> liftIO (throwIO (ShellFailed cmdline exitCode))
procStrict
:: MonadIO io
=> Text
-> [Text]
-> Shell Text
-> io (ExitCode, Text)
procStrict cmd args =
systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args))
shellStrict
:: MonadIO io
=> Text
-> Shell Text
-> io (ExitCode, Text)
shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine))
system
:: MonadIO io
=> Process.CreateProcess
-> Shell Text
-> io ExitCode
system p s = liftIO (do
let open = do
(Just hIn, Nothing, Nothing, ph) <- Process.createProcess p
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, ph)
mvar <- newMVar False
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (hClose handle)
return True )
bracket open (\(hIn, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, ph) -> do
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (sh (do
txt <- s
liftIO (Text.hPutStrLn hIn txt) ) )
`finally` close hIn
mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a) ) ) )
systemStrict
:: MonadIO io
=> Process.CreateProcess
-> Shell Text
-> io (ExitCode, Text)
systemStrict p s = liftIO (do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.Inherit
}
let open = do
(Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, ph)
mvar <- newMVar False
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (hClose handle)
return True )
bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (sh (do
txt <- s
liftIO (Text.hPutStrLn hIn txt) ) )
`finally` close hIn
concurrently
(mask_ (withAsyncWithUnmask feedIn (\a -> liftIO (Process.waitForProcess ph) <* wait a)))
(Text.hGetContents hOut) ) )
inproc
:: Text
-> [Text]
-> Shell Text
-> Shell Text
inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args))
inshell
:: Text
-> Shell Text
-> Shell Text
inshell cmd = stream (Process.shell (unpack cmd))
stream
:: Process.CreateProcess
-> Shell Text
-> Shell Text
stream p s = do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.Inherit
}
let open = do
(Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, ph)
mvar <- liftIO (newMVar False)
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (hClose handle)
return True )
(hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph)))
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (sh (do
txt <- s
liftIO (Text.hPutStrLn hIn txt) ) )
`finally` close hIn
a <- using (managed (mask_ . withAsyncWithUnmask feedIn))
inhandle hOut <|> (liftIO (Process.waitForProcess ph *> wait a) *> empty)
streamWithErr
:: Process.CreateProcess
-> Shell Text
-> Shell (Either Text Text)
streamWithErr p s = do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.CreatePipe
}
let open = do
(Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, hErr, ph)
mvar <- liftIO (newMVar False)
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (hClose handle)
return True )
(hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph)))
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (sh (do
txt <- s
liftIO (Text.hPutStrLn hIn txt) ) )
`finally` close hIn
queue <- liftIO TQueue.newTQueueIO
let forwardOut :: (forall a. IO a -> IO a) -> IO ()
forwardOut restore =
restore (sh (do
txt <- inhandle hOut
liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right txt)))) ))
`finally` STM.atomically (TQueue.writeTQueue queue Nothing)
let forwardErr :: (forall a. IO a -> IO a) -> IO ()
forwardErr restore =
restore (sh (do
txt <- inhandle hErr
liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left txt)))) ))
`finally` STM.atomically (TQueue.writeTQueue queue Nothing)
let drain = Shell (\(FoldM step begin done) -> do
x0 <- begin
let loop x numNothing
| numNothing < 2 = do
m <- STM.atomically (TQueue.readTQueue queue)
case m of
Nothing -> loop x $! numNothing + 1
Just e -> do
x' <- step x e
loop x' numNothing
| otherwise = return x
x1 <- loop x0 (0 :: Int)
done x1 )
a <- using (managed (mask_ . withAsyncWithUnmask feedIn ))
b <- using (managed (mask_ . withAsyncWithUnmask forwardOut))
c <- using (managed (mask_ . withAsyncWithUnmask forwardErr))
let l `also` r = do
_ <- l <|> (r *> STM.retry)
_ <- r
return ()
let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c))
drain <|> (liftIO (Process.waitForProcess ph *> waitAll) *> empty)
inprocWithErr
:: Text
-> [Text]
-> Shell Text
-> Shell (Either Text Text)
inprocWithErr cmd args =
streamWithErr (Process.proc (unpack cmd) (map unpack args))
inshellWithErr
:: Text
-> Shell Text
-> Shell (Either Text Text)
inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd))
echo :: MonadIO io => Text -> io ()
echo txt = liftIO (Text.putStrLn txt)
err :: MonadIO io => Text -> io ()
err txt = liftIO (Text.hPutStrLn IO.stderr txt)
readline :: MonadIO io => io (Maybe Text)
readline = liftIO (do
eof <- IO.isEOF
if eof
then return Nothing
else fmap (Just . pack) getLine )
arguments :: MonadIO io => io [Text]
arguments = liftIO (fmap (map pack) getArgs)
#if MIN_VERSION_base(4,7,0)
export :: MonadIO io => Text -> Text -> io ()
export key val = liftIO (setEnv (unpack key) (unpack val))
unset :: MonadIO io => Text -> io ()
unset key = liftIO (unsetEnv (unpack key))
#endif
#if MIN_VERSION_base(4,6,0)
need :: MonadIO io => Text -> io (Maybe Text)
need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key)))
#endif
env :: MonadIO io => io [(Text, Text)]
env = liftIO (fmap (fmap toTexts) getEnvironment)
where
toTexts (key, val) = (pack key, pack val)
cd :: MonadIO io => FilePath -> io ()
cd path = liftIO (Filesystem.setWorkingDirectory path)
pwd :: MonadIO io => io FilePath
pwd = liftIO Filesystem.getWorkingDirectory
home :: MonadIO io => io FilePath
home = liftIO Filesystem.getHomeDirectory
realpath :: MonadIO io => FilePath -> io FilePath
realpath path = liftIO (Filesystem.canonicalizePath path)
#ifdef mingw32_HOST_OS
fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag
fILE_ATTRIBUTE_REPARSE_POINT = 1024
reparsePoint :: Win32.FileAttributeOrFlag -> Bool
reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0
#endif
ls :: FilePath -> Shell FilePath
ls path = Shell (\(FoldM step begin done) -> do
x0 <- begin
let path' = Filesystem.encodeString path
canRead <- fmap
Directory.readable
(Directory.getPermissions (deslash path'))
#ifdef mingw32_HOST_OS
reparse <- fmap reparsePoint (Win32.getFileAttributes path')
if (canRead && not reparse)
then bracket
(Win32.findFirstFile (Filesystem.encodeString (path </> "*")))
(\(h, _) -> Win32.findClose h)
(\(h, fdat) -> do
let loop x = do
file' <- Win32.getFindDataFileName fdat
let file = Filesystem.decodeString file'
x' <- if (file' /= "." && file' /= "..")
then step x (path </> file)
else return x
more <- Win32.findNextFile h fdat
if more then loop $! x' else done x'
loop $! x0 )
else done x0 )
#else
if canRead
then bracket (openDirStream path') closeDirStream (\dirp -> do
let loop x = do
file' <- readDirStream dirp
case file' of
"" -> done x
_ -> do
let file = Filesystem.decodeString file'
x' <- if (file' /= "." && file' /= "..")
then step x (path </> file)
else return x
loop $! x'
loop $! x0 )
else done x0 )
#endif
deslash :: String -> String
deslash [] = []
deslash (c0:cs0) = c0:go cs0
where
go [] = []
go ['\\'] = []
go (c:cs) = c:go cs
lstree :: FilePath -> Shell FilePath
lstree path = do
child <- ls path
isDir <- testdir child
if isDir
then return child <|> lstree child
else return child
lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath
lsif predicate path = do
child <- ls path
isDir <- testdir child
if isDir
then do
continue <- liftIO (predicate child)
if continue
then return child <|> lsif predicate child
else return child
else return child
mv :: MonadIO io => FilePath -> FilePath -> io ()
mv oldPath newPath = liftIO $ catchIOError (Filesystem.rename oldPath newPath)
(\ioe -> if ioeGetErrorType ioe == UnsupportedOperation
then do
Filesystem.copyFile oldPath newPath
Filesystem.removeFile oldPath
else ioError ioe)
mkdir :: MonadIO io => FilePath -> io ()
mkdir path = liftIO (Filesystem.createDirectory False path)
mktree :: MonadIO io => FilePath -> io ()
mktree path = liftIO (Filesystem.createTree path)
cp :: MonadIO io => FilePath -> FilePath -> io ()
cp oldPath newPath = liftIO (Filesystem.copyFile oldPath newPath)
rm :: MonadIO io => FilePath -> io ()
rm path = liftIO (Filesystem.removeFile path)
rmdir :: MonadIO io => FilePath -> io ()
rmdir path = liftIO (Filesystem.removeDirectory path)
rmtree :: MonadIO io => FilePath -> io ()
rmtree path0 = liftIO (sh (loop path0))
where
#ifdef mingw32_HOST_OS
loop path = do
isDir <- testdir path
if isDir
then (do
child <- ls path
loop child ) <|> rmdir path
else rm path
#else
loop path = do
let path' = Filesystem.encodeString path
stat <- liftIO $ getSymbolicLinkStatus path'
let isLink = isSymbolicLink stat
isDir = isDirectory stat
if isLink
then rm path
else do
if isDir
then (do
child <- ls path
loop child ) <|> rmdir path
else rm path
#endif
testfile :: MonadIO io => FilePath -> io Bool
testfile path = liftIO (Filesystem.isFile path)
testdir :: MonadIO io => FilePath -> io Bool
testdir path = liftIO (Filesystem.isDirectory path)
testpath :: MonadIO io => FilePath -> io Bool
testpath path = do
exists <- testfile path
if exists
then return exists
else testdir path
touch :: MonadIO io => FilePath -> io ()
touch file = do
exists <- testfile file
liftIO (if exists
#ifdef mingw32_HOST_OS
then do
handle <- Win32.createFile
(Filesystem.encodeString file)
Win32.gENERIC_WRITE
Win32.fILE_SHARE_NONE
Nothing
Win32.oPEN_EXISTING
Win32.fILE_ATTRIBUTE_NORMAL
Nothing
(creationTime, _, _) <- Win32.getFileTime handle
systemTime <- Win32.getSystemTimeAsFileTime
Win32.setFileTime handle creationTime systemTime systemTime
#else
then touchFile (Filesystem.encodeString file)
#endif
else output file empty )
chmod
:: MonadIO io
=> (Permissions -> Permissions)
-> FilePath
-> io Permissions
chmod modifyPermissions path = liftIO (do
let path' = deslash (Filesystem.encodeString path)
permissions <- Directory.getPermissions path'
let permissions' = modifyPermissions permissions
changed = permissions /= permissions'
when changed (Directory.setPermissions path' permissions')
return permissions' )
getmod :: MonadIO io => FilePath -> io Permissions
getmod path = liftIO (do
let path' = deslash (Filesystem.encodeString path)
Directory.getPermissions path' )
setmod :: MonadIO io => Permissions -> FilePath -> io ()
setmod permissions path = liftIO (do
let path' = deslash (Filesystem.encodeString path)
Directory.setPermissions path' permissions )
copymod :: MonadIO io => FilePath -> FilePath -> io ()
copymod sourcePath targetPath = liftIO (do
let sourcePath' = deslash (Filesystem.encodeString sourcePath)
targetPath' = deslash (Filesystem.encodeString targetPath)
Directory.copyPermissions sourcePath' targetPath' )
readable :: Permissions -> Permissions
readable = Directory.setOwnerReadable True
nonreadable :: Permissions -> Permissions
nonreadable = Directory.setOwnerReadable False
writable :: Permissions -> Permissions
writable = Directory.setOwnerWritable True
nonwritable :: Permissions -> Permissions
nonwritable = Directory.setOwnerWritable False
executable :: Permissions -> Permissions
executable = Directory.setOwnerExecutable True
nonexecutable :: Permissions -> Permissions
nonexecutable = Directory.setOwnerExecutable False
searchable :: Permissions -> Permissions
searchable = Directory.setOwnerSearchable True
nonsearchable :: Permissions -> Permissions
nonsearchable = Directory.setOwnerSearchable False
ooo :: Permissions -> Permissions
ooo = const Directory.emptyPermissions
roo :: Permissions -> Permissions
roo = readable . ooo
owo :: Permissions -> Permissions
owo = writable . ooo
oox :: Permissions -> Permissions
oox = executable . ooo
oos :: Permissions -> Permissions
oos = searchable . ooo
rwo :: Permissions -> Permissions
rwo = readable . writable . ooo
rox :: Permissions -> Permissions
rox = readable . executable . ooo
ros :: Permissions -> Permissions
ros = readable . searchable . ooo
owx :: Permissions -> Permissions
owx = writable . executable . ooo
rwx :: Permissions -> Permissions
rwx = readable . writable . executable . ooo
rws :: Permissions -> Permissions
rws = readable . writable . searchable . ooo
time :: MonadIO io => io a -> io (a, NominalDiffTime)
time io = do
TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic)
a <- io
TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic)
let t = fromIntegral ( seconds2 seconds1)
+ fromIntegral (nanoseconds2 nanoseconds1) / 10^(9::Int)
return (a, fromRational t)
hostname :: MonadIO io => io Text
hostname = liftIO (fmap Text.pack getHostName)
sleep :: MonadIO io => NominalDiffTime -> io ()
sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int))))
exit :: MonadIO io => ExitCode -> io a
exit code = liftIO (exitWith code)
die :: MonadIO io => Text -> io a
die txt = liftIO (throwIO (userError (unpack txt)))
infixr 2 .||.
infixr 3 .&&.
(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode
cmd1 .&&. cmd2 = do
r <- cmd1
case r of
ExitSuccess -> cmd2
_ -> return r
(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode
cmd1 .||. cmd2 = do
r <- cmd1
case r of
ExitFailure _ -> cmd2
_ -> return r
mktempdir
:: MonadManaged managed
=> FilePath
-> Text
-> 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'))
mktemp
:: MonadManaged managed
=> FilePath
-> Text
-> 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) )
mktempfile
:: MonadManaged managed
=> FilePath
-> Text
-> managed FilePath
mktempfile parent prefix = using (do
let parent' = Filesystem.encodeString parent
let prefix' = unpack prefix
(file', handle) <- managed (\k ->
withTempFile parent' prefix' (\file' handle -> k (file', handle)) )
liftIO (hClose handle)
return (Filesystem.decodeString file') )
fork :: MonadManaged managed => IO a -> managed (Async a)
fork io = using (managed (withAsync io))
stdin :: Shell Text
stdin = inhandle IO.stdin
input :: FilePath -> Shell Text
input file = do
handle <- using (readonly file)
inhandle handle
inhandle :: Handle -> Shell Text
inhandle handle = Shell (\(FoldM step begin done) -> do
x0 <- begin
let loop x = do
eof <- IO.hIsEOF handle
if eof
then done x
else do
txt <- Text.hGetLine handle
x' <- step x txt
loop $! x'
loop $! x0 )
stdout :: MonadIO io => Shell Text -> io ()
stdout s = sh (do
txt <- s
liftIO (echo txt) )
output :: MonadIO io => FilePath -> Shell Text -> io ()
output file s = sh (do
handle <- using (writeonly file)
txt <- s
liftIO (Text.hPutStrLn handle txt) )
outhandle :: MonadIO io => Handle -> Shell Text -> io ()
outhandle handle s = sh (do
txt <- s
liftIO (Text.hPutStrLn handle txt) )
append :: MonadIO io => FilePath -> Shell Text -> io ()
append file s = sh (do
handle <- using (appendonly file)
txt <- s
liftIO (Text.hPutStrLn handle txt) )
stderr :: MonadIO io => Shell Text -> io ()
stderr s = sh (do
txt <- s
liftIO (err txt) )
strict :: MonadIO io => Shell Text -> io Text
strict s = liftM Text.unlines (fold s list)
readonly :: MonadManaged managed => FilePath -> managed Handle
readonly file = using (managed (Filesystem.withTextFile file IO.ReadMode))
writeonly :: MonadManaged managed => FilePath -> managed Handle
writeonly file = using (managed (Filesystem.withTextFile file IO.WriteMode))
appendonly :: MonadManaged managed => FilePath -> managed Handle
appendonly file = using (managed (Filesystem.withTextFile file IO.AppendMode))
cat :: [Shell a] -> Shell a
cat = msum
grep :: Pattern a -> Shell Text -> Shell Text
grep pattern s = do
txt <- s
_:_ <- return (match pattern txt)
return txt
sed :: Pattern Text -> Shell Text -> Shell Text
sed pattern s = do
when (matchesEmpty pattern) (die message)
let pattern' = fmap Text.concat
(many (pattern <|> fmap Text.singleton anyChar))
txt <- s
txt':_ <- return (match pattern' txt)
return txt'
where
message = "sed: the given pattern matches the empty string"
matchesEmpty = not . null . flip match ""
inplace :: MonadIO io => Pattern Text -> FilePath -> io ()
inplace pattern file = liftIO (runManaged (do
here <- pwd
(tmpfile, handle) <- mktemp here "turtle"
outhandle handle (sed pattern (input file))
liftIO (hClose handle)
copymod file tmpfile
mv tmpfile file ))
find :: Pattern a -> FilePath -> Shell FilePath
find pattern dir = do
path <- lstree dir
Right txt <- return (Filesystem.toText path)
_:_ <- return (match pattern txt)
return path
yes :: Shell Text
yes = fmap (\_ -> "y") endless
nl :: Num n => Shell a -> Shell (n, a)
nl s = Shell _foldIO'
where
_foldIO' (FoldM step begin done) = _foldIO s (FoldM step' begin' done')
where
step' (x, n) a = do
x' <- step x (n, a)
let n' = n + 1
n' `seq` return (x', n')
begin' = do
x0 <- begin
return (x0, 0)
done' (x, _) = done x
data ZipState a b = Empty | HasA a | HasAB a b | Done
paste :: Shell a -> Shell b -> Shell (a, b)
paste sA sB = Shell _foldIOAB
where
_foldIOAB (FoldM stepAB beginAB doneAB) = do
x0 <- beginAB
tvar <- STM.atomically (STM.newTVar Empty)
let begin = return ()
let stepA () a = STM.atomically (do
x <- STM.readTVar tvar
case x of
Empty -> STM.writeTVar tvar (HasA a)
Done -> return ()
_ -> STM.retry )
let doneA () = STM.atomically (do
x <- STM.readTVar tvar
case x of
Empty -> STM.writeTVar tvar Done
Done -> return ()
_ -> STM.retry )
let foldA = FoldM stepA begin doneA
let stepB () b = STM.atomically (do
x <- STM.readTVar tvar
case x of
HasA a -> STM.writeTVar tvar (HasAB a b)
Done -> return ()
_ -> STM.retry )
let doneB () = STM.atomically (do
x <- STM.readTVar tvar
case x of
HasA _ -> STM.writeTVar tvar Done
Done -> return ()
_ -> STM.retry )
let foldB = FoldM stepB begin doneB
withAsync (foldIO sA foldA) (\asyncA -> do
withAsync (foldIO sB foldB) (\asyncB -> do
let loop x = do
y <- STM.atomically (do
z <- STM.readTVar tvar
case z of
HasAB a b -> do
STM.writeTVar tvar Empty
return (Just (a, b))
Done -> return Nothing
_ -> STM.retry )
case y of
Nothing -> return x
Just ab -> do
x' <- stepAB x ab
loop $! x'
x' <- loop $! x0
wait asyncA
wait asyncB
doneAB x' ) )
endless :: Shell ()
endless = Shell (\(FoldM step begin _) -> do
x0 <- begin
let loop x = do
x' <- step x ()
loop $! x'
loop $! x0 )
limit :: Int -> Shell a -> Shell a
limit n s = Shell (\(FoldM step begin done) -> do
ref <- newIORef 0
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) )
limitWhile :: (a -> Bool) -> Shell a -> Shell a
limitWhile predicate s = Shell (\(FoldM step begin done) -> do
ref <- newIORef True
let step' x a = do
b <- readIORef ref
let b' = b && predicate a
writeIORef ref b'
if b' then step x a else return x
foldIO s (FoldM step' begin done) )
cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a
cache file s = do
let cached = do
txt <- input file
case reads (Text.unpack txt) of
[(ma, "")] -> return ma
_ ->
die (format ("cache: Invalid data stored in "%w) file)
exists <- testfile file
mas <- fold (if exists then cached else empty) list
case [ () | Nothing <- mas ] of
_:_ -> select [ a | Just a <- mas ]
_ -> do
handle <- using (writeonly file)
let justs = do
a <- s
liftIO (Text.hPutStrLn handle (Text.pack (show (Just a))))
return a
let nothing = do
let n = Nothing :: Maybe ()
liftIO (Text.hPutStrLn handle (Text.pack (show n)))
empty
justs <|> nothing
cut :: Pattern a -> Text -> [Text]
cut pattern txt = head (match (selfless chars `sepBy` pattern) txt)
date :: MonadIO io => io UTCTime
date = liftIO getCurrentTime
datefile :: MonadIO io => FilePath -> io UTCTime
datefile path = liftIO (Filesystem.getModified path)
du :: MonadIO io => FilePath -> io Size
du path = liftIO (fmap Size (Filesystem.getSize path))
newtype Size = Size { _bytes :: Integer } deriving (Num)
instance Show Size where
show = show . _bytes
sz :: Format r (Size -> r)
sz = makeFormat (\(Size numBytes) ->
let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000
(numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000
(numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000
(numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000
in if numKilobytes <= 0
then format (d%" B" ) remainingBytes
else if numMegabytes == 0
then format (d%"."%d%" KB") remainingKilobytes remainingBytes
else if numGigabytes == 0
then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes
else if numTerabytes == 0
then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes
else format (d%"."%d%" TB") numTerabytes remainingGigabytes )
bytes :: Integral n => Size -> n
bytes = fromInteger . _bytes
kilobytes :: Integral n => Size -> n
kilobytes = (`div` 1000) . bytes
megabytes :: Integral n => Size -> n
megabytes = (`div` 1000) . kilobytes
gigabytes :: Integral n => Size -> n
gigabytes = (`div` 1000) . megabytes
terabytes :: Integral n => Size -> n
terabytes = (`div` 1000) . gigabytes
kibibytes :: Integral n => Size -> n
kibibytes = (`div` 1024) . bytes
mebibytes :: Integral n => Size -> n
mebibytes = (`div` 1024) . kibibytes
gibibytes :: Integral n => Size -> n
gibibytes = (`div` 1024) . mebibytes
tebibytes :: Integral n => Size -> n
tebibytes = (`div` 1024) . gibibytes
countChars :: Integral n => Fold Text n
countChars = Control.Foldl.Text.length + charsPerNewline * countLines
charsPerNewline :: Num a => a
#ifdef mingw32_HOST_OS
charsPerNewline = 2
#else
charsPerNewline = 1
#endif
countWords :: Integral n => Fold Text n
countWords = premap Text.words (handles traverse genericLength)
countLines :: Integral n => Fold Text n
countLines = genericLength