diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for brick-filetree + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Penner (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Penner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# brick-filetree diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brick-filetree.cabal b/brick-filetree.cabal new file mode 100644 --- /dev/null +++ b/brick-filetree.cabal @@ -0,0 +1,72 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 3c8791fcfeb7862a7b511beda8cdf4e80ecdfeb8abcfb818c4f44436894c0b96 + +name: brick-filetree +version: 0.1.0.0 +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 +author: Chris Penner +maintainer: christopher.penner@gmail.com +copyright: Chris Penner +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/ChrisPenner/brick-filetree + +library + exposed-modules: + Brick.Widgets.FileTree + Brick.Widgets.FileTree.Internal.Actions + Brick.Widgets.FileTree.Internal.Render + Brick.Widgets.FileTree.Internal.Types + Lib + other-modules: + Paths_brick_filetree + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , brick + , comonad + , containers + , directory + , directory-tree + , filepath + , free + , vector + , vty + default-language: Haskell2010 + +test-suite brick-filetree-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_brick_filetree + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , brick + , brick-filetree + , comonad + , containers + , directory + , directory-tree + , filepath + , free + , vector + , vty + default-language: Haskell2010 diff --git a/src/Brick/Widgets/FileTree.hs b/src/Brick/Widgets/FileTree.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/FileTree.hs @@ -0,0 +1,29 @@ +module Brick.Widgets.FileTree + ( FileTree + , newFileTree + , toggleSelection + , moveUp + , moveDown + , pageDown + , pageUp + , moveToTop + , moveToBottom + , ascendDir + , descendDir + , getCurrentFilePath + , getCurrentDir + , getFlagged + , toggleSelectionVisible + , renderFileTree + , renderSelection + , selectedItemAttr + , titleAttr + , dirAttr + , fileAttr + , errorAttr + ) +where + +import Brick.Widgets.FileTree.Internal.Types +import Brick.Widgets.FileTree.Internal.Actions +import Brick.Widgets.FileTree.Internal.Render diff --git a/src/Brick/Widgets/FileTree/Internal/Actions.hs b/src/Brick/Widgets/FileTree/Internal/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/FileTree/Internal/Actions.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +module Brick.Widgets.FileTree.Internal.Actions + ( moveUp + , moveDown + , pageUp + , pageDown + , moveToTop + , moveToBottom + , ascendDir + , descendDir + , getCurrentFilePath + , getCurrentDir + , toggleSelection + , getFlagged + , toggleSelectionVisible + ) where + +import qualified Graphics.Vty.Input as V +import Brick.Main +import Brick.Types +import Brick.Widgets.List +import Data.Foldable +import Control.Comonad.Cofree as CF +import qualified Data.Sequence as Seq +import qualified Data.Set as S +import Brick.Widgets.FileTree.Internal.Types +import Brick.Widgets.FileTree.Internal.Render +import Control.Monad.IO.Class +import Control.Comonad +import Data.Maybe + +overCurrentList + :: (List String SubTree -> EventM String (List String SubTree)) + -> FileTree + -> EventM String FileTree +overCurrentList f fz@(FZ { context = x :< lst }) = do + newLst <- f lst + return fz { context = x :< newLst } + +pressKey :: V.Key -> (FileTree -> EventM String FileTree) +pressKey k = overCurrentList (handleListEvent (V.EvKey k [])) + +moveDown :: FileTree -> EventM String FileTree +moveDown = pressKey V.KDown + +moveUp :: FileTree -> EventM String FileTree +moveUp = pressKey V.KUp + +pageDown :: FileTree -> EventM String FileTree +pageDown = pressKey V.KPageDown + +pageUp :: FileTree -> EventM String FileTree +pageUp = pressKey V.KPageDown + +moveToTop :: FileTree -> EventM String FileTree +moveToTop = pressKey V.KHome + +moveToBottom :: FileTree -> EventM String FileTree +moveToBottom = pressKey V.KEnd + +ascendDir :: FileTree -> EventM String FileTree +ascendDir (FZ { parents = Seq.Empty, context = tree@((extract -> path -> p)), selection, ..}) + = do + fz <- liftIO $ buildParent p tree + return $ fz { selection = selection } +ascendDir (FZ { parents = (ps Seq.:|> (f :< pList)), context, ..}) = do + invalidateCacheEntry (cacheKey f) + return + $ FZ {parents = ps, context = (f :< listModify (const context) pList), ..} + +descendDir :: FileTree -> EventM String FileTree +descendDir fz@(FZ { parents, context = (f :< children), ..}) = do + invalidateCacheEntry (cacheKey f) + return $ case listSelectedElement children of + Nothing -> fz + Just (_, nextChildren@(FC { kind = Dir } :< _)) -> FZ + { parents = (parents Seq.|> (f :< children)) + , context = nextChildren + , .. + } + Just _ -> fz + +getCurrentFilePath :: FileTree -> Maybe FilePath +getCurrentFilePath (FZ { context = unwrap -> children }) = + case listSelectedElement children of + Nothing -> Nothing + Just (_, FC { kind = Error } :< _) -> Nothing + Just (_, fc :< _ ) -> Just (path fc) + +getCurrentDir :: FileTree -> FilePath +getCurrentDir (FZ { context = extract -> path -> p }) = p + +toggleSelection :: FileTree -> EventM String FileTree +toggleSelection fz@(FZ { context = (fc :< lst), selection, ..}) = do + invalidateCacheEntry selectionCacheKey + return . fromMaybe fz $ do + ((selectedContext@FC { selected = 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)) + lst + return $ FZ {context = (fc :< newList), selection = newSelection, ..} + +getFlagged :: FileTree -> [FilePath] +getFlagged = toList . selection + +toggleSelectionVisible :: FileTree -> FileTree +toggleSelectionVisible fz@(FZ { 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 new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/FileTree/Internal/Render.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Brick.Widgets.FileTree.Internal.Render + ( selectedItemAttr + , titleAttr + , dirAttr + , fileAttr + , errorAttr + , cacheKey + , renderHeader + , renderFileTree + , selectionCacheKey + , renderSelection + ) +where + +import Brick.Widgets.FileTree.Internal.Types + +import Data.Foldable +import Brick.Widgets.Core +import Brick.Widgets.Border +import Brick.Types +import Brick.AttrMap +import Brick.Widgets.List +import Control.Comonad.Cofree as CF +import Control.Comonad +import Data.Bool +import qualified Data.Sequence as S + +selectedItemAttr, titleAttr, dirAttr, fileAttr, errorAttr :: AttrName +selectedItemAttr = "selectedItemAttr" +titleAttr = "titleAttr" +dirAttr = "dirAttr" +fileAttr = "fileAttr" +errorAttr = "errorAttr" + +cacheKey :: FileContext -> String +cacheKey = path + +renderHeader :: SubTree -> Widget String +renderHeader ((path -> p) :< _) = withAttr titleAttr (str p) <=> hBorder + +renderFileTree :: FileTree -> Widget String +renderFileTree fz@(FZ { parents, context, config }) = + ( renderHeader context + <=> (renderParents parents <+> renderNode context <+> previewW) + <=> selectionW + ) + where + selectionW = if showSelection config then renderSelection fz else emptyWidget + previewW = if previewDir config then renderPreview context else emptyWidget + +renderPreview :: SubTree -> Widget String +renderPreview (_ :< lst) = do + case listSelectedElement lst of + Just (_, node@(FC { kind = Dir } :< _)) -> vBorder <+> renderNode node + _ -> emptyWidget + +selectionCacheKey :: String +selectionCacheKey = "delve!selection" + +renderSelection :: FileTree -> Widget String +renderSelection (FZ { selection }) + | null selection + = emptyWidget + | otherwise + = let selectionsW = + cached selectionCacheKey + . vBox + . fmap (withAttr selectedItemAttr . str) + . toList + $ selection + in hBorder <=> withAttr titleAttr (str "Selected") <=> selectionsW + +renderParents :: S.Seq SubTree -> Widget String +renderParents S.Empty = emptyWidget +renderParents parents@(_ S.:|> (p :< _)) = cached + (cacheKey p) + (hBox . toList $ (renderParent <$> 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 + ls + +renderParent :: SubTree -> Widget String +renderParent = (<+> vBorder) . hLimit 20 . renderNode + +renderFileContext :: FileContext -> Widget String +renderFileContext (FC { kind = File, name, selected }) = + let (attr', modStr) = + if selected then (selectedItemAttr, "* ") 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 }) = + let (attr', modStr) = + if selected then (selectedItemAttr, "* ") 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 new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/FileTree/Internal/Types.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +module Brick.Widgets.FileTree.Internal.Types + ( FileKind(..) + , FileContext(..) + , Config(..) + , FileTree(..) + , SubTree + , buildParent + , newFileTree + , defaultConfig + ) +where + +import Brick.Widgets.List +import qualified Data.Vector as V +import Control.Comonad.Cofree as CF +import qualified System.Directory.Tree as FT +import qualified Data.Sequence as S +import System.FilePath.Posix +import System.Directory +import qualified Data.Set as S + +data FileKind = Dir | File | Error + +data FileContext = + FC + { selected :: Bool + , path :: FilePath + , name :: String + , kind :: FileKind + } + +data Config = + Config + { showSelection :: Bool + , previewDir :: Bool + } + +defaultConfig :: Config +defaultConfig = Config {showSelection = True, previewDir = False} + +type SubTree = Cofree (GenericList String V.Vector) FileContext + +data FileTree = FZ + { parents :: S.Seq SubTree + , selection :: S.Set FilePath + , context :: SubTree + , config :: Config + } + +buildParent :: FilePath -> SubTree -> IO FileTree +buildParent p child = do + FZ { context = (c :< ls), ..} <- newFileTree (takeDirectory p) + let newChildren = fmap (replace p child) ls + return $ FZ {context = c :< newChildren, ..} + where + replace pth fc@((path -> pth') :< _) new | pth == pth' = new + | otherwise = fc + +newFileTree :: FilePath -> IO FileTree +newFileTree currentDir = do + absRoot <- makeAbsolute (normalise currentDir) + (_ FT.:/ tree) <- FT.buildL absRoot + return $ convert (takeDirectory absRoot) tree + +convert :: FilePath -> FT.DirTree FilePath -> FileTree +convert root tree = + let subTree = go (normalise root) $ tree + in FZ + { parents = [] + , selection = mempty + , config = defaultConfig + , context = subTree + } + 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 + } + :< list name mempty 1 + go root' (FT.File { FT.name }) = + FC + { name = name + , path = normalise (root' name) + , selected = False + , kind = 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 diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"