{-# LANGUAGE DeriveDataTypeable #-} -- Copyright (c) 2007, 2008 Ben Moseley -- | A Simple Dired Implementation for Yi -- TODO ------- -- Support Symlinks -- Mark operations -- - rename -- - delete -- - search -- set buffer to ReadOnly -- 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 ,fnewE ) where import Prelude (uncurry, catch, realToFrac) import qualified Data.ByteString.Lazy as LazyB import Data.List hiding (find, maximum, concat) import Data.Maybe import qualified Data.Map as M import System.Directory import System.FilePath import System.Locale import System.PosixCompat.Files import System.PosixCompat.Types import System.PosixCompat.User import Control.Monad.Reader hiding (mapM) import Data.Time import Data.Time.Clock.POSIX import Text.Printf import Yi.Regex import Yi.MiniBuffer (withMinibufferGen, noHint) import Yi.Config import Yi.Core import Yi.Style import System.FriendlyPath ------------------------------------------------ -- | If file exists, read contents of file into a new buffer, otherwise -- creating a new empty buffer. Replace the current window with a new -- window onto the new buffer. -- -- If the file is already open, just switch to the corresponding buffer. -- -- Need to clean up semantics for when buffers exist, and how to attach -- windows to buffers. -- fnewE :: FilePath -> YiM () fnewE f = fnewCanonicalized =<< liftIO (userToCanonPath f) fnewCanonicalized :: FilePath -> YiM () fnewCanonicalized f = do bufs <- gets bufferSet -- The file names associated with the list of current buffers let bufsWithThisFilename = filter assocWithSameFile bufs -- The names of the existing buffers let fDirectory = takeDirectory f de <- liftIO $ doesDirectoryExist f fe <- liftIO $ doesFileExist f dfe <- liftIO $ doesDirectoryExist fDirectory b <- case bufsWithThisFilename of (h:_) -> return (bkey h) [] -> if de then diredDirBuffer f else do b <- if fe then fileToNewBuffer f else -- File does not exist do when (not dfe) $ do userWantMkDir <- return True -- TODO when userWantMkDir $ liftIO $ createDirectory fDirectory withEditor $ stringToNewBuffer (Right f) (fromString "") -- Create new empty buffer -- adjust the mode tbl <- asks (modeTable . yiConfig) contents <- withGivenBuffer b $ elemsB let header = take 1024 contents hmode = case header =~ "\\-\\*\\- *([^ ]*) *\\-\\*\\-" of AllTextSubmatches [_,m] ->m _ -> "" Just mode = (find (\(AnyMode m)->modeName m == hmode) tbl) <|> (find (\(AnyMode m)->modeApplies m f contents) tbl) <|> Just (AnyMode emptyMode) case mode of AnyMode newMode -> withGivenBuffer b $ setMode newMode return b withEditor $ switchToBufferE b where -- Determines whether or not a given buffer is associated with -- the given file. Note that filepaths are always canonicalized. assocWithSameFile :: FBuffer -> Bool assocWithSameFile fbuffer = case file fbuffer of Nothing -> False Just f2 -> equalFilePath f f2 -- The first argument is the buffer name fileToNewBuffer :: FilePath -> YiM BufferRef fileToNewBuffer path = do contents <- io $ LazyB.readFile path now <- io getCurrentTime b <- withEditor $ stringToNewBuffer (Right path) contents withGivenBuffer b $ markSavedB now return b ------------------------------------------------ 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 Char [FilePath] -- ^ 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 } deriving (Show, Eq, Typeable) instance Initializable DiredState where initial = DiredState { diredPath = "" , diredMarks = M.empty , diredEntries = M.empty , diredFilePoints = [] } diredKeymap :: Keymap -> Keymap diredKeymap = do (choice [ char 'p' ?>>! lineUp, oneOf [char 'n', char ' '] >>! lineDown, char 'b' ?>>! leftB, char 'f' ?>>! rightB, char 'm' ?>>! diredMark, char 'd' ?>>! diredMarkDel, char 'g' ?>>! diredRefresh, char '^' ?>>! diredUpDir, char '+' ?>>! diredCreateDir, char 'q' ?>>! (deleteBuffer =<< gets currentBuffer), oneOf [ctrl $ char 'm', spec KEnter] >>! diredLoad, spec KBS ?>>! diredUnmark] <||) dired :: YiM () dired = do msgEditor "Dired..." dir <- liftIO getCurrentDirectory fnewE dir diredDir :: FilePath -> YiM () diredDir dir = diredDirBuffer dir >> return () diredDirBuffer :: FilePath -> YiM BufferRef diredDirBuffer dir = do b <- withEditor $ stringToNewBuffer (Right dir) (fromString "") withEditor $ switchToBufferE b diredRefresh return b -- | Write the contents of the supplied directory into the current buffer in dired format diredRefresh :: YiM () diredRefresh = do -- Get directory name Just dir <- withBuffer $ gets file -- Scan directory di <- liftIO $ diredScanDir dir let ds = DiredState { diredPath = dir , diredMarks = M.empty , diredEntries = di , diredFilePoints = [] } -- Compute results let dlines = linesToDisplay ds (strss, stys, strs) = unzip3 dlines strss' = transpose $ map doPadding $ transpose $ strss -- Set buffer contents withBuffer $ do -- Clear buffer 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} -- Colours for Dired come from overlays not syntax highlighting modifyMode $ \m -> m {modeKeymap = diredKeymap, modeName = "dired"} moveTo p where 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) = 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 (uncurry lineToDisplay) (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 let filteredFiles = filter (not . diredOmitFile) files foldM (lineForFile dir) M.empty filteredFiles 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 '..'. diredOmitFile :: String -> Bool diredOmitFile = (=~".*~$|.*#$|^\\.$|^\\..$") diredMark :: BufferM () diredMark = diredMarkWithChar '*' lineDown diredMarkDel :: BufferM () diredMarkDel = diredMarkWithChar 'D' lineDown diredMarkWithChar :: Char -> BufferM () -> BufferM () diredMarkWithChar c mv = do p <- pointB moveToSol >> insertN [c] >> deleteN 1 moveTo p mv diredUnmark :: BufferM () diredUnmark = diredMarkWithChar ' ' lineUp diredLoad :: YiM () diredLoad = do (Just dir) <- withBuffer $ gets file (fn, de) <- fileFromPoint let sel = dir fn case de of (DiredFile _dfi) -> do exists <- liftIO $ doesFileExist sel if exists then fnewE sel else msgEditor $ sel ++ " no longer exists" (DiredDir _dfi) -> do exists <- liftIO $ 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 <- liftIO $ doesFileExist target existsDir <- liftIO $ doesDirectoryExist target msgEditor $ "Following link:"++target if existsFile then fnewE target else if existsDir then diredDir target else msgEditor $ target ++ " does not exist" (DiredSocket _dfi) -> do exists <- liftIO $ doesFileExist sel if exists then msgEditor ("Can't open Socket " ++ sel) else msgEditor $ sel ++ " no longer exists" (DiredBlockDevice _dfi) -> do exists <- liftIO $ doesFileExist sel if exists then msgEditor ("Can't open Block Device " ++ sel) else msgEditor $ sel ++ " no longer exists" (DiredCharacterDevice _dfi) -> do exists <- liftIO $ doesFileExist sel if exists then msgEditor ("Can't open Character Device " ++ sel) else msgEditor $ sel ++ " no longer exists" (DiredNamedPipe _dfi) -> do exists <- liftIO $ doesFileExist sel if exists then msgEditor ("Can't open Pipe " ++ sel) else msgEditor $ sel ++ " no longer exists" DiredNoInfo -> msgEditor $ "No File Info for:"++sel -- | Extract the filename at point. NB this may fail if the buffer has been edited. Maybe use Markers instead. fileFromPoint :: YiM (FilePath, DiredEntry) fileFromPoint = do p <- withBuffer pointB dState <- withBuffer $ getA bufferDynamicValueA let (_,_,f) = head $ filter (\(_,p2,_)->p<=p2) (diredFilePoints dState) return (f, M.findWithDefault DiredNoInfo f $ diredEntries dState) diredUpDir :: YiM () diredUpDir = do (Just dir) <- withBuffer $ gets file diredDir $ takeDirectory dir diredCreateDir :: YiM () diredCreateDir = do withMinibufferGen "" noHint "Create Dir:" return $ \nm -> do (Just dir) <- withBuffer $ gets file let newdir = dir nm msgEditor $ "Creating "++newdir++"..." liftIO $ createDirectoryIfMissing True newdir diredRefresh