{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} -- Copyright (c) 2007, 2008, 2009 Ben Moseley, Wen Pu -- | A Simple Dired Implementation for Yi -- TODO ------- -- add more comments -- Support Symlinks -- Mark operations -- - search -- Improve the colouring to show -- - loaded buffers -- - .hs files -- - marked files -- Fix old mod dates (> 6months) to show year -- Fix the 'number of links' field to show actual values not just 1... -- Automatic support for browsing .zip, .gz files etc... module Yi.Dired ( dired , diredDir , diredDirBuffer ) where import Prelude (catch, realToFrac) import qualified Codec.Binary.UTF8.String as UTF8 import Control.Monad.Reader hiding (mapM) import Data.Binary import Data.List hiding (find, maximum, concat) import Data.Maybe import Data.Char (toLower) import Data.DeriveTH import qualified Data.Map as M import qualified Data.Rope as R import Data.Time import Data.Time.Clock.POSIX import System.Directory hiding (canonicalizePath) import System.FilePath import System.CanonicalizePath (canonicalizePath) import System.Locale import System.PosixCompat.Files import System.PosixCompat.Types import System.PosixCompat.User import Text.Printf import Yi.Core hiding (sequence, forM, notElem) import {-# source #-} Yi.File (editFile) import Yi.MiniBuffer (spawnMinibufferE, withMinibufferGen, noHint, withMinibuffer) import Yi.Misc (getFolder, promptFile) import Yi.Style data DiredFileInfo = DiredFileInfo { permString :: String , numLinks :: Integer , owner :: String , grp :: String , sizeInBytes :: Integer , modificationTimeString :: String } deriving (Show, Eq, Typeable) data DiredEntry = DiredFile DiredFileInfo | DiredDir DiredFileInfo | DiredSymLink DiredFileInfo String | DiredSocket DiredFileInfo | DiredBlockDevice DiredFileInfo | DiredCharacterDevice DiredFileInfo | DiredNamedPipe DiredFileInfo | DiredNoInfo deriving (Show, Eq, Typeable) data DiredState = DiredState { diredPath :: FilePath -- ^ The full path to the directory being viewed -- FIXME Choose better data structure for Marks... , diredMarks :: M.Map FilePath Char -- ^ Map values are just leafnames, not full paths , diredEntries :: M.Map FilePath DiredEntry -- ^ keys are just leafnames, not full paths , diredFilePoints :: [(Point,Point,FilePath)] -- ^ position in the buffer where filename is , diredNameCol :: Int -- ^ position on line where filename is (all pointA are this col) , diredCurrFile :: FilePath -- ^ keep the position of pointer (for refreshing dired buffer) } deriving (Show, Eq, Typeable) $(derive makeBinary ''DiredState) instance Initializable DiredState where initial = DiredState { diredPath = "" , diredMarks = M.empty , diredEntries = M.empty , diredFilePoints = [] , diredNameCol = 0 , diredCurrFile = "" } instance YiVariable DiredState $(derives [makeBinary] [''DiredEntry, ''DiredFileInfo]) bypassReadOnly :: BufferM a -> BufferM a bypassReadOnly f = do ro <- getA readOnlyA putA readOnlyA False res <- f putA readOnlyA ro return res filenameColOf :: BufferM () -> BufferM () filenameColOf f = getA bufferDynamicValueA >>= setPrefCol . Just . diredNameCol >> f resetDiredOpState :: YiM () resetDiredOpState = withBuffer $ modA bufferDynamicValueA (\_ds -> initial :: DiredOpState) incDiredOpSucCnt :: YiM () incDiredOpSucCnt = withBuffer $ modA bufferDynamicValueA (\ds -> ds { diredOpSucCnt = (diredOpSucCnt ds) + 1 }) getDiredOpState :: YiM DiredOpState getDiredOpState = withBuffer $ getA bufferDynamicValueA modDiredOpState :: (DiredOpState -> DiredOpState) -> YiM () modDiredOpState f = withBuffer $ modA bufferDynamicValueA f -- | execute the operations -- Pass the list of remaining operations down, insert new ops at the head if needed procDiredOp :: Bool -> [DiredOp] -> YiM () procDiredOp counting ((DORemoveFile f):ops) = do io $ catch (removeLink f) handler when counting postproc procDiredOp counting ops where handler err = fail $ concat ["Remove file ", f, " failed: ", show err] postproc = do incDiredOpSucCnt withBuffer $ diredUnmarkPath (takeFileName f) procDiredOp counting ((DORemoveDir f):ops) = do io $ catch (removeDirectoryRecursive f) handler -- document suggests removeDirectoryRecursive will follow -- symlinks in f, but it seems not the case, at least on OS X. when counting postproc procDiredOp counting ops where handler err = fail $ concat ["Remove directory ", f, " failed: ", show err] postproc = do incDiredOpSucCnt withBuffer $ diredUnmarkPath (takeFileName f) procDiredOp _counting ((DORemoveBuffer _):_) = undefined -- TODO procDiredOp counting ((DOCopyFile o n):ops) = do io $ catch (copyFile o n) handler when counting postproc procDiredOp counting ops where handler err = fail $ concat ["Copy file ", o, " to ", n, " failed: ", show err] postproc = do incDiredOpSucCnt withBuffer $ diredUnmarkPath (takeFileName o) -- TODO: mark copied files with "C" if the target dir's dired buffer exists procDiredOp counting ((DOCopyDir o n):ops) = do contents <- io $ catch doCopy handler subops <- io $ mapM builder $ filter (`notElem` [".", ".."]) contents procDiredOp False subops when counting postproc procDiredOp counting ops where handler err = fail $ concat ["Copy directory ", o, " to ", n, " failed: ", show err] postproc = do incDiredOpSucCnt withBuffer $ diredUnmarkPath (takeFileName o) -- perform dir copy: create new dir and create other copy ops doCopy :: IO [FilePath] doCopy = do exists <- doesDirectoryExist n when exists $ removeDirectoryRecursive n createDirectoryIfMissing True n getDirectoryContents o -- build actual copy operations 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 $ catch (rename o n) handler when counting postproc procDiredOp counting ops where handler err = fail $ concat ["Rename ", o, " to ", n, " failed: ", show err] postproc = do incDiredOpSucCnt withBuffer $ diredUnmarkPath (takeFileName o) procDiredOp counting r@((DOConfirm prompt eops enops):ops) = do withMinibuffer (prompt ++ " (yes/no)") noHint act where act s = case map toLower s of "yes" -> procDiredOp counting (eops ++ ops) "no" -> procDiredOp counting (enops ++ ops) _ -> procDiredOp counting r -- TODO: show an error msg procDiredOp counting ((DOCheck check eops enops):ops) = do res <- io $ check if res then procDiredOp counting (eops ++ ops) else procDiredOp counting (enops ++ ops) procDiredOp counting ((DOCkOverwrite fp op):ops) = do exists <- io $ fileExist fp if exists then procDiredOp counting (newOp:ops) else procDiredOp counting (op:ops) where newOp = DOChoice (concat ["Overwrite ", fp, " ?"]) op procDiredOp counting ((DOInput prompt opGen):ops) = do promptFile prompt act where act s = do procDiredOp counting $ (opGen s) ++ ops procDiredOp counting ((DONoOp):ops) = procDiredOp counting ops procDiredOp counting ((DOFeedback f):ops) = do getDiredOpState >>= f >> procDiredOp counting ops procDiredOp counting r@((DOChoice prompt op):ops) = do st <- getDiredOpState if diredOpForAll st then proceedYes else discard $ withEditor $ spawnMinibufferE msg (const askKeymap) where msg = concat [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 (\st -> st{diredOpForAll=True}) proceedYes quit = cleanUp >> msgEditor "Quit" help = do msgEditor $ concat ["y: yes, n: no, ", "!: yes on all remaining items, ", "q: quit, h: help"] cleanUp procDiredOp counting r -- repeat -- use cleanUp to get back the original buffer cleanUp = withEditor closeBufferAndWindowE proceedYes = procDiredOp counting (op:ops) proceedNo = procDiredOp counting ops procDiredOp _ _ = return () -- | delete a list of file in the given directory -- 1. Ask for confirmation, if yes, perform deletions, otherwise showNothing -- 2. Confirmation is required for recursive deletion of non-empty directry, but only the top level one -- 3. Show the number of successful deletions at the end of the excution -- 4. TODO: ask confirmation for wether to remove the associated buffers when a file is removed askDelFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM () askDelFiles dir fs = do case fs of (_x:_) -> do resetDiredOpState -- TODO: show the file name list in new tmp window opList <- io $ sequence ops -- a deletion command is mapped to a list of deletions wrapped up by DOConfirm -- TODO: is `counting' necessary here? procDiredOp True [DOConfirm prompt (opList ++ [DOFeedback showResult]) [DOFeedback showNothing]] -- no files listed [] -> procDiredOp True [DOFeedback showNothing] where prompt = concat ["Delete ", show $ length fs, " file(s)?"] ops = (map opGenerator fs) showResult st = do diredRefresh msgEditor $ concat [show $ diredOpSucCnt st, " of ", show total, " deletions done"] showNothing _ = msgEditor "(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 <- liftM 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 = concat ["Recursive delete of ", fn, "?"] -- Test the emptyness of a folder nullDir :: [FilePath] -> Bool nullDir contents = Data.List.any (not . flip Data.List.elem [".", ".."]) contents diredDoDel :: YiM () diredDoDel = do dir <- currentDir maybefile <- withBuffer fileFromPoint case maybefile of Just (fn, de) -> askDelFiles dir [(fn, de)] Nothing -> noFileAtThisLine diredDoMarkedDel :: YiM () diredDoMarkedDel = do dir <- currentDir fs <- markedFiles (flip Data.List.elem ['D']) askDelFiles dir fs diredKeymap :: Keymap -> Keymap diredKeymap = do (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), char 'x' ?>>! diredDoMarkedDel, oneOf [ctrl $ char 'm', spec KEnter, char 'f'] >>! diredLoad, oneOf [char 'u', spec KBS] >>! diredUnmark, char 'D' ?>>! diredDoDel, char 'U' ?>>! diredUnmarkAll, char 'R' ?>>! diredRename, char 'C' ?>>! diredCopy] <||) dired :: YiM () dired = do msgEditor "Dired..." maybepath <- withBuffer $ gets file dir <- io $ getFolder maybepath discard $ editFile dir diredDir :: FilePath -> YiM () diredDir dir = diredDirBuffer dir >> return () diredDirBuffer :: FilePath -> YiM BufferRef diredDirBuffer d = do -- Emacs doesn't follow symlinks, probbably Yi shouldn't do too dir <- io $ canonicalizePath d -- XXX Don't specify the path as the filename of the buffer. b <- withEditor $ stringToNewBuffer (Left dir) (R.fromString "") withEditor $ switchToBufferE b withBuffer $ modA bufferDynamicValueA $ \ds -> ds { diredPath = dir } diredRefresh return b -- | Write the contents of the supplied directory into the current buffer in dired format diredRefresh :: YiM () diredRefresh = do dState <- withBuffer $ getA bufferDynamicValueA let dir = diredPath dState -- Scan directory di <- io $ diredScanDir dir currFile <- if null (diredFilePoints dState) then return "" else do maybefile <- withBuffer fileFromPoint case maybefile of Just (fp, _) -> return fp Nothing -> return "" let ds = dState {diredEntries = di, diredCurrFile = currFile} -- Compute results 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 length l1details) + (length l1details) -- Set buffer contents withBuffer $ do -- Clear buffer putA readOnlyA False ---- modifications begin here deleteRegionB =<< regionOfB Document -- Write Header insertN $ dir ++ ":\n" p <-pointB -- paint header addOverlayB $ mkOverlay UserLayer (mkRegion 0 (p-2)) headStyle ptsList <- mapM insertDiredLine $ zip3 strss' stys strs putA bufferDynamicValueA ds{diredFilePoints=ptsList, diredNameCol =namecol} -- Colours for Dired come from overlays not syntax highlighting modifyMode $ \m -> m {modeKeymap = topKeymapA ^: diredKeymap, modeName = "dired"} diredRefreshMark ---- no modifications after this line putA readOnlyA True when (null currFile) $ moveTo (p-2) 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] -> [String] doPadding drs = map (pad ((maximum . map drlength) drs)) drs pad _n (DRPerms s) = s pad n (DRLinks s) = (replicate (max 0 (n - length s)) ' ') ++ s pad n (DROwners s) = s ++ (replicate (max 0 (n - length s)) ' ') ++ " " pad n (DRGroups s) = s ++ (replicate (max 0 (n - length s)) ' ') pad n (DRSizes s) = (replicate (max 0 (n - length s)) ' ') ++ s pad n (DRDates s) = (replicate (max 0 (n - length s)) ' ') ++ s pad _n (DRFiles s) = s -- Don't right-justify the filename drlength = length . undrs -- | Returns a tuple containing the textual region (the end of) which is used for 'click' detection -- and the FilePath of the file represented by that textual region insertDiredLine :: ([String], StyleName, String) -> BufferM (Point, Point, FilePath) insertDiredLine (fields, sty, filenm) = bypassReadOnly $ do insertN $ (concat $ intersperse " " (init fields)) p1 <- pointB insertN (" " ++ last fields) p2 <- pointB insertN "\n" addOverlayB (mkOverlay UserLayer (mkRegion p1 p2) sty) return (p1, p2, filenm) data DRStrings = DRPerms {undrs :: String} | DRLinks {undrs :: String} | DROwners {undrs :: String} | DRGroups {undrs :: String} | DRSizes {undrs :: String} | DRDates {undrs :: String} | DRFiles {undrs :: String} -- | Return a List of (prefix, fullDisplayNameIncludingSourceAndDestOfLink, style, filename) linesToDisplay :: DiredState ->([([DRStrings], StyleName, String)]) linesToDisplay dState = map (\(k, i) -> let k' = UTF8.decodeString k in lineToDisplay k' i) (M.assocs $ diredEntries dState) where 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 $ printf "%4d" (numLinks v), DROwners $ owner v, DRGroups $ grp v, DRSizes $ printf "%8d" (sizeInBytes v), DRDates $ modificationTimeString v] -- | Return dired entries for the contents of the supplied directory diredScanDir :: FilePath -> IO (M.Map FilePath DiredEntry) diredScanDir dir = do files <- getDirectoryContents dir -- The file strings as UTF-8 encoded on linux. They need to stay this way for functions that -- stat these paths. However for display they need to be converted to ISO-10646 strings. foldM (lineForFile dir) M.empty files where lineForFile :: String -> M.Map FilePath DiredEntry -> String -> IO (M.Map FilePath DiredEntry) 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 "" let de = if (isDirectory fileStatus) then (DiredDir dfi) else if (isRegularFile fileStatus) then (DiredFile dfi) else if islink then (DiredSymLink dfi linkTarget) else if (isSocket fileStatus) then (DiredSocket dfi) else if (isCharacterDevice fileStatus) then (DiredCharacterDevice dfi) else if (isBlockDevice fileStatus) then (DiredBlockDevice dfi) else if (isNamedPipe fileStatus) then (DiredNamedPipe dfi) else DiredNoInfo return (M.insert f de m) lineForFilePath :: FilePath -> FileStatus -> IO DiredFileInfo lineForFilePath fp fileStatus = do let modTimeStr = shortCalendarTimeToString $ posixSecondsToUTCTime $ realToFrac $ modificationTime fileStatus let uid = fileOwner fileStatus gid = fileGroup fileStatus _filenm <- if (isSymbolicLink fileStatus) then return . ((++) (takeFileName fp ++ " -> ")) =<< readSymbolicLink fp else return $ takeFileName fp ownerEntry <- catch (getUserEntryForID uid) (const $ getAllUserEntries >>= return . scanForUid uid) groupEntry <- catch (getGroupEntryForID gid) (const $ getAllGroupEntries >>= return . scanForGid gid) let fmodeStr = (modeString . fileMode) fileStatus sz = toInteger $ fileSize fileStatus ownerStr = userName ownerEntry groupStr = groupName groupEntry numOfLinks = toInteger $ linkCount fileStatus return $ DiredFileInfo { permString = fmodeStr , numLinks = numOfLinks , owner = ownerStr , grp = groupStr , sizeInBytes = sz , modificationTimeString = modTimeStr} -- | Needed on Mac OS X 10.4 scanForUid :: UserID -> [UserEntry] -> UserEntry scanForUid uid entries = maybe (UserEntry "?" "" uid 0 "" "" "") id (find ((== uid) . userID) entries) -- | Needed on Mac OS X 10.4 scanForGid :: GroupID -> [GroupEntry] -> GroupEntry scanForGid gid entries = maybe (GroupEntry "?" "" gid []) id (find ((== gid) . groupID) entries) modeString :: FileMode -> String 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" -- Default Filter: omit files ending in '~' or '#' and also '.' and '..'. -- TODO: customizable filters? --diredOmitFile :: String -> Bool --diredOmitFile = undefined diredMark :: BufferM () diredMark = diredMarkWithChar '*' lineDown diredMarkDel :: BufferM () diredMarkDel = diredMarkWithChar 'D' lineDown diredMarkWithChar :: Char -> BufferM () -> BufferM () diredMarkWithChar c mv = bypassReadOnly $ do maybefile <- fileFromPoint case maybefile of Just (fn, _de) -> do modA bufferDynamicValueA (\ds -> ds {diredMarks = M.insert fn c $ diredMarks ds}) filenameColOf mv diredRefreshMark Nothing -> filenameColOf mv diredRefreshMark :: BufferM () diredRefreshMark = do b <- pointB dState <- getA bufferDynamicValueA let posDict = diredFilePoints dState markMap = diredMarks dState draw (pos, _, fn) = case M.lookup fn markMap of Just mark -> do moveTo pos >> moveToSol >> insertN [mark] >> deleteN 1 e <- pointB addOverlayB $ mkOverlay UserLayer (mkRegion (e - 1) e) (styleOfMark mark) Nothing -> do -- for deleted marks moveTo pos >> moveToSol >> insertN [' '] >> deleteN 1 Yi.Core.mapM_ draw posDict moveTo b where styleOfMark '*' = const (withFg green) styleOfMark 'D' = const (withFg red) styleOfMark _ = defaultStyle diredUnmark :: BufferM () diredUnmark = bypassReadOnly $ do maybefile <- fileFromPoint case maybefile of Just (fn, _de) -> do modA bufferDynamicValueA (\ds -> ds {diredMarks = M.delete fn $ diredMarks ds}) filenameColOf lineUp diredRefreshMark Nothing -> do filenameColOf lineUp diredUnmarkPath :: FilePath -> BufferM() diredUnmarkPath fn = do modA bufferDynamicValueA (\ds -> ds {diredMarks = M.delete fn $ diredMarks ds}) diredUnmarkAll :: BufferM () diredUnmarkAll = bypassReadOnly $ do modA bufferDynamicValueA (\ds -> ds {diredMarks = const M.empty $ diredMarks ds}) filenameColOf $ return () diredRefreshMark currentDir :: YiM FilePath currentDir = do DiredState { diredPath = dir } <- withBuffer $ getA bufferDynamicValueA return dir -- | move selected files in a given directory to the target location given -- by user input -- -- if multiple source -- then if target is not a existing dir -- then error -- else move source files into target dir -- else if target is dir -- then if target exist -- then move source file into target dir -- else if source is dir and parent of target exists -- then move source to target -- else error -- else if parent of target exist -- then move source to target -- else error 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 prompt = concat ["Move ", show total, " item(s) to:"] mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps] where posOps = (map builder fs) ++ [DOFeedback showResult] negOps = [DOFeedback (\_ -> errorEditor $ concat [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 -- the only item 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)] negOps = [DOFeedback (\_ -> errorEditor $ concat ["Cannot move ", old, " to ", new])] new = t old = dir fn ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t) showResult st = do diredRefresh msgEditor $ concat [show (diredOpSucCnt st), " of ", show total, " item(s) moved."] showNothing _ = msgEditor $ "Quit" total = length fs -- | copy selected files in a given directory to the target location given -- by user input -- -- askCopyFiles follow the same logic as askRenameFiles, -- except dir and file are done by different DiredOP askCopyFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM () askCopyFiles dir fs = do 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 = concat ["Copy ", show total, " item(s) to:"] mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps] where posOps = (map builder fs) ++ [DOFeedback showResult] negOps = [DOFeedback (\_ -> errorEditor $ concat [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 -- the only item 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)] negOps = [DOFeedback (\_ -> errorEditor $ concat ["Cannot copy ", old, " to ", new])] new = t old = dir fn ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t) showResult st = do diredRefresh msgEditor $ concat [show (diredOpSucCnt st), " of ", show total, " item(s) copied."] showNothing _ = msgEditor $ "Quit" total = length fs op4Type :: DiredEntry -> FilePath -> FilePath -> DiredOp op4Type (DiredDir _) = DOCopyDir op4Type _ = DOCopyFile diredRename :: YiM () diredRename = do dir <- currentDir fs <- markedFiles (flip Data.List.elem ['*']) if null fs then do maybefile <- withBuffer 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 (flip Data.List.elem ['*']) if null fs then do maybefile <- withBuffer fileFromPoint case maybefile of Just (fn, de) -> askCopyFiles dir [(fn, de)] Nothing -> noFileAtThisLine else askCopyFiles dir fs diredLoad :: YiM () diredLoad = do dir <- currentDir maybefile <- withBuffer fileFromPoint case maybefile of Just (fn, de) -> do let sel = dir fn case de of (DiredFile _dfi) -> do exists <- io $ doesFileExist sel if exists then discard $ editFile sel else msgEditor $ sel ++ " no longer exists" (DiredDir _dfi) -> do exists <- io $ doesDirectoryExist sel if exists then diredDir sel else msgEditor $ sel ++ " no longer exists" (DiredSymLink _dfi dest) -> do let target = if isAbsolute dest then dest else dir dest existsFile <- io $ doesFileExist target existsDir <- io $ doesDirectoryExist target msgEditor $ "Following link:"++target if existsFile then discard $ editFile target else if existsDir then diredDir target else msgEditor $ target ++ " does not exist" (DiredSocket _dfi) -> do exists <- io $ doesFileExist sel if exists then msgEditor ("Can't open Socket " ++ sel) else msgEditor $ sel ++ " no longer exists" (DiredBlockDevice _dfi) -> do exists <- io $ doesFileExist sel if exists then msgEditor ("Can't open Block Device " ++ sel) else msgEditor $ sel ++ " no longer exists" (DiredCharacterDevice _dfi) -> do exists <- io $ doesFileExist sel if exists then msgEditor ("Can't open Character Device " ++ sel) else msgEditor $ sel ++ " no longer exists" (DiredNamedPipe _dfi) -> do exists <- io $ doesFileExist sel if exists then msgEditor ("Can't open Pipe " ++ sel) else msgEditor $ sel ++ " no longer exists" DiredNoInfo -> msgEditor $ "No File Info for:"++sel Nothing -> noFileAtThisLine noFileAtThisLine :: YiM () noFileAtThisLine = msgEditor "(No file at this line)" -- | Extract the filename at point. NB this may fail if the buffer has been edited. Maybe use Markers instead. fileFromPoint :: BufferM (Maybe (FilePath, DiredEntry)) fileFromPoint = do p <- pointB dState <- getA bufferDynamicValueA let candidates = filter (\(_,p2,_)->p<=p2) (diredFilePoints dState) case candidates of ((_, _, f):_) -> return $ Just (f, M.findWithDefault DiredNoInfo f $ diredEntries dState) _ -> return Nothing markedFiles :: (Char -> Bool) -> YiM [(FilePath, DiredEntry)] markedFiles cond = do dState <- withBuffer $ getA bufferDynamicValueA let fs = fst . unzip $ filter (cond . snd) (M.assocs $ diredMarks dState) return $ map (\f -> (f, (diredEntries dState) M.! f)) fs diredUpDir :: YiM () diredUpDir = do dir <- currentDir diredDir $ takeDirectory dir diredCreateDir :: YiM () diredCreateDir = do withMinibufferGen "" noHint "Create Dir:" return $ \nm -> do dir <- currentDir let newdir = dir nm msgEditor $ "Creating "++newdir++"..." io $ createDirectoryIfMissing True newdir diredRefresh -- | Elementary operations for dired file operations -- Map a dired mark operation (e.g. delete, rename, copy) command -- into a list of DiredOps, and use procDiredOp to excute them. -- Logic and implementation of each operation are packaged in procDiredOp -- See askDelFiles for example. -- If new elem op is added, just add corresponding procDiredOp to handle it. data DiredOp = DORemoveFile FilePath | DORemoveDir FilePath | DOCopyFile FilePath FilePath | DOCopyDir FilePath FilePath | DORename FilePath FilePath | DORemoveBuffer FilePath -- ^ remove the buffers that associate with the file | DOConfirm String [DiredOp] [DiredOp] -- ^ prompt a "yes/no" question. If yes, execute the first list of embedded DiredOps -- otherwise execute the second list of embedded DiredOps | DOCheck (IO Bool) [DiredOp] [DiredOp] -- ^ similar to DOConfirm, but no user interaction. Could be used to check file existence | DOCkOverwrite FilePath DiredOp -- ^ this is a shortcut, it invokes DCChoice if file exists | DOInput String (String -> [DiredOp]) -- ^ prompt a string and collect user input. -- the embedded list of DiredOps is generated based on input, -- Remember that the input should be checked with DOCheck | DOChoice String DiredOp -- ^ prompt a string, provide keybindings for 'y', 'n', '!', 'q' and optional 'h' (help) -- this is useful when overwriting of existing files is required to complete the op -- choice '!' will bypass following DOChoice prompts. | DOFeedback (DiredOpState -> YiM ()) -- ^ to feedback, given the state. such as show the result. | DONoOp -- ^ no operation -- Have no idea how to keep track of this state better, so here it is ... data DiredOpState = DiredOpState { diredOpSucCnt :: !Int -- ^ keep track of the num of successful operations , diredOpForAll :: Bool -- ^ if True, DOChoice will be bypassed } deriving (Show, Eq, Typeable) instance Initializable DiredOpState where initial = DiredOpState {diredOpSucCnt = 0, diredOpForAll = False} $(derive makeBinary ''DiredOpState) instance YiVariable DiredOpState