diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,6 +11,29 @@ A brick widget for exploring file trees. +You can dig through my unfinished cli file browser +[Delve](https://github.com/ChrisPenner/delve) for a few examples if you like. + +Note that this works relatively well, but I give no guarantees about future +maintenance or feature requests. + +Allows selecting multiple files/directories from anywhere in your filesystem +which can be viewed from your brick app and used for whatever you like. + +Note, this uses lazy IO to build the file tree, which will be run iteratively +as you use the UI to explore it; this allows better performance, but all the +usual lazyIO caveats apply; shouldn't cause you too much trouble though. + +## Usage: + +- Create a FileTree using `newFileTree` +- Store this FileTree in your Brick State somewhere +- Render the FileTree using `renderFileTree` +- Wire up handlers for brick events to trigger FileTree actions, e.g. + `moveUp`, `toggleFlagged`, etc. +- At some point you'll want to get the selected object with + `getCurrentFilePath` or get all flagged items with `getFlagged`. + See [Hackage](https://hackage.haskell.org/package/brick-filetree) for docs. -[![asciicast](https://asciinema.org/a/BegqABw8NlGfEJqFfbOIVVozr.svg)](https://asciinema.org/a/BegqABw8NlGfEJqFfbOIVVozr) +![screencast](./screencast.gif) diff --git a/brick-filetree.cabal b/brick-filetree.cabal --- a/brick-filetree.cabal +++ b/brick-filetree.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: a1c35f4807a2c1fe8338398832ea28f66d6766999d7cc199b0f806d2a59daf21 +-- hash: 60b970266b5b619a343adbc75e45bb7b94ca7d210c2f956ceca11f0af49ecfc7 name: brick-filetree -version: 0.1.0.2 +version: 0.1.0.3 description: Please see the README on GitHub at homepage: https://github.com/ChrisPenner/brick-filetree#readme bug-reports: https://github.com/ChrisPenner/brick-filetree/issues diff --git a/src/Brick/Widgets/FileTree.hs b/src/Brick/Widgets/FileTree.hs --- a/src/Brick/Widgets/FileTree.hs +++ b/src/Brick/Widgets/FileTree.hs @@ -2,6 +2,12 @@ ( -- * Types FileTree + , FileContext + , flagged + , val + , path + , name + , kind -- Initialization , newFileTree @@ -25,7 +31,8 @@ -- * Rendering , renderFileTree - , renderSelection + , renderFileTreeCustom + , renderFileContext -- ** Attributes , flaggedItemAttr diff --git a/src/Brick/Widgets/FileTree/Internal/Actions.hs b/src/Brick/Widgets/FileTree/Internal/Actions.hs --- a/src/Brick/Widgets/FileTree/Internal/Actions.hs +++ b/src/Brick/Widgets/FileTree/Internal/Actions.hs @@ -35,59 +35,59 @@ import Data.Maybe overCurrentList - :: (List String SubTree -> EventM String (List String SubTree)) - -> FileTree - -> EventM String FileTree -overCurrentList f fz@(FZ { context = x :< lst }) = do + :: (List String (SubTree a) -> EventM String (List String (SubTree a))) + -> FileTree a + -> EventM String (FileTree a) +overCurrentList f fz@(FT { context = x :< lst }) = do newLst <- f lst return fz { context = x :< newLst } -pressKey :: V.Key -> (FileTree -> EventM String FileTree) +pressKey :: V.Key -> (FileTree a -> EventM String (FileTree a)) pressKey k = overCurrentList (handleListEvent (V.EvKey k [])) -- | Move the cursor down one item -moveDown :: FileTree -> EventM String FileTree +moveDown :: FileTree a -> EventM String (FileTree a) moveDown = pressKey V.KDown -- | Move the cursor up one item -moveUp :: FileTree -> EventM String FileTree +moveUp :: FileTree a -> EventM String (FileTree a) moveUp = pressKey V.KUp -- | Move the cursor down a page -pageDown :: FileTree -> EventM String FileTree +pageDown :: FileTree a -> EventM String (FileTree a) pageDown = pressKey V.KPageDown -- | Move the cursor up a page -pageUp :: FileTree -> EventM String FileTree +pageUp :: FileTree a -> EventM String (FileTree a) pageUp = pressKey V.KPageDown -- | Move the cursor the the top of the file list -moveToTop :: FileTree -> EventM String FileTree +moveToTop :: FileTree a -> EventM String (FileTree a) moveToTop = pressKey V.KHome -- | Move the cursor the the bottom of the file list -moveToBottom :: FileTree -> EventM String FileTree +moveToBottom :: FileTree a -> EventM String (FileTree a) moveToBottom = pressKey V.KEnd -- | Move the cursor up a directory in the file tree -ascendDir :: FileTree -> EventM String FileTree -ascendDir (FZ { parents = Seq.Empty, context = tree@((extract -> path -> p)), selection, ..}) +ascendDir :: FileTree a -> EventM String (FileTree a) +ascendDir (FT { parents = Seq.Empty, context = tree@((extract -> path -> p)), selection, valLoader, ..}) = do - fz <- liftIO $ buildParent p tree + fz <- liftIO $ buildParent p valLoader tree return $ fz { selection = selection } -ascendDir (FZ { parents = (ps Seq.:|> (f :< pList)), context, ..}) = do +ascendDir (FT { parents = (ps Seq.:|> (f :< pList)), context, ..}) = do invalidateCacheEntry (cacheKey f) return - $ FZ {parents = ps, context = (f :< listModify (const context) pList), ..} + $ FT {parents = ps, context = (f :< listModify (const context) pList), ..} -- | If the cursor is on a directory then descend the cursor into that dir -- If the cursor is on a file nothing happens -descendDir :: FileTree -> EventM String FileTree -descendDir fz@(FZ { parents, context = (f :< children), ..}) = do +descendDir :: FileTree a -> EventM String (FileTree a) +descendDir fz@(FT { parents, context = (f :< children), ..}) = do invalidateCacheEntry (cacheKey f) return $ case listSelectedElement children of Nothing -> fz - Just (_, nextChildren@(FC { kind = Dir } :< _)) -> FZ + Just (_, nextChildren@(FC { kind = Dir } :< _)) -> FT { parents = (parents Seq.|> (f :< children)) , context = nextChildren , .. @@ -95,37 +95,37 @@ Just _ -> fz -- | Get the absolute path of the object (dir or file) under the cursor -getCurrentFilePath :: FileTree -> Maybe FilePath -getCurrentFilePath (FZ { context = unwrap -> children }) = +getCurrentFilePath :: FileTree a -> Maybe FilePath +getCurrentFilePath (FT { context = unwrap -> children }) = case listSelectedElement children of Nothing -> Nothing Just (_, FC { kind = Error } :< _) -> Nothing Just (_, fc :< _ ) -> Just (path fc) -- | Get the absolute path of the directory where the cursor currently is. -getCurrentDir :: FileTree -> FilePath -getCurrentDir (FZ { context = extract -> path -> p }) = p +getCurrentDir :: FileTree a -> FilePath +getCurrentDir (FT { context = extract -> path -> p }) = p -- | Flag or unflag the current file or dir -toggleFlagged :: FileTree -> EventM String FileTree -toggleFlagged fz@(FZ { context = (fc :< lst), selection, ..}) = do +toggleFlagged :: FileTree a -> EventM String (FileTree a) +toggleFlagged fz@(FT { context = (fc :< lst), selection, ..}) = do invalidateCacheEntry selectionCacheKey return . fromMaybe fz $ do - ((selectedContext@FC { selected = isSelected, path }) :< rest) <- snd + ((selectedContext@FC { flagged = isSelected, path }) :< rest) <- snd <$> listSelectedElement lst let newSelection = if isSelected then S.delete path selection else S.insert path selection let newList = listModify - (const (selectedContext { selected = not isSelected } :< rest)) + (const (selectedContext { flagged = not isSelected } :< rest)) lst - return $ FZ {context = (fc :< newList), selection = newSelection, ..} + return $ FT {context = (fc :< newList), selection = newSelection, ..} -- | Get all flagged file paths. All paths are absolute -getFlagged :: FileTree -> [FilePath] +getFlagged :: FileTree a -> [FilePath] getFlagged = toList . selection -- | Hide/Show a list of all flagged files -toggleFlaggedVisible :: FileTree -> FileTree -toggleFlaggedVisible fz@(FZ { config }) = +toggleFlaggedVisible :: FileTree a -> FileTree a +toggleFlaggedVisible fz@(FT { config }) = fz { config = config { showSelection = not $ showSelection config } } diff --git a/src/Brick/Widgets/FileTree/Internal/Render.hs b/src/Brick/Widgets/FileTree/Internal/Render.hs --- a/src/Brick/Widgets/FileTree/Internal/Render.hs +++ b/src/Brick/Widgets/FileTree/Internal/Render.hs @@ -10,8 +10,9 @@ , cacheKey , renderHeader , renderFileTree + , renderFileTreeCustom , selectionCacheKey - , renderSelection + , renderFileContext ) where @@ -28,6 +29,10 @@ import Data.Bool import qualified Data.Sequence as S +-- | Custom rendering function for a file +-- Note that the resulting widget must be exactly 1 row high. +type CustomFCRender a = FileContext a -> Widget String + -- | Flagged items are rendered with this attr flaggedItemAttr :: AttrName flaggedItemAttr = "flaggedItemAttr" @@ -44,33 +49,43 @@ errorAttr :: AttrName errorAttr = "errorAttr" -cacheKey :: FileContext -> String +cacheKey :: FileContext a -> String cacheKey = path -renderHeader :: SubTree -> Widget String -renderHeader ((path -> p) :< _) = withAttr titleAttr (str p) <=> hBorder +renderHeader :: SubTree a -> Widget String +renderHeader ((path -> p) :< _) = + withAttr titleAttr (str $ p <> "/") <=> hBorder -renderFileTree :: FileTree -> Widget String -renderFileTree fz@(FZ { parents, context, config }) = +renderFileTreeCustom :: CustomFCRender a -> FileTree a -> Widget String +renderFileTreeCustom customFCRender fz@(FT { parents, context, config }) = ( renderHeader context - <=> (renderParents parents <+> renderNode context <+> previewW) + <=> ( renderParents customFCRender parents + <+> renderNode customFCRender True context + <+> previewW + ) <=> selectionW ) where selectionW = if showSelection config then renderSelection fz else emptyWidget - previewW = if previewDir config then renderPreview context else emptyWidget + previewW = if previewDir config + then renderPreview customFCRender context + else emptyWidget -renderPreview :: SubTree -> Widget String -renderPreview (_ :< lst) = do +renderFileTree :: FileTree a -> Widget String +renderFileTree = renderFileTreeCustom renderFileContext + +renderPreview :: CustomFCRender a -> SubTree a -> Widget String +renderPreview customFCRender (_ :< lst) = do case listSelectedElement lst of - Just (_, node@(FC { kind = Dir } :< _)) -> vBorder <+> renderNode node + Just (_, node@(FC { kind = Dir } :< _)) -> + vBorder <+> renderNode customFCRender False node _ -> emptyWidget selectionCacheKey :: String selectionCacheKey = "delve!selection" -renderSelection :: FileTree -> Widget String -renderSelection (FZ { selection }) +renderSelection :: FileTree a -> Widget String +renderSelection (FT { selection }) | null selection = emptyWidget | otherwise @@ -80,34 +95,35 @@ . fmap (withAttr flaggedItemAttr . str) . toList $ selection - in hBorder <=> withAttr titleAttr (str "Selected") <=> selectionsW + in hBorder <=> withAttr titleAttr (str "flagged") <=> selectionsW -renderParents :: S.Seq SubTree -> Widget String -renderParents S.Empty = emptyWidget -renderParents parents@(_ S.:|> (p :< _)) = cached +renderParents :: CustomFCRender a -> S.Seq (SubTree a) -> Widget String +renderParents _ S.Empty = emptyWidget +renderParents customFCRender parents@(_ S.:|> (p :< _)) = cached (cacheKey p) - (hBox . toList $ (renderParent <$> S.drop ind parents)) + (hBox . toList $ (renderParent customFCRender <$> S.drop ind parents)) where len = S.length parents ind = max 0 (len - 2) -renderNode :: SubTree -> Widget String -renderNode (_ :< ls) = renderList - (\b -> bool id (forceAttr listSelectedAttr) b . renderFileContext . extract) - True +renderNode :: CustomFCRender a -> Bool -> SubTree a -> Widget String +renderNode customFCRender focused (_ :< ls) = renderList + (\b -> bool id (forceAttr listSelectedAttr) b . customFCRender . extract) + focused ls -renderParent :: SubTree -> Widget String -renderParent = (<+> vBorder) . hLimit 20 . renderNode +renderParent :: CustomFCRender a -> SubTree a -> Widget String +renderParent customFCRender = + (<+> vBorder) . hLimit 20 . renderNode customFCRender False -renderFileContext :: FileContext -> Widget String -renderFileContext (FC { kind = File, name, selected }) = +renderFileContext :: FileContext a -> Widget String +renderFileContext (FC { kind = File, name, flagged }) = let (attr', modStr) = - if selected then (flaggedItemAttr, "* ") else (fileAttr, "") + if flagged then (flaggedItemAttr, "* ") else (fileAttr, "") in withAttr attr' . str $ modStr <> name renderFileContext (FC { kind = Error, name, path }) = withAttr errorAttr . str $ "! " <> path <> ": " <> name -renderFileContext (FC { kind = Dir, name, selected }) = +renderFileContext (FC { kind = Dir, name, flagged }) = let (attr', modStr) = - if selected then (flaggedItemAttr, "* ") else (dirAttr, "") - in withAttr attr' . str $ modStr <> name <> "/" + if flagged then (flaggedItemAttr, "* ") else (dirAttr, "") + in withAttr attr' . str $ modStr <> name diff --git a/src/Brick/Widgets/FileTree/Internal/Types.hs b/src/Brick/Widgets/FileTree/Internal/Types.hs --- a/src/Brick/Widgets/FileTree/Internal/Types.hs +++ b/src/Brick/Widgets/FileTree/Internal/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Brick.Widgets.FileTree.Internal.Types ( FileKind(..) , FileContext(..) @@ -22,15 +23,21 @@ import System.FilePath.Posix import System.Directory import qualified Data.Set as S +import Data.List +import System.IO.Unsafe data FileKind = Dir | File | Error + deriving (Eq, Ord, Show) -data FileContext = +type ValueLoader a = FileKind -> FilePath -> IO a + +data FileContext a = FC - { selected :: Bool + { flagged :: Bool , path :: FilePath , name :: String , kind :: FileKind + , val :: a } data Config = @@ -42,64 +49,85 @@ defaultConfig :: Config defaultConfig = Config {showSelection = True, previewDir = False} -type SubTree = Cofree (GenericList String V.Vector) FileContext +type SubTree a = Cofree (GenericList String V.Vector) (FileContext a) -- | Represents all the state required to interact with or display a filetree -data FileTree = FZ - { parents :: S.Seq SubTree +data FileTree a = FT + { parents :: S.Seq (SubTree a) , selection :: S.Set FilePath - , context :: SubTree + , context :: SubTree a , config :: Config + , valLoader :: ValueLoader a } -buildParent :: FilePath -> SubTree -> IO FileTree -buildParent p child = do - FZ { context = (c :< ls), ..} <- newFileTree (takeDirectory p) +buildParent :: FilePath -> ValueLoader a -> SubTree a -> IO (FileTree a) +buildParent p valLoader' child = do + FT { context = (c :< ls), ..} <- newFileTree valLoader' (takeDirectory p) let newChildren = fmap (replace p child) ls - return $ FZ {context = c :< newChildren, ..} + return $ FT {context = c :< newChildren, ..} where replace pth fc@((path -> pth') :< _) new | pth == pth' = new | otherwise = fc -- | Create a new 'FileTree' situated at the given 'FilePath' -newFileTree :: FilePath -> IO FileTree -newFileTree currentDir = do +-- +-- The given 'ValueLoader' will be used to load additional context for each +-- filepath (dirs AND files). It will be called lazily using 'unsafeInterleaveIO' +-- when the value itself is accessed (if ever). +newFileTree :: ValueLoader a -> FilePath -> IO (FileTree a) +newFileTree valLoader' currentDir = do absRoot <- makeAbsolute (normalise currentDir) - (_ FT.:/ tree) <- FT.buildL absRoot - return $ convert (takeDirectory absRoot) tree + (_ FT.:/ tree) <- FT.readDirectoryWithL (interleavedValLoader File) absRoot + convert interleavedValLoader (takeDirectory absRoot) tree + where interleavedValLoader fk fp = unsafeInterleaveIO $ valLoader' fk fp -convert :: FilePath -> FT.DirTree FilePath -> FileTree -convert root tree = - let subTree = go (normalise root) $ tree - in FZ - { parents = [] - , selection = mempty - , config = defaultConfig - , context = subTree - } +convert + :: forall a . ValueLoader a -> FilePath -> FT.DirTree a -> IO (FileTree a) +convert valLoader' root tree = do + subTree <- go (normalise root) tree + pure $ FT + { parents = [] + , selection = mempty + , config = defaultConfig + , context = subTree + , valLoader = valLoader' + } where - go :: FilePath -> FT.DirTree FilePath -> SubTree - go root' (FT.Failed { FT.name, FT.err }) = - FC - { name = show err - , path = normalise (root' name) - , selected = False - , kind = Error - } + go :: FilePath -> FT.DirTree a -> IO (SubTree a) + go root' (FT.Failed { FT.name, FT.err }) = do + val <- valLoader' Error name + pure + $ FC + { name = show err + , path = normalise (root' name) + , flagged = False + , kind = Error + , val = val + } :< list name mempty 1 - go root' (FT.File { FT.name }) = - FC - { name = name - , path = normalise (root' name) - , selected = False - , kind = File - } + go root' (FT.File { FT.name, FT.file }) = + pure + $ FC + { name = name + , path = normalise (root' name) + , flagged = False + , kind = File + , val = file + } :< list name mempty 1 - go root' (FT.Dir path contents) = - FC - { name = path - , path = normalise (root' path) - , kind = Dir - , selected = False - } - :< list path (V.fromList . fmap (go (root' path)) $ contents) 1 + go root' (FT.Dir path contents) = do + let absPath = normalise (root' path) + val <- valLoader' Dir absPath + children <- traverse (go absPath) contents + pure + $ FC + { name = path <> "/" + , path = absPath + , kind = Dir + , flagged = False + , val = val + } + :< list path (V.fromList . sortOn byFileType $ children) 1 + +byFileType :: SubTree a -> (FileKind, String) +byFileType (FC { kind, name } :< _) = (kind, name)