{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PhatSort.Cmd.PhatSort
(
Options(..)
, runIO
, run
) where
import Control.Monad (forM, forM_, unless, when)
import Data.Char (toLower)
import Data.List (dropWhileEnd, isSuffixOf, partition, sortBy)
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty)
import Data.Ord (comparing)
import System.FilePath ((</>), takeDirectory)
import Control.Monad.Random.Class (MonadRandom)
import System.Random.Shuffle (shuffleM)
import qualified PhatSort.Monad.FileSystem as FS
import PhatSort.Monad.FileSystem (MonadFileSystem)
import qualified PhatSort.Monad.Stdio as Stdio
import PhatSort.Monad.Stdio (MonadStdio)
import qualified PhatSort.Monad.Sync as Sync
import PhatSort.Monad.Sync (MonadSync)
import qualified PhatSort.Monad.Trans.Error as Error
import PhatSort.Monad.Trans.Error (ErrorT)
import qualified PhatSort.Script as Script
import PhatSort.SortOptions
( SortCase(CaseInsensitive, CaseSensitive)
, SortFirst(FirstDirs, FirstFiles, FirstNone)
, SortOrder(OrderName, OrderRandom, OrderTime)
)
data Options
= Options
{ Options -> SortCase
optCase :: !SortCase
, Options -> SortFirst
optFirst :: !SortFirst
, Options -> Bool
optSync :: !Bool
, Options -> SortOrder
optOrder :: !SortOrder
, Options -> Bool
optReverse :: !Bool
, Options -> Bool
optScript :: !Bool
, Options -> Bool
optVerbose :: !Bool
, Options -> NonEmpty FilePath
optTargets :: !(NonEmpty FilePath)
}
deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> FilePath
$cshow :: Options -> FilePath
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show
runIO :: Options -> IO (Either String ())
runIO :: Options -> IO (Either FilePath ())
runIO = forall (m :: * -> *) a.
Monad m =>
ErrorT m a -> m (Either FilePath a)
Error.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadFileSystem m, MonadRandom m, MonadStdio m, MonadSync m) =>
Options -> ErrorT m ()
run
run
:: forall m
. (MonadFileSystem m, MonadRandom m, MonadStdio m, MonadSync m)
=> Options
-> ErrorT m ()
run :: forall (m :: * -> *).
(MonadFileSystem m, MonadRandom m, MonadStdio m, MonadSync m) =>
Options -> ErrorT m ()
run Options{Bool
NonEmpty FilePath
SortOrder
SortFirst
SortCase
optTargets :: NonEmpty FilePath
optVerbose :: Bool
optScript :: Bool
optReverse :: Bool
optOrder :: SortOrder
optSync :: Bool
optFirst :: SortFirst
optCase :: SortCase
optTargets :: Options -> NonEmpty FilePath
optVerbose :: Options -> Bool
optScript :: Options -> Bool
optReverse :: Options -> Bool
optOrder :: Options -> SortOrder
optSync :: Options -> Bool
optFirst :: Options -> SortFirst
optCase :: Options -> SortCase
..} = do
[Target]
targets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> ErrorT m Target
getTarget forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty FilePath
optTargets
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Target]
targets forall a b. (a -> b) -> a -> b
$ \Target{FilePath
targetDstPath :: Target -> FilePath
targetSrcPath :: Target -> FilePath
targetArgPath :: Target -> FilePath
targetDstPath :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
..} -> do
FilePath -> ErrorT m ()
putProgress FilePath
targetArgPath
FilePath -> FilePath -> ErrorT m ()
mvDir FilePath
targetDstPath FilePath
targetSrcPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorT m ()
sync
FilePath -> ErrorT m ()
mkDir FilePath
targetDstPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorT m ()
sync
FilePath -> FilePath -> FilePath -> ErrorT m ()
processDir FilePath
targetArgPath FilePath
targetSrcPath FilePath
targetDstPath
FilePath -> ErrorT m ()
rmDir FilePath
targetSrcPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorT m ()
sync
where
mkDir :: FilePath -> ErrorT m ()
mkDir :: FilePath -> ErrorT m ()
mkDir FilePath
path
| Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"mkdir", FilePath
path]
| Bool
otherwise = forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError ())
FS.createDirectory FilePath
path
mvDir :: FilePath -> FilePath -> ErrorT m ()
mvDir :: FilePath -> FilePath -> ErrorT m ()
mvDir FilePath
srcPath FilePath
dstPath
| Bool
optScript =
forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"mv", FilePath
srcPath, FilePath
dstPath]
| Bool
otherwise = forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> FilePath -> m (Either IOError ())
FS.renameDirectory FilePath
srcPath FilePath
dstPath
mvFile :: FilePath -> FilePath -> ErrorT m ()
mvFile :: FilePath -> FilePath -> ErrorT m ()
mvFile FilePath
srcPath FilePath
dstPath
| Bool
optScript =
forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"mv", FilePath
srcPath, FilePath
dstPath]
| Bool
otherwise = forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> FilePath -> m (Either IOError ())
FS.renameFile FilePath
srcPath FilePath
dstPath
processDir :: FilePath -> FilePath -> FilePath -> ErrorT m ()
processDir :: FilePath -> FilePath -> FilePath -> ErrorT m ()
processDir FilePath
argPath FilePath
srcPath FilePath
dstPath = do
let goDir :: Entry -> ErrorT m ()
goDir Entry{FilePath
FileStatus
entryStatus :: Entry -> FileStatus
entryDstPath :: Entry -> FilePath
entrySrcPath :: Entry -> FilePath
entryArgPath :: Entry -> FilePath
entryName :: Entry -> FilePath
entryStatus :: FileStatus
entryDstPath :: FilePath
entrySrcPath :: FilePath
entryArgPath :: FilePath
entryName :: FilePath
..} = do
FilePath -> ErrorT m ()
putProgress FilePath
entryArgPath
FilePath -> ErrorT m ()
mkDir FilePath
entryDstPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorT m ()
sync
FilePath -> FilePath -> FilePath -> ErrorT m ()
processDir FilePath
entryArgPath FilePath
entrySrcPath FilePath
entryDstPath
FilePath -> ErrorT m ()
rmDir FilePath
entrySrcPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorT m ()
sync
goFile :: Entry -> ErrorT m ()
goFile Entry{FilePath
FileStatus
entryStatus :: FileStatus
entryDstPath :: FilePath
entrySrcPath :: FilePath
entryArgPath :: FilePath
entryName :: FilePath
entryStatus :: Entry -> FileStatus
entryDstPath :: Entry -> FilePath
entrySrcPath :: Entry -> FilePath
entryArgPath :: Entry -> FilePath
entryName :: Entry -> FilePath
..} = do
FilePath -> ErrorT m ()
putProgress FilePath
entryArgPath
FilePath -> FilePath -> ErrorT m ()
mvFile FilePath
entrySrcPath FilePath
entryDstPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorT m ()
sync
go :: Entry -> ErrorT m ()
go entry :: Entry
entry@Entry{FilePath
FileStatus
entryStatus :: FileStatus
entryDstPath :: FilePath
entrySrcPath :: FilePath
entryArgPath :: FilePath
entryName :: FilePath
entryStatus :: Entry -> FileStatus
entryDstPath :: Entry -> FilePath
entrySrcPath :: Entry -> FilePath
entryArgPath :: Entry -> FilePath
entryName :: Entry -> FilePath
..}
| FileStatus -> Bool
FS.isDirectory FileStatus
entryStatus = Entry -> ErrorT m ()
goDir Entry
entry
| Bool
otherwise = Entry -> ErrorT m ()
goFile Entry
entry
[Entry]
allEntries <- forall (m :: * -> *).
MonadFileSystem m =>
Bool -> FilePath -> FilePath -> FilePath -> ErrorT m [Entry]
getEntries Bool
optScript FilePath
argPath FilePath
srcPath FilePath
dstPath
let ([Entry]
dirEntries, [Entry]
fileEntries) =
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (FileStatus -> Bool
FS.isDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> FileStatus
entryStatus) [Entry]
allEntries
case SortFirst
optFirst of
SortFirst
FirstNone -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Entry -> ErrorT m ()
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Entry] -> ErrorT m [Entry]
sortEntries [Entry]
allEntries
SortFirst
FirstDirs -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Entry -> ErrorT m ()
goDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Entry] -> ErrorT m [Entry]
sortEntries [Entry]
dirEntries
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Entry -> ErrorT m ()
goFile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Entry] -> ErrorT m [Entry]
sortEntries [Entry]
fileEntries
SortFirst
FirstFiles -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Entry -> ErrorT m ()
goFile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Entry] -> ErrorT m [Entry]
sortEntries [Entry]
fileEntries
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Entry -> ErrorT m ()
goDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Entry] -> ErrorT m [Entry]
sortEntries [Entry]
dirEntries
putProgress :: FilePath -> ErrorT m ()
putProgress :: FilePath -> ErrorT m ()
putProgress FilePath
path
| Bool -> Bool
not Bool
optVerbose = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"echo", FilePath
path]
| Bool
otherwise = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn FilePath
path
rmDir :: FilePath -> ErrorT m ()
rmDir :: FilePath -> ErrorT m ()
rmDir FilePath
path
| Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"rmdir", FilePath
path]
| Bool
otherwise = forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError ())
FS.removeDirectory FilePath
path
sortEntries :: [Entry] -> ErrorT m [Entry]
sortEntries :: [Entry] -> ErrorT m [Entry]
sortEntries [Entry]
entries = forall (m :: * -> *) a. Monad m => m a -> ErrorT m a
Error.lift forall a b. (a -> b) -> a -> b
$ do
let compareNames :: Entry -> Entry -> Ordering
compareNames = case SortCase
optCase of
SortCase
CaseSensitive -> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Entry -> FilePath
entryName
SortCase
CaseInsensitive -> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> FilePath
entryName)
compareTimes :: Entry -> Entry -> Ordering
compareTimes = forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FileStatus -> EpochTime
FS.modificationTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> FileStatus
entryStatus)
reverse' :: [a] -> [a]
reverse' = if Bool
optReverse then forall a. [a] -> [a]
reverse else forall a. a -> a
id
case SortOrder
optOrder of
SortOrder
OrderName -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse' forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Entry -> Entry -> Ordering
compareNames [Entry]
entries
SortOrder
OrderTime -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse' forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Entry -> Entry -> Ordering
compareTimes [Entry]
entries
SortOrder
OrderRandom -> forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [Entry]
entries
sync :: ErrorT m ()
sync :: ErrorT m ()
sync
| Bool -> Bool
not Bool
optSync = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"sync"]
| Bool
otherwise = forall (m :: * -> *). MonadSync m => m ()
Sync.sync
data Target
= Target
{ Target -> FilePath
targetArgPath :: !FilePath
, Target -> FilePath
targetSrcPath :: !FilePath
, Target -> FilePath
targetDstPath :: !FilePath
}
getTarget
:: MonadFileSystem m
=> FilePath
-> ErrorT m Target
getTarget :: forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> ErrorT m Target
getTarget FilePath
targetArgPath = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
"-phat" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
targetArgPath) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$ FilePath
"-phat directory: " forall a. [a] -> [a] -> [a]
++ FilePath
targetArgPath
FilePath
targetDstPath <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FilePath)
FS.makeAbsolute forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
targetArgPath
FileStatus
tgtStatus <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FileStatus)
FS.getFileStatus FilePath
targetDstPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileStatus -> Bool
FS.isDirectory FileStatus
tgtStatus) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$ FilePath
"not a directory: " forall a. [a] -> [a] -> [a]
++ FilePath
targetArgPath
let parentDir :: FilePath
parentDir = ShowS
takeDirectory FilePath
targetDstPath
FileStatus
parentStatus <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FileStatus)
FS.getFileStatus FilePath
parentDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileStatus -> DeviceID
FS.deviceID FileStatus
tgtStatus forall a. Eq a => a -> a -> Bool
== FileStatus -> DeviceID
FS.deviceID FileStatus
parentStatus) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$ FilePath
"mount point: " forall a. [a] -> [a] -> [a]
++ FilePath
targetArgPath
let targetSrcPath :: FilePath
targetSrcPath = FilePath
targetDstPath forall a. [a] -> [a] -> [a]
++ FilePath
"-phat"
Bool
exists <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError Bool)
FS.doesPathExist FilePath
targetSrcPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$ FilePath
"already exists: " forall a. [a] -> [a] -> [a]
++ FilePath
targetArgPath forall a. [a] -> [a] -> [a]
++ FilePath
"-phat"
forall (f :: * -> *) a. Applicative f => a -> f a
pure Target{FilePath
targetSrcPath :: FilePath
targetDstPath :: FilePath
targetArgPath :: FilePath
targetDstPath :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
..}
data Entry
= Entry
{ Entry -> FilePath
entryName :: !FilePath
, Entry -> FilePath
entryArgPath :: !FilePath
, Entry -> FilePath
entrySrcPath :: !FilePath
, Entry -> FilePath
entryDstPath :: !FilePath
, Entry -> FileStatus
entryStatus :: !FS.FileStatus
}
getEntries
:: MonadFileSystem m
=> Bool
-> FilePath
-> FilePath
-> FilePath
-> ErrorT m [Entry]
getEntries :: forall (m :: * -> *).
MonadFileSystem m =>
Bool -> FilePath -> FilePath -> FilePath -> ErrorT m [Entry]
getEntries Bool
isScript FilePath
argDir FilePath
srcDir FilePath
dstDir = do
[FilePath]
names <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError [FilePath])
FS.listDirectory (if Bool
isScript then FilePath
dstDir else FilePath
srcDir)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
names forall a b. (a -> b) -> a -> b
$ \FilePath
entryName -> do
let entryArgPath :: FilePath
entryArgPath = FilePath
argDir FilePath -> ShowS
</> FilePath
entryName
entrySrcPath :: FilePath
entrySrcPath = FilePath
srcDir FilePath -> ShowS
</> FilePath
entryName
entryDstPath :: FilePath
entryDstPath = FilePath
dstDir FilePath -> ShowS
</> FilePath
entryName
FileStatus
entryStatus <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FileStatus)
FS.getFileStatus (if Bool
isScript then FilePath
entryDstPath else FilePath
entrySrcPath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entry{FilePath
FileStatus
entryStatus :: FileStatus
entryDstPath :: FilePath
entrySrcPath :: FilePath
entryArgPath :: FilePath
entryName :: FilePath
entryStatus :: FileStatus
entryDstPath :: FilePath
entrySrcPath :: FilePath
entryArgPath :: FilePath
entryName :: FilePath
..}