lens-filesystem (empty) → 0.0.0.0

raw patch · 8 files changed

+481/−0 lines, 8 filesdep +basedep +directorydep +filepathsetup-changed

Dependencies added: base, directory, filepath, hspec, lens, lens-action, lens-filesystem

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +45/−0
Setup.hs +2/−0
lens-filesystem.cabal +61/−0
src/Control/Lens/FileSystem.hs +197/−0
src/Control/Lens/FileSystem/Internal/Combinators.hs +39/−0
test/Spec.hs +104/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for lens-fs++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (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 Author name here 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.

+ README.md view

@@ -0,0 +1,45 @@+# lens-filesystem++[HACKAGE](https://hackage.haskell.org/package/lens-filesystem)++A lensy style interface to your filesystem.++This is pretty experimental; I wouldn't recommend using it in production code at the moment;+Using the read-only operations should be fine, but I'd strongly recommend doing lots of testing+with `print` before you run destructive filesystem operations.++This library is meant to be used in conjunction with the `lens-action` library.++The interface to this package could change at any time.++Examples:++```haskell+Many of the combinators you see here come from `lens-action`.++-- Find all files in ~ or ~/config with a .vim or .conf extension+>>> "/Users/chris" ^!! including (path "config") . ls . traversed . exts ["vim", "conf"]+["/Users/chris/.vim","/Users/chris/tmux.conf","/Users/chris/config/plugins.vim"]++-- Check whether a filename is a dotfile+>>> let isDotfile = has (filename . _head . only '.')+-- Crawl a filetree according to a given fold, +-- e.g. crawl all dirs that aren't dotfiles (a.k.a. .git, .stack-work)+>>> "." ^!! crawling (ls'ed . dirs . filtered (not . isDotfile))+[ "." , "./app" , "./test" , "./src" , "./src/Control"+, "./src/Control/Lens", "./src/Control/Lens/FileSystem"]++-- Crawl ALL files in "src" collecting "*.hs" files, then make file paths absolute+>>> "src" ^!! crawled . exts ["hs"] . absolute+[ "/Users/chris/dev/lens-fs/src/Control/Lens/FileSystem/Combinators.hs"+, "/Users/chris/dev/lens-fs/src/Control/Lens/FileSystem.hs" ]++-- Find all executables in the 'scripts' directory and copy them to bin+>>> "scripts" ^! crawled . withPerms [executable] . act (`copyFile` "/Users/chris/bin")++-- Read all markdown files and get their contents with filename+>>> "./test" ^!! crawled . exts ["md"] . contents . withIndex+[("./test/data/flat/file.md","markdown\n")]+```++See more examples in the [tests](./test/Spec.hs)

+ Setup.hs view

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

+ lens-filesystem.cabal view

@@ -0,0 +1,61 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9ca81ad924a9ad21b7413d6c5eabf70ce7b386acbbb1e630c907cd5e58d9531e++name:           lens-filesystem+version:        0.0.0.0+description:    Please see the README on GitHub at <https://github.com/ChrisPenner/lens-fs#readme>+homepage:       https://github.com/ChrisPenner/lens-filesystem#readme+bug-reports:    https://github.com/ChrisPenner/lens-filesystem/issues+author:         Chris Penner+maintainer:     example@example.com+copyright:      2019 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/lens-filesystem++library+  exposed-modules:+      Control.Lens.FileSystem+      Control.Lens.FileSystem.Internal.Combinators+  other-modules:+      Paths_lens_filesystem+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , directory+    , filepath+    , lens+    , lens-action+  default-language: Haskell2010++test-suite lens-filesystem-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_lens_filesystem+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , directory+    , filepath+    , hspec+    , lens+    , lens-action+    , lens-filesystem+  default-language: Haskell2010

+ src/Control/Lens/FileSystem.hs view

@@ -0,0 +1,197 @@+{-|+Module      : Control.Lens.FileSystem+Description : Lensy File system combinators+Copyright   : (c) Chris Penner, 2019+License     : BSD3++Note that this package is experimental, test things carefully before performing destructive+operations. I'm not responsible if things go wrong.++This package is meant to be used alongside combinators from 'lens-action'; for example+'^!', '^!!' and 'act'.+-}+++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+module Control.Lens.FileSystem+    (+    -- * File System Helpers+      ls+    , ls'ed+    , path+    , pathL+    , branching+    , dirs+    , files+    , contents+    , exts+    , crawled+    , crawling+    , absolute+    , withPerms+    , symLinksFollowed++    -- * Combinators+    , filteredM+    , merging+    , including++    -- ** Exception Handling+    , recovering+    , tryOrContinue+    , tryCatch++    -- * Re-exports+    , (</>)++    , readable+    , writable+    , executable+    , module System.FilePath.Lens+    ) where++import Control.Lens+import Control.Lens.Action+import Control.Lens.FileSystem.Internal.Combinators+import System.Directory+import System.FilePath.Posix+import System.FilePath.Lens++-- | List the files at a given directory+-- If the focused path isn't a directory this fold will return 0 results+--+-- >>> "./test/data" ^! ls+-- ["./test/data/flat","./test/data/symlinked","./test/data/.dotfile","./test/data/permissions","./test/data/nested"]+ls :: Monoid r => Acting IO r FilePath [FilePath]+ls = recovering $ act (\fp -> (fmap (fp </>)) <$> listDirectory fp)++-- | Fold over all files in the given directory.+-- If the focused path isn't a directory this fold will return 0 results+-- This is an alias for @@ls . traversed@@+--+-- >>> "./test/data" ^!! ls'ed+-- ["./test/data/flat","./test/data/symlinked","./test/data/.dotfile","./test/data/permissions","./test/data/nested"]+ls'ed :: Monoid r => Acting IO r FilePath FilePath+ls'ed = ls . traversed+++-- | Append a path the end of the current path.+-- This uses `</>` for cross platform compatibility so+-- you don't need leading/trailing slashes here+--+-- >>> "./src" ^! path "Control"+-- "./src/Control"+path :: FilePath -> Getter FilePath FilePath+path filePath = to (</> filePath)++-- | Create a filepath from a list of path segments, then append it to the focused path.+--+-- >>> "." ^! pathL ["a", "b", "c"]+-- "./a/b/c"+pathL :: [FilePath] -> Getter FilePath FilePath+pathL filePaths = to (</> joinPath filePaths)++-- | "Branch" a fold into many sub-paths.+-- E.g. if we want to crawl into BOTH of @src@ and @test@ directories we can do:+--+-- >>> "." ^!! branching ["src", "test"] . ls+-- [["./src/Control"],["./test/Spec.hs","./test/data"]]+branching :: [FilePath] -> Fold FilePath FilePath+branching filePaths = folding (\fp -> (fp </>) <$> filePaths)++-- | Filter for only paths which point to a valid directory+--+-- >>> "./test" ^!! ls'ed+-- ["./test/Spec.hs","./test/data"]+--+-- >>> "./test" ^!! ls'ed . dirs+-- ["./test/data"]+dirs :: (Monoid r) => Acting IO r FilePath FilePath+dirs = filteredM doesDirectoryExist++-- | Filter for only paths which point to a valid file+--+-- >>> "./test" ^!! ls'ed+-- ["./test/Spec.hs","./test/data"]+--+-- >>> "./test" ^!! ls'ed . files+-- ["./test/Spec.hs"]+files :: (Monoid r) => Acting IO r FilePath FilePath+files = filteredM doesFileExist++-- | Get the contents of a file+-- This fold will return 0 results if the path does not exist, if it isn't a file, or if+-- reading the file causes any exceptions.+--+-- This fold lifts the path of the current file into the index of the fold in case you need it+-- downstream.+--+-- >>> "./test/data/flat/file.md" ^! contents+-- "markdown\n"+--+-- >>> "./test/data/flat/file.md" ^! contents . withIndex+-- ("./test/data/flat/file.md","markdown\n")+contents :: (Indexable FilePath p, Effective IO r f, Monoid r) => Over' p f FilePath String+contents = recovering (iact go)+  where+    go fp = do+        contents' <- readFile fp+        return (fp, contents')++-- | Filter the fold for only files which have ANY of the given file extensions.+-- E.g. to find all Haskell or Markdown files in the current directory:+--+-- >>> "./test/" ^!! crawled . exts ["hs", "md"]+-- ["./test/Spec.hs","./test/data/flat/file.md","./test/data/symlinked/file.md"]+exts :: [String] -> Traversal' FilePath FilePath+exts extList = filtered check+  where+    check fp = drop 1 (takeExtension fp) `elem` extList++-- | Crawl over every file AND directory in the given path.+--+-- >>> "./test/data/nested/top" ^!! crawled+-- ["./test/data/nested/top","./test/data/nested/top/mid","./test/data/nested/top/mid/bottom","./test/data/nested/top/mid/bottom/floor.txt"]+crawled :: Monoid r => Acting IO r FilePath FilePath+crawled = including (dirs . ls . traversed . crawled)++-- | Continually run the given fold until all branches hit dead ends,+-- yielding over all elements encountered the way.+--+-- >>> "./test/data" ^!! crawling (ls'ed . filtered ((== "flat") . view filename))+-- ["./test/data","./test/data/flat"]+crawling :: Monoid r => Acting IO r FilePath FilePath -> Acting IO r FilePath FilePath+crawling fld = including (recovering (fld . crawling fld))++-- | Make filepaths absolute in reference to the current working directory+--+-- > >>> "./test/data" ^! absolute+-- > "/Users/chris/dev/lens-filesystem/test/data"+absolute :: MonadicFold IO FilePath FilePath+absolute = act makeAbsolute++-- | Filter for only paths which have ALL of the given file-permissions+-- See 'readable', 'writable', 'executable'+--+-- >>> "./test/data" ^!! crawled . withPerms [readable, executable]+-- ["./test/data/permissions/exe"]+withPerms :: Monoid r => [Permissions -> Bool] -> Acting IO r FilePath FilePath+withPerms permChecks = filteredM checkAll+  where+    checkAll fp = do+        perms <- getPermissions fp+        return $ all ($ perms) permChecks++-- | If the path is a symlink, rewrite the path to its destination and keep folding+-- If it's not a symlink; pass the path onwards as is.+--+-- >>> "./test/data/symlinked" ^! symLinksFollowed+-- "flat"+symLinksFollowed :: Monoid r => Acting IO r FilePath FilePath+symLinksFollowed = tryOrContinue (act getSymbolicLinkTarget)

+ src/Control/Lens/FileSystem/Internal/Combinators.hs view

@@ -0,0 +1,39 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+module Control.Lens.FileSystem.Internal.Combinators where++import Control.Lens+import Control.Lens.Action+import Control.Lens.Action.Internal+import Control.Applicative++-- | If a given fold fails (e.g. with an exception), recover and simply return 0 elements+-- rather than crashing.+recovering :: (Monad m, Alternative m, Monoid r, Effective m r f) => Over' p f s a -> Over' p f s a+recovering fld f s = effective (ineffective (fld f s) <|> pure mempty)++-- | Try the given fold, if it throws an exception then return the input as the output instead+tryOrContinue :: (Monad m, Alternative m) => Acting m r a a -> Acting m r a a+tryOrContinue = flip tryCatch pure++-- | Try the given fold, if it throws an exception then use the given handler to compute a+-- replacement value and continue with that.+tryCatch :: (Monad m, Alternative m) => Acting m r s b -> (s -> m b) -> Acting m r s b+tryCatch fld handler f a = effective (ineffective (fld f a) <|> (handler a >>= ineffective . f))++-- | Filter a fold using a monadic action+filteredM :: (Monad m, Monoid r) => (a -> m Bool) -> Acting m r a a+filteredM predicate f a = effective go+  where+    go = do+      predicate a >>= \case+        True -> ineffective (f a)+        False -> pure mempty++-- | Merge two folds+merging :: (Applicative f, Contravariant f) => LensLike' f s a -> LensLike' f s a -> LensLike' f s a+merging fold1 fold2 nextFold s = fold1 nextFold s *> fold2 nextFold s++-- | Include the results of an additional fold alongside the original values+including :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a+including = merging id

+ test/Spec.hs view

@@ -0,0 +1,104 @@+{-# LANGUAGE LambdaCase #-}+import Control.Lens+import Control.Lens.Action+import Control.Lens.FileSystem+import System.Directory+import Test.Hspec++baseDir :: FilePath+baseDir = "test" </> "data"++main :: IO ()+main = do+    absRoot <- makeAbsolute baseDir+    setCurrentDirectory baseDir+    hspec $ do+      describe "ls" $ do+        it "should return files and dirs with full path" $ do+          "flat" ^! ls `shouldReturn` ["flat/file.txt","flat/file.md","flat/dir"]+        it "should allow traversing deeper" $ do+          "flat" ^!! ls . traversed `shouldReturn` ["flat/file.txt","flat/file.md","flat/dir"]+      describe "ls'ed" $ do+        it "should behave like 'ls' but with traversal" $ do+          "flat" ^!! ls'ed `shouldReturn` ["flat/file.txt","flat/file.md","flat/dir"]+      describe "path" $ do+        it "should add to path" $ do+          "nested" ^! path "top" `shouldReturn` "nested/top"+        it "should add deep paths to path" $ do+          "nested" ^! path ("top" </> "mid" </> "bottom") `shouldReturn` "nested/top/mid/bottom"+      describe "pathL" $ do+        it "should add to path" $ do+          "nested" ^! pathL ["top"] `shouldReturn` "nested/top"+        it "should add deep pathL to path" $ do+          "nested" ^! pathL ["top", "mid", "bottom"] `shouldReturn` "nested/top/mid/bottom"+      describe "branching" $ do+        it "should follow many paths" $ do+          "nested" ^! branching ["top", "peak"] . ls `shouldReturn`+            ["nested/top/mid","nested/peak/trees.txt","nested/peak/base"]+      describe "dirs" $ do+        it "should filter to only dirs" $ do+          "flat" ^!! ls . traversed . dirs `shouldReturn` ["flat/dir"]+      describe "files" $ do+        it "should filter to only files" $ do+          "flat" ^!! ls . traversed . files `shouldReturn` ["flat/file.txt", "flat/file.md"]+      describe "contents" $ do+        it "should get file contents" $ do+          "flat" ^!! ls . traversed . files . contents `shouldReturn` ["text\n", "markdown\n"]+      describe "exts" $ do+        it "should filter by extension" $ do+          "flat" ^!! ls . traversed . exts ["", "txt"] `shouldReturn` ["flat/file.txt", "flat/dir"]+      describe "crawled" $ do+        it "should find ALL files and dirs under root including root" $ do+          "nested" ^!! crawled `shouldReturn`+            [ "nested", "nested/top", "nested/top/mid", "nested/top/mid/bottom"+            , "nested/top/mid/bottom/floor.txt", "nested/peak", "nested/peak/trees.txt"+            , "nested/peak/base", "nested/peak/base/basecamp.txt"]+      describe "absoluted" $ do+        it "should make paths absolute" $ do+          "flat" ^!! ls . traversed . absolute `shouldReturn`+            [ absRoot </> "flat" </> "file.txt"+            , absRoot </> "flat" </> "file.md"+            , absRoot </> "flat" </> "dir"+            ]+      describe "withPerms" $ do+        it "should filter based on permissions" $ do+          "permissions" ^!! ls . traversed . withPerms [executable] `shouldReturn`+            ["permissions/exe" ]+          "permissions" ^!! ls . traversed . withPerms [readable] `shouldReturn`+            ["permissions/readonly", "permissions/exe" ]+        it "should 'and' permissions together" $ do+          "permissions" ^!! ls . traversed . withPerms [executable, readable, writable] `shouldReturn`+            ["permissions/exe" ]+      describe "symLinksFollowed" $ do+        it "should rewrite symlinks" $ do+          "symLinked" ^!! symLinksFollowed `shouldReturn` ["flat"]++      describe "recovering" $ do+        it "should recover from exceptions with an empty fold" $ do+          [1 :: Int, 2, 3] ^!! traversed . recovering (act (\case 2 -> fail "nope"; n -> pure n))+            `shouldReturn` [1, 3]++      describe "tryOrContinue" $ do+        it "should return input when fold fails" $ do+          [1 :: Int, 2, 3] ^!! traversed . tryOrContinue (act (\case 2 -> fail "nope"; n -> pure (10*n)))+            `shouldReturn` [10, 2, 30]++      describe "tryCatch" $ do+        it "should recover from failure using handler" $ do+          [1 :: Int, 2, 3] ^!! traversed . tryCatch (act (\case 2 -> fail "nope"; n -> pure (10*n))) (pure . (*100))+            `shouldReturn` [10, 200, 30]++      describe "filteredM" $ do+        it "should filter out failing elements" $ do+          [1 :: Int, 2, 3] ^!! traversed . filteredM (pure . odd)+            `shouldReturn` [1, 3]++      describe "merging" $ do+        it "should combine elements from multiple folds" $ do+          [1 :: Int, 2, 3] ^!! traversed . merging (to (*10)) (to (*100))+            `shouldReturn` [10, 100, 20, 200, 30, 300]++      describe "including" $ do+        it "should add new elements while keeping old ones" $ do+          [1 :: Int, 2, 3] ^!! traversed . including (to (*10))+            `shouldReturn` [1, 10, 2, 20, 3, 30]