brick-filetree (empty) → 0.1.0.0

raw patch · 11 files changed

+469/−0 lines, 11 filesdep +basedep +brickdep +brick-filetreesetup-changed

Dependencies added: base, brick, brick-filetree, comonad, containers, directory, directory-tree, filepath, free, vector, vty

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• brick-filetree.cabal +72/−0
• src/Brick/Widgets/FileTree.hs +29/−0
• src/Brick/Widgets/FileTree/Internal/Actions.hs +117/−0
• src/Brick/Widgets/FileTree/Internal/Render.hs +104/−0
• src/Brick/Widgets/FileTree/Internal/Types.hs +103/−0
• src/Lib.hs +6/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for brick-filetree++## Unreleased changes

@@ -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.

@@ -0,0 +1,1 @@+# brick-filetree

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <https://github.com/ChrisPenner/brick-filetree#readme>+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

@@ -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

@@ -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 } }

@@ -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 <> "/"

@@ -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

@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"