module Yi.Dired
( dired
, diredDir
, diredDirBuffer
, editFile
) where
import GHC.Generics (Generic)
import Control.Applicative ((<$>), (<|>))
import Control.Category ((>>>))
import Control.Exc (orException, printingException)
import Control.Lens (assign, makeLenses, use, (%~), (&), (.=), (.~), (^.))
import Control.Monad.Reader (asks, foldM, unless, void, when)
import Data.Binary (Binary)
import Data.Char (toLower)
import Data.Default (Default, def)
import Data.Foldable (find, foldl')
import Data.List (any, elem, sum, transpose)
import qualified Data.Map as M (Map, assocs, delete, empty,
findWithDefault, fromList,
insert, keys, lookup, map,
mapKeys, union, (!))
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty, (<>))
import qualified Data.Text as T (Text, pack, unpack)
import qualified Data.Text.ICU as ICU (regex, find, unfold, group, MatchOption(..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Typeable (Typeable)
import System.CanonicalizePath (canonicalizePath)
import System.Directory (copyFile, createDirectoryIfMissing,
doesDirectoryExist, doesFileExist,
getDirectoryContents, getPermissions,
removeDirectoryRecursive, writable)
import System.FilePath (dropTrailingPathSeparator,
equalFilePath, isAbsolute,
takeDirectory, takeFileName, (</>))
import System.FriendlyPath (userToCanonPath)
import System.PosixCompat.Files (FileStatus, fileExist, fileGroup,
fileMode, fileOwner, fileSize,
getSymbolicLinkStatus,
groupExecuteMode, groupReadMode,
groupWriteMode, isBlockDevice,
isCharacterDevice, isDirectory,
isNamedPipe, isRegularFile, isSocket,
isSymbolicLink, linkCount,
modificationTime, otherExecuteMode,
otherReadMode, otherWriteMode,
ownerExecuteMode, ownerReadMode,
ownerWriteMode, readSymbolicLink,
readSymbolicLink, removeLink, rename,
unionFileModes)
import System.PosixCompat.Types (FileMode, GroupID, UserID)
import System.PosixCompat.User (GroupEntry, GroupEntry (..),
UserEntry (..), getAllGroupEntries,
getAllUserEntries,
getGroupEntryForID,
getUserEntryForID, groupID, userID)
import Text.Printf (printf)
import Yi.Buffer
import Yi.Config (modeTable)
import Yi.Core (errorEditor)
import Yi.Editor
import Yi.Keymap (Keymap, YiM, topKeymapA)
import Yi.Keymap.Keys
import Yi.MiniBuffer (noHint, spawnMinibufferE, withMinibuffer, withMinibufferFree)
import Yi.Misc (getFolder, promptFile)
import Yi.Monad (gets)
import qualified Yi.Rope as R
import Yi.String (showT)
import Yi.Style
import Yi.Types (YiVariable, yiConfig)
import Yi.Utils (io, makeLensesWithSuffix)
#if __GLASGOW_HASKELL__ < 710
import System.Locale (defaultTimeLocale)
import Data.Time (UTCTime, formatTime, getCurrentTime)
#else
import Data.Time (UTCTime, formatTime, getCurrentTime, defaultTimeLocale)
#endif
data DiredOpState = DiredOpState
{ _diredOpSucCnt :: !Int
, _diredOpForAll :: Bool
} deriving (Show, Eq, Typeable, Generic)
instance Default DiredOpState where
def = DiredOpState { _diredOpSucCnt = 0, _diredOpForAll = False }
instance Binary DiredOpState
instance YiVariable DiredOpState
makeLenses ''DiredOpState
data DiredFileInfo = DiredFileInfo
{ permString :: R.YiString
, numLinks :: Integer
, owner :: R.YiString
, grp :: R.YiString
, sizeInBytes :: Integer
, modificationTimeString :: R.YiString
} deriving (Show, Eq, Typeable, Generic)
data DiredEntry
= DiredFile DiredFileInfo
| DiredDir DiredFileInfo
| DiredSymLink DiredFileInfo R.YiString
| DiredSocket DiredFileInfo
| DiredBlockDevice DiredFileInfo
| DiredCharacterDevice DiredFileInfo
| DiredNamedPipe DiredFileInfo
| DiredNoInfo
deriving (Show, Eq, Typeable, Generic)
type DiredFilePath = R.YiString
type DiredEntries = M.Map DiredFilePath DiredEntry
data DiredState = DiredState
{ diredPath :: FilePath
, diredMarks :: M.Map FilePath Char
, diredEntries :: DiredEntries
, diredFilePoints :: [(Point,Point,FilePath)]
, diredNameCol :: Int
, diredCurrFile :: FilePath
} deriving (Show, Eq, Typeable, Generic)
makeLensesWithSuffix "A" ''DiredState
instance Binary DiredState
instance Default DiredState where
def = DiredState { diredPath = mempty
, diredMarks = mempty
, diredEntries = mempty
, diredFilePoints = mempty
, diredNameCol = 0
, diredCurrFile = mempty
}
instance YiVariable DiredState
instance Binary DiredEntry
instance Binary DiredFileInfo
editFile :: FilePath -> YiM (Either T.Text BufferRef)
editFile filename = do
f <- io $ userToCanonPath filename
dupBufs <- filter (maybe False (equalFilePath f) . file) <$> gets bufferSet
dirExists <- io $ doesDirectoryExist f
fileExists <- io $ doesFileExist f
b <- case dupBufs of
[] -> if dirExists
then Right <$> diredDirBuffer f
else do
nb <- if fileExists
then fileToNewBuffer f
else Right <$> newEmptyBuffer f
case nb of
Left m -> return $ Left m
Right buf -> Right <$> setupMode f buf
(h:_) -> return . Right $ bkey h
case b of
Left m -> return $ Left m
Right bf -> withEditor (switchToBufferE bf >> addJumpHereE) >> return b
where
fileToNewBuffer :: FilePath -> YiM (Either T.Text BufferRef)
fileToNewBuffer f = io getCurrentTime >>= \n -> io (R.readFile f) >>= \case
Left m -> return $ Left m
Right (contents, conv) -> do
permissions <- io $ getPermissions f
b <- stringToNewBuffer (FileBuffer f) contents
withGivenBuffer b $ do
encodingConverterNameA .= Just conv
markSavedB n
unless (writable permissions) (readOnlyA .= True)
return $ Right b
newEmptyBuffer :: FilePath -> YiM BufferRef
newEmptyBuffer f =
stringToNewBuffer (FileBuffer f) mempty
setupMode :: FilePath -> BufferRef -> YiM BufferRef
setupMode f b = do
tbl <- asks (modeTable . yiConfig)
content <- withGivenBuffer b elemsB
let header = R.take 1024 content
rx = ICU.regex [] "\\-\\*\\- *([^ ]*) *\\-\\*\\-"
hmode = case ICU.find rx (R.toText header) of
Nothing -> ""
Just m -> case (ICU.group 1 m) of
Just n -> n
Nothing -> ""
Just mode = find (\(AnyMode m) -> modeName m == hmode) tbl <|>
find (\(AnyMode m) -> modeApplies m f header) tbl <|>
Just (AnyMode emptyMode)
case mode of
AnyMode newMode -> withGivenBuffer b $ setMode newMode
return b
bypassReadOnly :: BufferM a -> BufferM a
bypassReadOnly f = do ro <- use readOnlyA
assign readOnlyA False
res <- f
assign readOnlyA ro
return res
filenameColOf :: BufferM () -> BufferM ()
filenameColOf f = getBufferDyn >>= assign preferColA . Just . diredNameCol >> f
resetDiredOpState :: YiM ()
resetDiredOpState = withCurrentBuffer $ putBufferDyn (def :: DiredOpState)
incDiredOpSucCnt :: YiM ()
incDiredOpSucCnt =
withCurrentBuffer $ getBufferDyn >>= putBufferDyn . (diredOpSucCnt %~ succ)
getDiredOpState :: YiM DiredOpState
getDiredOpState = withCurrentBuffer getBufferDyn
modDiredOpState :: (DiredOpState -> DiredOpState) -> YiM ()
modDiredOpState f = withCurrentBuffer $ getBufferDyn >>= putBufferDyn . f
procDiredOp :: Bool -> [DiredOp] -> YiM ()
procDiredOp counting (DORemoveFile f:ops) = do
io $ printingException ("Remove file " <> f) (removeLink f)
when counting postproc
procDiredOp counting ops
where postproc = do incDiredOpSucCnt
withCurrentBuffer $ diredUnmarkPath (takeFileName f)
procDiredOp counting (DORemoveDir f:ops) = do
io $ printingException ("Remove directory " <> f) (removeDirectoryRecursive f)
when counting postproc
procDiredOp counting ops
where postproc = do
incDiredOpSucCnt
withCurrentBuffer $ diredUnmarkPath (takeFileName f)
procDiredOp _counting (DORemoveBuffer _:_) = undefined
procDiredOp counting (DOCopyFile o n:ops) = do
io $ printingException ("Copy file " <> o) (copyFile o n)
when counting postproc
procDiredOp counting ops
where postproc = do
incDiredOpSucCnt
withCurrentBuffer $ diredUnmarkPath (takeFileName o)
procDiredOp counting (DOCopyDir o n:ops) = do
contents <- io $ printingException
(concat ["Copy directory ", o, " to ", n]) doCopy
subops <- io $ mapM builder $ filter (`notElem` [".", ".."]) contents
procDiredOp False subops
when counting postproc
procDiredOp counting ops
where postproc = do
incDiredOpSucCnt
withCurrentBuffer $ diredUnmarkPath (takeFileName o)
doCopy :: IO [FilePath]
doCopy = do
exists <- doesDirectoryExist n
when exists $ removeDirectoryRecursive n
createDirectoryIfMissing True n
getDirectoryContents o
builder :: FilePath -> IO DiredOp
builder name = do
let npath = n </> name
let opath = o </> name
isDir <- doesDirectoryExist opath
return $ DOCkOverwrite npath $ getOp isDir opath npath
where getOp isDir = if isDir then DOCopyDir else DOCopyFile
procDiredOp counting (DORename o n:ops) = do
io $ printingException (concat ["Rename ", o, " to ", n]) (rename o n)
when counting postproc
procDiredOp counting ops
where postproc = do
incDiredOpSucCnt
withCurrentBuffer $ diredUnmarkPath (takeFileName o)
procDiredOp counting r@(DOConfirm prompt eops enops:ops) =
withMinibuffer (R.toText $ prompt <> " (yes/no)") noHint (act . T.unpack)
where act s = case map toLower s of
"yes" -> procDiredOp counting (eops <> ops)
"no" -> procDiredOp counting (enops <> ops)
_ -> procDiredOp counting r
procDiredOp counting (DOCheck check eops enops:ops) = do
res <- io check
procDiredOp counting (if res then eops <> ops else enops <> ops)
procDiredOp counting (DOCkOverwrite fp op:ops) = do
exists <- io $ fileExist fp
procDiredOp counting (if exists then newOp:ops else op:ops)
where newOp = DOChoice ("Overwrite " <> R.fromString fp <> " ?") op
procDiredOp counting (DOInput prompt opGen:ops) =
promptFile (R.toText prompt) (act . T.unpack)
where act s = procDiredOp counting $ opGen s <> ops
procDiredOp counting (DONoOp:ops) = procDiredOp counting ops
procDiredOp counting (DOFeedback f:ops) =
getDiredOpState >>= f >> procDiredOp counting ops
procDiredOp counting r@(DOChoice prompt op:ops) = do
st <- getDiredOpState
if st ^. diredOpForAll
then proceedYes
else withEditor_ $ spawnMinibufferE msg (const askKeymap)
where msg = R.toText $ prompt <> " (y/n/!/q/h)"
askKeymap = choice [ char 'n' ?>>! noAction
, char 'y' ?>>! yesAction
, char '!' ?>>! allAction
, char 'q' ?>>! quit
, char 'h' ?>>! help
]
noAction = cleanUp >> proceedNo
yesAction = cleanUp >> proceedYes
allAction = do cleanUp
modDiredOpState (diredOpForAll .~ True)
proceedYes
quit = cleanUp >> printMsg "Quit"
help = do
printMsg
"y: yes, n: no, !: yes on all remaining items, q: quit, h: help"
cleanUp
procDiredOp counting r
cleanUp = withEditor closeBufferAndWindowE
proceedYes = procDiredOp counting (op:ops)
proceedNo = procDiredOp counting ops
procDiredOp _ _ = return ()
askDelFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()
askDelFiles dir fs =
case fs of
(_x:_) -> do
resetDiredOpState
opList <- io $ sequence ops
let ops' = opList <> [DOFeedback showResult]
procDiredOp True [DOConfirm prompt ops' [DOFeedback showNothing]]
[] -> procDiredOp True [DOFeedback showNothing]
where
prompt = R.concat [ "Delete "
, R.fromString . show $ length fs
, " file(s)?"
]
ops = map opGenerator fs
showResult st = do
diredRefresh
printMsg $ showT (st ^. diredOpSucCnt) <> " of "
<> showT total <> " deletions done"
showNothing _ = printMsg "(No deletions requested)"
total = length fs
opGenerator :: (FilePath, DiredEntry) -> IO DiredOp
opGenerator (fn, de) = do
exists <- fileExist path
if exists then case de of
(DiredDir _dfi) -> do
isNull <- fmap nullDir $ getDirectoryContents path
return $ if isNull then DOConfirm recDelPrompt
[DORemoveDir path] [DONoOp]
else DORemoveDir path
_ -> return (DORemoveFile path)
else return DONoOp
where path = dir </> fn
recDelPrompt = "Recursive delete of " <> R.fromString fn <> "?"
nullDir :: [FilePath] -> Bool
nullDir = Data.List.any (not . flip Data.List.elem [".", ".."])
diredDoDel :: YiM ()
diredDoDel = do
dir <- currentDir
maybefile <- withCurrentBuffer fileFromPoint
case maybefile of
Just (fn, de) -> askDelFiles dir [(fn, de)]
Nothing -> noFileAtThisLine
diredDoMarkedDel :: YiM ()
diredDoMarkedDel = do
dir <- currentDir
fs <- markedFiles (== 'D')
askDelFiles dir fs
diredKeymap :: Keymap -> Keymap
diredKeymap = important $ withArg mainMap
where
withArg :: (Maybe Int -> Keymap) -> Keymap
withArg k = choice [ ctrlCh 'u' ?>> k (Just 1) , k Nothing ]
mainMap :: Maybe Int -> Keymap
mainMap univArg = choice
[ char 'p' ?>>! filenameColOf lineUp
, oneOf [char 'n', char ' '] >>! filenameColOf lineDown
, char 'd' ?>>! diredMarkDel
, char 'g' ?>>! diredRefresh
, char 'm' ?>>! diredMark
, char '^' ?>>! diredUpDir
, char '+' ?>>! diredCreateDir
, char 'q' ?>>!
((deleteBuffer =<< gets currentBuffer) :: EditorM ())
, char 'x' ?>>! diredDoMarkedDel
, oneOf [ctrl $ char 'm', spec KEnter, char 'f', char 'e'] >>! diredLoad
, char 'o' ?>>! withOtherWindow diredLoad
, char 'u' ?>>! diredUnmark Forward
, spec KBS ?>>! diredUnmark Backward
, char 'D' ?>>! diredDoDel
, char 'U' ?>>! diredUnmarkAll
, char 'R' ?>>! diredRename
, char 'C' ?>>! diredCopy
, char '*' ?>> multiMarks univArg
]
multiMarks :: Maybe Int -> Keymap
multiMarks univArg = choice
[ char '!' ?>>! diredUnmarkAll
, char '@' ?>>! diredMarkSymlinks univArg
, char '/' ?>>! diredMarkDirectories univArg
, char 't' ?>>! diredToggleAllMarks
]
dired :: YiM ()
dired = do
printMsg "Dired..."
maybepath <- withCurrentBuffer $ gets file
dir <- io $ getFolder maybepath
void $ editFile dir
diredDir :: FilePath -> YiM ()
diredDir dir = void (diredDirBuffer dir)
diredDirBuffer :: FilePath -> YiM BufferRef
diredDirBuffer d = do
dir <- io $ canonicalizePath d
b <- stringToNewBuffer (FileBuffer dir) mempty
withEditor $ switchToBufferE b
withCurrentBuffer $ do
state <- getBufferDyn
putBufferDyn (state & diredPathA .~ dir)
directoryContentA .= True
diredRefresh
return b
diredRefresh :: YiM ()
diredRefresh = do
dState <- withCurrentBuffer getBufferDyn
let dir = diredPath dState
di <- io $ diredScanDir dir
currFile <- if null (diredFilePoints dState)
then return ""
else do maybefile <- withCurrentBuffer fileFromPoint
case maybefile of
Just (fp, _) -> return fp
Nothing -> return ""
let ds = diredEntriesA .~ di $ diredCurrFileA .~ currFile $ dState
let dlines = linesToDisplay ds
(strss, stys, strs) = unzip3 dlines
strss' = transpose $ map doPadding $ transpose strss
namecol = if null strss' then 0 else
let l1details = init $ head strss'
in Data.List.sum (map R.length l1details) + length l1details
withCurrentBuffer $ do
assign readOnlyA False
deleteRegionB =<< regionOfB Document
insertN $ R.fromString dir <> ":\n"
p <- pointB
addOverlayB $ mkOverlay "dired" (mkRegion 0 (p2)) headStyle ""
ptsList <- mapM insertDiredLine $ zip3 strss' stys strs
putBufferDyn $ diredFilePointsA .~ ptsList $ diredNameColA .~ namecol $ ds
modifyMode $ modeKeymapA .~ topKeymapA %~ diredKeymap
>>> modeNameA .~ "dired"
diredRefreshMark
assign readOnlyA True
when (null currFile) $ moveTo (p2)
case getRow currFile ptsList of
Just rpos -> filenameColOf $ moveTo rpos
Nothing -> filenameColOf lineDown
where
getRow fp recList = lookup fp (map (\(a,_b,c)->(c,a)) recList)
headStyle = const (withFg grey)
doPadding :: [DRStrings] -> [R.YiString]
doPadding drs = map (pad ((maximum . map drlength) drs)) drs
pad _n (DRPerms s) = s
pad n (DRLinks s) = R.replicate (max 0 (n R.length s)) " " <> s
pad n (DROwners s) = s <> R.replicate (max 0 (n R.length s)) " " <> " "
pad n (DRGroups s) = s <> R.replicate (max 0 (n R.length s)) " "
pad n (DRSizes s) = R.replicate (max 0 (n R.length s)) " " <> s
pad n (DRDates s) = R.replicate (max 0 (n R.length s)) " " <> s
pad _n (DRFiles s) = s
drlength = R.length . undrs
insertDiredLine :: ([R.YiString], StyleName, R.YiString)
-> BufferM (Point, Point, FilePath)
insertDiredLine (fields, sty, filenm) = bypassReadOnly $ do
insertN . R.unwords $ init fields
p1 <- pointB
insertN $ ' ' `R.cons` last fields
p2 <- pointB
newlineB
addOverlayB (mkOverlay "dired" (mkRegion p1 p2) sty "")
return (p1, p2, R.toString filenm)
data DRStrings = DRPerms {undrs :: R.YiString}
| DRLinks {undrs :: R.YiString}
| DROwners {undrs :: R.YiString}
| DRGroups {undrs :: R.YiString}
| DRSizes {undrs :: R.YiString}
| DRDates {undrs :: R.YiString}
| DRFiles {undrs :: R.YiString}
linesToDisplay :: DiredState -> [([DRStrings], StyleName, R.YiString)]
linesToDisplay dState = map (uncurry lineToDisplay) (M.assocs entries)
where
entries = diredEntries dState
lineToDisplay k (DiredFile v) =
(l " -" v <> [DRFiles k], defaultStyle, k)
lineToDisplay k (DiredDir v) =
(l " d" v <> [DRFiles k], const (withFg blue), k)
lineToDisplay k (DiredSymLink v s) =
(l " l" v <> [DRFiles $ k <> " -> " <> s], const (withFg cyan), k)
lineToDisplay k (DiredSocket v) =
(l " s" v <> [DRFiles k], const (withFg magenta), k)
lineToDisplay k (DiredCharacterDevice v) =
(l " c" v <> [DRFiles k], const (withFg yellow), k)
lineToDisplay k (DiredBlockDevice v) =
(l " b" v <> [DRFiles k], const (withFg yellow), k)
lineToDisplay k (DiredNamedPipe v) =
(l " p" v <> [DRFiles k], const (withFg brown), k)
lineToDisplay k DiredNoInfo =
([DRFiles $ k <> " : Not a file/dir/symlink"], defaultStyle, k)
l pre v = [DRPerms $ pre <> permString v,
DRLinks . R.fromString $ printf "%4d" (numLinks v),
DROwners $ owner v,
DRGroups $ grp v,
DRSizes . R.fromString $ printf "%8d" (sizeInBytes v),
DRDates $ modificationTimeString v]
diredScanDir :: FilePath -> IO DiredEntries
diredScanDir dir = do
files <- getDirectoryContents dir
foldM (lineForFile dir) M.empty files
where
lineForFile :: FilePath
-> DiredEntries
-> FilePath
-> IO DiredEntries
lineForFile d m f = do
let fp = d </> f
fileStatus <- getSymbolicLinkStatus fp
dfi <- lineForFilePath fp fileStatus
let islink = isSymbolicLink fileStatus
linkTarget <- if islink then readSymbolicLink fp else return mempty
let de
| isDirectory fileStatus = DiredDir dfi
| isRegularFile fileStatus = DiredFile dfi
| islink = DiredSymLink dfi (R.fromString linkTarget)
| isSocket fileStatus = DiredSocket dfi
| isCharacterDevice fileStatus = DiredCharacterDevice dfi
| isBlockDevice fileStatus = DiredBlockDevice dfi
| isNamedPipe fileStatus = DiredNamedPipe dfi
| otherwise = DiredNoInfo
return $ M.insert (R.fromString f) de m
lineForFilePath :: FilePath -> FileStatus -> IO DiredFileInfo
lineForFilePath fp fileStatus = do
let modTimeStr = R.fromString . shortCalendarTimeToString
. posixSecondsToUTCTime . realToFrac
$ modificationTime fileStatus
let uid = fileOwner fileStatus
gid = fileGroup fileStatus
fn = takeFileName fp
_filenm <- if isSymbolicLink fileStatus
then return . ((fn <> " -> ") <>) =<< readSymbolicLink fp
else return fn
ownerEntry <- orException (getUserEntryForID uid)
(fmap (scanForUid uid) getAllUserEntries)
groupEntry <- orException (getGroupEntryForID gid)
(fmap (scanForGid gid) getAllGroupEntries)
let fmodeStr = (modeString . fileMode) fileStatus
sz = toInteger $ fileSize fileStatus
ownerStr = R.fromString $ userName ownerEntry
groupStr = R.fromString $ groupName groupEntry
numOfLinks = toInteger $ linkCount fileStatus
return DiredFileInfo { permString = fmodeStr
, numLinks = numOfLinks
, owner = ownerStr
, grp = groupStr
, sizeInBytes = sz
, modificationTimeString = modTimeStr}
scanForUid :: UserID -> [UserEntry] -> UserEntry
scanForUid uid entries = fromMaybe missingEntry $
find ((uid ==) . userID) entries
where
missingEntry = UserEntry "?" mempty uid 0 mempty mempty mempty
scanForGid :: GroupID -> [GroupEntry] -> GroupEntry
scanForGid gid entries = fromMaybe missingEntry $
find ((gid ==) . groupID) entries
where
missingEntry = GroupEntry "?" mempty gid mempty
modeString :: FileMode -> R.YiString
modeString fm = ""
<> strIfSet "r" ownerReadMode
<> strIfSet "w" ownerWriteMode
<> strIfSet "x" ownerExecuteMode
<> strIfSet "r" groupReadMode
<> strIfSet "w" groupWriteMode
<> strIfSet "x" groupExecuteMode
<> strIfSet "r" otherReadMode
<> strIfSet "w" otherWriteMode
<> strIfSet "x" otherExecuteMode
where
strIfSet s mode = if fm == (fm `unionFileModes` mode) then s else "-"
shortCalendarTimeToString :: UTCTime -> String
shortCalendarTimeToString = formatTime defaultTimeLocale "%b %d %H:%M"
diredMark :: BufferM ()
diredMark = diredMarkWithChar '*' lineDown
diredMarkDel :: BufferM ()
diredMarkDel = diredMarkWithChar 'D' lineDown
diredMarkKind :: Maybe Int
-> (DiredFilePath -> DiredEntry -> Bool)
-> Char
-> BufferM ()
diredMarkKind m p c = bypassReadOnly $ do
dState <- getBufferDyn
let es = M.assocs $ diredEntries dState
ms = M.fromList [ (R.toString fp, c) | (fp, e) <- es, p fp e ]
putBufferDyn (dState & diredMarksA %~ run ms)
diredRefreshMark
where
run :: M.Map FilePath Char -> M.Map FilePath Char -> M.Map FilePath Char
run ms cms = case m of
Nothing -> M.union ms cms
Just _ -> deleteKeys cms (M.keys ms)
diredMarkSymlinks :: Maybe Int -> BufferM ()
diredMarkSymlinks m = diredMarkKind m p '*'
where
p _ DiredSymLink {} = True
p _ _ = False
diredMarkDirectories :: Maybe Int -> BufferM ()
diredMarkDirectories m = diredMarkKind m p '*'
where
p "." DiredDir {} = False
p ".." DiredDir {} = False
p _ DiredDir {} = True
p _ _ = False
diredToggleAllMarks :: BufferM ()
diredToggleAllMarks = bypassReadOnly $ do
dState <- getBufferDyn
let es = diredEntries dState
putBufferDyn (dState & diredMarksA %~ tm es)
diredRefreshMark
where
tm :: DiredEntries -> M.Map FilePath Char -> M.Map FilePath Char
tm de ms = let unmarked = deleteKeys (M.mapKeys R.toString de) (M.keys ms)
in M.map (const '*') unmarked
deleteKeys :: Ord k => M.Map k v -> [k] -> M.Map k v
deleteKeys = foldl' (flip M.delete)
diredMarkWithChar :: Char -> BufferM () -> BufferM ()
diredMarkWithChar c mv = bypassReadOnly $
fileFromPoint >>= \case
Just (fn, _de) -> do
state <- getBufferDyn
putBufferDyn (state & diredMarksA %~ M.insert fn c)
filenameColOf mv
diredRefreshMark
Nothing -> filenameColOf mv
diredRefreshMark :: BufferM ()
diredRefreshMark = do
b <- pointB
dState <- getBufferDyn
let posDict = diredFilePoints dState
markMap = diredMarks dState
draw (pos, _, fn) = case M.lookup fn markMap of
Just mark -> do
moveTo pos >> moveToSol >> insertB mark >> deleteN 1
e <- pointB
addOverlayB $
mkOverlay "dired" (mkRegion (e 1) e) (styleOfMark mark) ""
Nothing ->
moveTo pos >> moveToSol >> insertN " " >> deleteN 1
mapM_ draw posDict
moveTo b
where
styleOfMark '*' = const (withFg green)
styleOfMark 'D' = const (withFg red)
styleOfMark _ = defaultStyle
diredUnmark :: Direction
-> BufferM ()
diredUnmark d = bypassReadOnly $ do
let lineDir = case d of { Forward -> lineDown; Backward -> lineUp; }
fileFromPoint >>= \case
Just (fn, _de) -> do
diredUnmarkPath fn
filenameColOf lineDir
diredRefreshMark
Nothing -> filenameColOf lineDir
diredUnmarkPath :: FilePath -> BufferM()
diredUnmarkPath fn = getBufferDyn >>= putBufferDyn.(diredMarksA %~ M.delete fn)
diredUnmarkAll :: BufferM ()
diredUnmarkAll = bypassReadOnly $ do
getBufferDyn >>= putBufferDyn.(diredMarksA .~ M.empty)
filenameColOf $ return ()
diredRefreshMark
currentDir :: YiM FilePath
currentDir = diredPath <$> withCurrentBuffer getBufferDyn
askRenameFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()
askRenameFiles dir fs = case fs of
[_x] -> do resetDiredOpState
procDiredOp True [DOInput prompt sOpIsDir]
_x:_ -> do resetDiredOpState
procDiredOp True [DOInput prompt mOpIsDirAndExists]
[] -> procDiredOp True [DOFeedback showNothing]
where
mkErr t = return . DOFeedback . const $ errorEditor t
prompt = "Move " <> R.fromString (show total) <> " item(s) to:"
mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps]
where
posOps = map builder fs <> [DOFeedback showResult]
negOps = mkErr $ T.pack t <> " is not directory!"
builder (fn, _de) = let old = dir </> fn
new = t </> fn
in DOCkOverwrite new (DORename old new)
sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirRename]
where (fn, _) = head fs
posOps = [DOCkOverwrite new (DORename old new),
DOFeedback showResult]
where new = t </> fn
old = dir </> fn
sOpDirRename = [DOCheck ckParentDir posOps' negOps,
DOFeedback showResult]
where posOps' = [DOCkOverwrite new (DORename old new)]
p = "Cannot move " <> T.pack old
<> " to " <> T.pack new
negOps = mkErr p
new = t
old = dir </> fn
ps = dropTrailingPathSeparator t
ckParentDir = doesDirectoryExist $ takeDirectory ps
showResult st = do
diredRefresh
printMsg $ showT (st ^. diredOpSucCnt) <> " of "
<> showT total <> " item(s) moved."
showNothing _ = printMsg "Quit"
total = length fs
askCopyFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()
askCopyFiles dir fs =
case fs of
[_x] -> do resetDiredOpState
procDiredOp True [DOInput prompt sOpIsDir]
_x:_ -> do resetDiredOpState
procDiredOp True [DOInput prompt mOpIsDirAndExists]
[] -> procDiredOp True [DOFeedback showNothing]
where
prompt = "Copy " <> R.fromString (show total) <> " item(s) to:"
mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps]
where
posOps = map builder fs <> [DOFeedback showResult]
negOps = [DOFeedback . const $
errorEditor (T.pack t <> " is not directory!")]
builder (fn, de) = let old = dir </> fn
new = t </> fn
in DOCkOverwrite new (op4Type de old new)
sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirCopy]
where (fn, de) = head fs
posOps = [DOCkOverwrite new (op4Type de old new),
DOFeedback showResult]
where new = t </> fn
old = dir </> fn
sOpDirCopy = [DOCheck ckParentDir posOps' negOps,
DOFeedback showResult]
where posOps' = [DOCkOverwrite new (op4Type de old new)]
p = "Cannot copy " <> T.pack old <> " to " <> T.pack new
negOps =
[DOFeedback . const $ errorEditor p]
new = t
old = dir </> fn
ckParentDir = doesDirectoryExist $
takeDirectory (dropTrailingPathSeparator t)
showResult st = do
diredRefresh
printMsg $ showT (st ^. diredOpSucCnt) <> " of "
<> showT total <> " item(s) copied."
showNothing _ = printMsg "Quit"
total = length fs
op4Type :: DiredEntry -> FilePath -> FilePath -> DiredOp
op4Type (DiredDir _) = DOCopyDir
op4Type _ = DOCopyFile
diredRename :: YiM ()
diredRename = do
dir <- currentDir
fs <- markedFiles (== '*')
if null fs then do maybefile <- withCurrentBuffer fileFromPoint
case maybefile of
Just (fn, de) -> askRenameFiles dir [(fn, de)]
Nothing -> noFileAtThisLine
else askRenameFiles dir fs
diredCopy :: YiM ()
diredCopy = do
dir <- currentDir
fs <- markedFiles (== '*')
if null fs then do maybefile <- withCurrentBuffer fileFromPoint
case maybefile of
Just (fn, de) -> askCopyFiles dir [(fn, de)]
Nothing -> noFileAtThisLine
else askCopyFiles dir fs
diredLoad :: YiM ()
diredLoad = do
dir <- currentDir
withCurrentBuffer fileFromPoint >>= \case
Just (fn, de) -> do
let sel = dir </> fn
sel' = T.pack sel
case de of
(DiredFile _dfi) -> do
exists <- io $ doesFileExist sel
if exists
then void $ editFile sel
else printMsg $ sel' <> " no longer exists"
(DiredDir _dfi) -> do
exists <- io $ doesDirectoryExist sel
if exists
then diredDir sel
else printMsg $ sel' <> " no longer exists"
(DiredSymLink _dfi dest') -> do
let dest = R.toString dest'
target = if isAbsolute dest then dest else dir </> dest
existsFile <- io $ doesFileExist target
existsDir <- io $ doesDirectoryExist target
printMsg $ "Following link:" <> T.pack target
if existsFile then void $ editFile target else
if existsDir then diredDir target else
printMsg $ T.pack target <> " does not exist"
(DiredSocket _dfi) -> do
exists <- io $ doesFileExist sel
printMsg (if exists
then "Can't open Socket " <> sel'
else sel' <> " no longer exists")
(DiredBlockDevice _dfi) -> do
exists <- io $ doesFileExist sel
printMsg (if exists
then "Can't open Block Device " <> sel'
else sel' <> " no longer exists")
(DiredCharacterDevice _dfi) -> do
exists <- io $ doesFileExist sel
printMsg (if exists
then "Can't open Character Device " <> sel'
else sel' <> " no longer exists")
(DiredNamedPipe _dfi) -> do
exists <- io $ doesFileExist sel
printMsg (if exists
then "Can't open Pipe " <> sel'
else sel' <> " no longer exists")
DiredNoInfo -> printMsg $ "No File Info for:" <> sel'
Nothing -> noFileAtThisLine
noFileAtThisLine :: YiM ()
noFileAtThisLine = printMsg "(No file at this line)"
fileFromPoint :: BufferM (Maybe (FilePath, DiredEntry))
fileFromPoint = do
p <- pointB
dState <- getBufferDyn
let candidates = filter (\(_,p2,_)->p <= p2) (diredFilePoints dState)
finddef f = M.findWithDefault DiredNoInfo (R.fromString f)
return $ case candidates of
((_, _, f):_) -> Just (f, finddef f $ diredEntries dState)
_ -> Nothing
markedFiles :: (Char -> Bool) -> YiM [(FilePath, DiredEntry)]
markedFiles cond = do
dState <- withCurrentBuffer getBufferDyn
let fs = fst . unzip $ filter (cond . snd) (M.assocs $ diredMarks dState)
return $ map (\f -> (f, diredEntries dState M.! R.fromString f)) fs
diredUpDir :: YiM ()
diredUpDir = do
dir <- currentDir
diredDir $ takeDirectory dir
diredCreateDir :: YiM ()
diredCreateDir =
withMinibufferFree "Create Dir:" $ \nm -> do
dir <- currentDir
let newdir = dir </> T.unpack nm
printMsg $ "Creating " <> T.pack newdir <> "..."
io $ createDirectoryIfMissing True newdir
diredRefresh
data DiredOp = DORemoveFile FilePath
| DORemoveDir FilePath
| DOCopyFile FilePath FilePath
| DOCopyDir FilePath FilePath
| DORename FilePath FilePath
| DORemoveBuffer FilePath
| DOConfirm R.YiString [DiredOp] [DiredOp]
| DOCheck (IO Bool) [DiredOp] [DiredOp]
| DOCkOverwrite FilePath DiredOp
| DOInput R.YiString (String -> [DiredOp])
| DOChoice R.YiString DiredOp
| DOFeedback (DiredOpState -> YiM ())
| DONoOp