diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,27 @@ +Copyright 2021 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,27 +0,0 @@ -Copyright 2012-2014 Tony Morris - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. 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. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,7 @@ +0.4.0 + +* Rewrite of filepather + +0.3.0 + +* This change log starts diff --git a/filepather.cabal b/filepather.cabal --- a/filepather.cabal +++ b/filepather.cabal @@ -1,48 +1,45 @@ -Name: filepather -Version: 0.3.0 -Author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> -Maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> -Copyright: Tony Morris -License: BSD3 -License-File: LICENSE -Synopsis: Functions on System.FilePath -Category: System -Description: +name: filepather +version: 0.4.0 +synopsis: Functions on System.FilePath +description: Functions over @System.FilePath@ including a find function for recursing down directories. -Homepage: https://github.com/tonymorris/filepather -Cabal-version: >= 1.6 -Build-Type: Simple - -Flag small_base - Description: Choose the new, split-up base package. - -Library - Build-Depends: - base < 5 && >= 3, - directory >= 1.1, - filepath >= 1.2, - mtl >= 2, - comonad >= 1.1, - transformers >= 0.2, - data-lens >= 2.9, - comonad-transformers >= 2 - - GHC-Options: - -Wall +license: BSD3 +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (C) 2021 Tony Morris +category: Test +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 +homepage: https://gitlab.com/tonymorris/filepather +bug-reports: https://gitlab.com/tonymorris/filepather/issues +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5 - Hs-Source-Dirs: - src +source-repository head + type: git + location: git@gitlab.com:tonymorris/filepather.git - Exposed-Modules: - System.FilePath.FilePather - System.FilePath.FilePather.FileType - System.FilePath.FilePather.RecursePredicate - System.FilePath.FilePather.FilterPredicate - System.FilePath.FilePather.FilePathPredicate - System.FilePath.FilePather.Find - System.FilePath.FilePather.LiftI +library + exposed-modules: + System.FilePath.FilePather + System.FilePath.FilePather.Find + System.FilePath.FilePather.ReadFilePath + System.FilePath.FilePather.ToFilePath + System.FilePath.FilePather.Posix -Source-Repository head - type: git - location: git@github.com:tonymorris/filepather.git + build-depends: base >= 4.8 && < 6 + , bytestring >= 0.10 && < 0.12 + , contravariant >= 1 && < 2 + , directory >= 1.3 && < 2 + , filepath >= 1.4 && < 2 + , lens >= 4 && < 6 + , mmorph >= 1.1 && < 2 + , mtl >= 2.2 && < 2.3 + , semigroups >= 0.9 && < 1 + , semigroupoids >= 5.2 && < 6 + , transformers >= 0.5 && < 0.7 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/System/FilePath/FilePather.hs b/src/System/FilePath/FilePather.hs --- a/src/System/FilePath/FilePather.hs +++ b/src/System/FilePath/FilePather.hs @@ -1,9 +1,8 @@ -module System.FilePath.FilePather(module X) where - -import System.FilePath.FilePather.FileType as X -import System.FilePath.FilePather.RecursePredicate as X -import System.FilePath.FilePather.FilterPredicate as X -import System.FilePath.FilePather.FilePathPredicate as X -import System.FilePath.FilePather.Find as X -import System.FilePath.FilePather.LiftI as X +module System.FilePath.FilePather( + module P +) where +import System.FilePath.FilePather.Find as P +import System.FilePath.FilePather.Posix as P +import System.FilePath.FilePather.ReadFilePath as P +import System.FilePath.FilePather.ToFilePath as P diff --git a/src/System/FilePath/FilePather/FilePathPredicate.hs b/src/System/FilePath/FilePather/FilePathPredicate.hs deleted file mode 100644 --- a/src/System/FilePath/FilePather/FilePathPredicate.hs +++ /dev/null @@ -1,270 +0,0 @@ -module System.FilePath.FilePather.FilePathPredicate -( - FilePathPredicate(..) -) where - -import qualified System.FilePath as P -import System.FilePath.FilePather.RecursePredicate -import System.FilePath.FilePather.FilterPredicate -import Control.Monad -import qualified Data.Foldable as F - --- | Functions that are common to predicates that work on 'FilePath' values. -class FilePathPredicate f where - -- | A predicate that always succeeds. - always :: - Monad g => - f g - -- | A predicate that always fails. - never :: - Monad g => - f g - -- | Return a predicate that succeeds only if the two given predicates succeed. - (.&&.) :: - Monad g => - f g - -> f g - -> f g - -- | Return a predicate that succeeds if any of the two given predicates succeed. - (.||.) :: - Monad g => - f g - -> f g - -> f g - -- | Negates the given predicate. - (.!.) :: - Monad g => - f g - -> f g - -- | Folds the predicates on disjunction. - anyof :: - (F.Foldable t, Monad g) => - t (f g) - -> f g - -- | Folds the predicates on conjunction. - anyof = - F.foldr (.||.) never - allof :: - (F.Foldable t, Monad g) => - t (f g) - -> f g - allof = - F.foldr (.&&.) always - -- | A predicate that computes its result based on a file name extension. - extension :: - Monad g => - (FilePath -> Bool) - -> f g - -- | A predicate that computes its result based on equivalence to a file name extension. This function matches with and without the preceding extension separator (.). - extensionEq :: - Monad g => - FilePath - -> f g - extensionEq p = - extension (== p) - -- | A predicate that computes its result based on equivalence to one of a list of file name extensions. - extensionOneof :: - (F.Foldable t, Monad g) => - t FilePath - -> f g - extensionOneof = - F.foldr (\a b -> extensionEq a .||. b) never - -- | A predicate that computes its result based on inequivalence to any of a list of file name extensions. - extensionNoneof :: - (F.Foldable t, Monad g) => - t FilePath - -> f g - extensionNoneof = - F.foldr (\a b -> (.!.) (extensionEq a) .&&. b) always - -- | A predicate that computes its result based on a directory. - directory :: - Monad g => - (FilePath -> Bool) - -> f g - -- | A predicate that succeeds if its 'FilePath' has an extension. - hasExtension :: - Monad g => - f g - hasExtension = - (.!.) notHasExtension - -- | A predicate that succeeds if its 'FilePath' does not have an extension. - notHasExtension :: - Monad g => - f g - notHasExtension = - (.!.) hasExtension - -- | A predicate that computes its result based on the splitting of a name and extension. - splitExtension :: - Monad g => - (String -> String -> Bool) - -> f g - -- | A predicate that computes its result based on the splitting of a name into directories. - splitDirectories :: - Monad g => - ([FilePath] -> Bool) - -> f g - -- | A predicate that succeeds if its 'FilePath' has a trailing path separator. - hasTrailingPathSeparator :: - Monad g => - f g - hasTrailingPathSeparator = - (.!.) notHasTrailingPathSeparator - -- | A predicate that succeeds if its 'FilePath' does not have a trailing path separator. - notHasTrailingPathSeparator:: - Monad g => - f g - notHasTrailingPathSeparator = - (.!.) hasTrailingPathSeparator - -- | A predicate that computes its result based on the file name. - fileName :: - Monad g => - (FilePath -> Bool) - -> f g - -- | A predicate that computes its result based on the base name. - baseName :: - Monad g => - (FilePath -> Bool) - -> f g - -- | A predicate that computes its result based on the normalised file name. - normalise :: - Monad g => - (FilePath -> Bool) - -> f g - -- | A predicate that computes its result based on the file name having been made valid. - makeValid :: - Monad g => - (FilePath -> Bool) - -> f g - -- | A predicate that succeeds if its 'FilePath' is relative. - isRelative :: - Monad g => - f g - isRelative = - (.!.) isNotRelative - -- | A predicate that succeeds if its 'FilePath' is not relative. - isNotRelative :: - Monad g => - f g - isNotRelative = - (.!.) isRelative - -- | A predicate that succeeds if its 'FilePath' is absolute. - isAbsolute :: - Monad g => - f g - isAbsolute = - (.!.) isNotAbsolute - -- | A predicate that succeeds if its 'FilePath' is not absolute. - isNotAbsolute :: - Monad g => - f g - isNotAbsolute = - (.!.) isAbsolute - -- | A predicate that succeeds if its 'FilePath' is valid. - isValid :: - Monad g => - f g - isValid = - (.!.) isNotValid - -- | A predicate that succeeds if its 'FilePath' is not valid. - isNotValid :: - Monad g => - f g - isNotValid = - (.!.) isValid - -instance FilePathPredicate RecursePredicateT where - always = - recursePredicateT . const . return $ True - never = - recursePredicateT . const . return $ False - f .&&. g = - recursePredicateT $ \p -> do r <- runRecursePredicateT f p - if r - then - runRecursePredicateT g p - else - return False - f .||. g = - recursePredicateT $ \p -> do r <- runRecursePredicateT f p - if r - then - return True - else - runRecursePredicateT g p - (.!.) f = - recursePredicateT $ liftM not . runRecursePredicateT f - extension f = - recursePredicateT $ return . liftM2 (||) f (f . drop 1) . P.takeExtension - directory f = - recursePredicateT $ return . f . P.takeDirectory - hasExtension = - recursePredicateT $ return . P.hasExtension - splitExtension f = - recursePredicateT $ return . uncurry f . P.splitExtension - splitDirectories f = - recursePredicateT $ return . f . P.splitDirectories - hasTrailingPathSeparator = - recursePredicateT $ return . P.hasTrailingPathSeparator - fileName f = - recursePredicateT $ return . f . P.takeFileName - baseName f = - recursePredicateT $ return . f . P.takeBaseName - normalise f = - recursePredicateT $ return . f . P.normalise - makeValid f = - recursePredicateT $ return . f . P.makeValid - isRelative = - recursePredicateT $ return . P.isRelative - isAbsolute = - recursePredicateT $ return . P.isAbsolute - isValid = - recursePredicateT $ return . P.isValid - -instance FilePathPredicate FilterPredicateT where - always = - filterPredicateT . const . const . return $ True - never = - filterPredicateT . const . const . return $ False - f .&&. g = - filterPredicateT $ \p k -> do r <- runFilterPredicateT f p k - if r - then - runFilterPredicateT g p k - else - return False - f .||. g = - filterPredicateT $ \p k -> do r <- runFilterPredicateT f p k - if r - then - return True - else - runFilterPredicateT g p k - (.!.) f = - filterPredicateT $ \p -> liftM not . runFilterPredicateT f p - extension f = - filterPredicateT $ const . return . liftM2 (||) f (f . drop 1) . P.takeExtension - directory f = - filterPredicateT $ const . return . f . P.takeDirectory - hasExtension = - filterPredicateT $ const . return . P.hasExtension - splitExtension f = - filterPredicateT $ const . return . uncurry f . P.splitExtension - splitDirectories f = - filterPredicateT $ const . return . f . P.splitDirectories - hasTrailingPathSeparator = - filterPredicateT $ const . return . P.hasTrailingPathSeparator - fileName f = - filterPredicateT $ const . return . f . P.takeFileName - baseName f = - filterPredicateT $ const . return . f . P.takeBaseName - normalise f = - filterPredicateT $ const . return . f . P.normalise - makeValid f = - filterPredicateT $ const . return . f . P.makeValid - isRelative = - filterPredicateT $ const . return . P.isRelative - isAbsolute = - filterPredicateT $ const . return . P.isAbsolute - isValid = - filterPredicateT $ const . return . P.isValid - diff --git a/src/System/FilePath/FilePather/FileType.hs b/src/System/FilePath/FilePather/FileType.hs deleted file mode 100644 --- a/src/System/FilePath/FilePather/FileType.hs +++ /dev/null @@ -1,32 +0,0 @@ -module System.FilePath.FilePather.FileType -( - FileType(..) -, isFile -, isDirectory -, isUnknown -) where --- | The possible types of a file. -data FileType = - File -- ^ The type is a normal file. - | Directory -- ^ The type is a directory. - | Unknown -- ^ The type is unknown. - deriving (Eq, Ord, Show, Enum) - -isFile :: - FileType - -> Bool -isFile = - (==) File - -isDirectory :: - FileType - -> Bool -isDirectory = - (==) Directory - -isUnknown :: - FileType - -> Bool -isUnknown = - (==) Unknown - diff --git a/src/System/FilePath/FilePather/FilterPredicate.hs b/src/System/FilePath/FilePather/FilterPredicate.hs deleted file mode 100644 --- a/src/System/FilePath/FilePather/FilterPredicate.hs +++ /dev/null @@ -1,88 +0,0 @@ -module System.FilePath.FilePather.FilterPredicate -( - FilterPredicateT -, FilterPredicate -, filterPredicateT -, filterPredicate -, filterPredicateT' -, filterPredicate' -, runFilterPredicateT -, runFilterPredicate -, isDirectoryType -, isFileType -, isUnknownType -) where - -import Control.Monad.Identity -import System.FilePath.FilePather.FileType - -newtype FilterPredicateT f = - FilterPredicateT (FilePath -> FileType -> f Bool) - --- | A filter predicate that does not require effects to compute its result. -type FilterPredicate = - FilterPredicateT Identity - --- | A filter predicate takes a 'FilePath' and a file type and returns whether or not to filter the value. -filterPredicateT :: - (FilePath -> FileType -> f Bool) - -> FilterPredicateT f -filterPredicateT = - FilterPredicateT - --- | Construct a filter predicate that does not require effects to compute its result. -filterPredicate :: - (FilePath -> FileType -> Bool) - -> FilterPredicate -filterPredicate f = - filterPredicateT (\z -> Identity . f z) - --- | A filter predicate takes a 'FilePath' and returns whether or not to filter the value. -filterPredicateT' :: - (FilePath -> f Bool) - -> FilterPredicateT f -filterPredicateT' f = - filterPredicateT (const . f) - --- | Construct a filter predicate that does not require effects to compute its result. -filterPredicate' :: - (FilePath -> Bool) - -> FilterPredicate -filterPredicate' f = - filterPredicate (const . f) - --- | Extract the filter predicate function. -runFilterPredicateT :: - FilterPredicateT f - -> FilePath - -> FileType - -> f Bool -runFilterPredicateT (FilterPredicateT f) = - f - --- | Construct a filter predicate that does not require effects to compute its result. -runFilterPredicate :: - FilterPredicate - -> FilePath - -> FileType - -> Bool -runFilterPredicate p k = - runIdentity . runFilterPredicateT p k - -isDirectoryType :: - Monad f => - FilterPredicateT f -isDirectoryType = - filterPredicateT . const $ return . isDirectory - -isFileType :: - Monad f => - FilterPredicateT f -isFileType = - filterPredicateT . const $ return . isFile - -isUnknownType :: - Monad f => - FilterPredicateT f -isUnknownType = - filterPredicateT . const $ return . isUnknown diff --git a/src/System/FilePath/FilePather/Find.hs b/src/System/FilePath/FilePather/Find.hs --- a/src/System/FilePath/FilePather/Find.hs +++ b/src/System/FilePath/FilePather/Find.hs @@ -1,255 +1,78 @@ -module System.FilePath.FilePather.Find -( - Find(..) -, findi -, findpi -, FindR -, foundR -, dropR -, recurseR -, noRecurseR -, foundL -, dropL -, recurseL -, noRecurseL -) where - -import Control.Monad.Identity -import Control.Monad.Trans.Identity -import Control.Comonad -import Control.Comonad.Trans.Store -import Data.Lens.Partial.Common hiding (null) -import System.FilePath -import System.FilePath.FilePather.RecursePredicate -import System.FilePath.FilePather.FilterPredicate -import System.FilePath.FilePather.FileType -import System.Directory - -class Find f where - -- | Finds all files using the given recurse predicate and filter predicate in the given file path. - find :: - FilterPredicateT f - -> RecursePredicateT f - -> FilePath - -> IO [FindR] - -- | Find files in the current directory. - findHere :: - FilterPredicateT f - -> RecursePredicateT f - -> IO [FindR] - findHere f r = - getCurrentDirectory >>= find f r - -- | Finds all files using the given recurse predicate and filter predicate in the given file path. - findp :: - FilterPredicateT f - -> RecursePredicateT f - -> FilePath - -> IO [FilePath] - findp f r = - liftM (\x -> x >>= \w -> - case w of - Found p _ -> [p] - Drop _ _ -> [] - Recurse _ -> [] - NoRecurse _ -> []) . find f r - -- | Find files in the current directory. - findpHere :: - FilterPredicateT f - -> RecursePredicateT f - -> IO [FilePath] - findpHere f r = - getCurrentDirectory >>= findp f r - -instance Find Identity where - find f' r' = - let find' base p = - let f = - runFilterPredicateT f' - r = - runRecursePredicateT r' - z :: - FilePath - z = - if null base then p else base p - keep :: - Bool - -> FileType - -> FindR - keep u = - (if u then Found else Drop) z - rkeep :: - Bool - -> FindR - rkeep u = - (if u then Recurse else NoRecurse) z - tkeep :: - FileType - -> [FindR] - tkeep t = - [keep (runIdentity (f z t)) t] - in do fe <- doesFileExist z - if fe - then - return (tkeep File) - else - do de <- doesDirectoryExist z - if de - then - let (Identity k) = f z Directory - (Identity l) = r z - in liftM ([rkeep l, keep k Directory] ++) $ - if l - then - do t <- getDirectoryContents z - u <- forM (filter (`notElem` [".", ".."]) t) (find f' r' . (z )) - return (concat u) - else - return [] - else - return (tkeep Unknown) - in find' [] - -instance Find IO where - find f' r' = - let find' base p = - let f = - runFilterPredicateT f' - r = - runRecursePredicateT r' - z :: - FilePath - z = - if null base then p else base p - keep :: - Bool - -> FileType - -> FindR - keep u = - (if u then Found else Drop) z - rkeep :: - Bool - -> FindR - rkeep u = - (if u then Recurse else NoRecurse) z - tkeep :: - FileType - -> IO [FindR] - tkeep t = - f z t >>= \y -> return [keep y t] - in do fe <- doesFileExist z - if fe - then - tkeep File - else - do de <- doesDirectoryExist z - if de - then - do k <- f z Directory - l <- r z - liftM ([rkeep l, keep k Directory] ++) $ - if l - then - do t <- getDirectoryContents z - u <- forM (filter (`notElem` [".", ".."]) t) (find f' r' . (z )) - return (concat u) - else - return [] - else - tkeep Unknown - in find' [] - -instance Comonad f => Find (IdentityT f) where - find f r = - find (filterPredicateT $ \p -> Identity . extract . runFilterPredicateT f p) (recursePredicateT $ Identity . extract . runRecursePredicateT r) - --- | A specialisation of `find` to the `Identity` monad. Useful in assisting type-inference. -findi :: - FilterPredicate - -> RecursePredicate - -> FilePath - -> IO [FindR] -findi = - find - --- | A specialisation of `findp` to the `Identity` monad. Useful in assisting type-inference. -findpi :: - FilterPredicate - -> RecursePredicate - -> FilePath - -> IO [FilePath] -findpi = - findp - --- | The results of a path find. One of --- --- * @found@ with the file path name and file type. --- --- * @drop@ with the file path name and file type. --- --- * @recurse@ with the file path (the file type is always directory). --- --- * @no-recurse@ with the file path (the file type is always directory). -data FindR = - Found FilePath FileType - | Drop FilePath FileType - | Recurse FilePath - | NoRecurse FilePath - deriving (Eq, Show) - -foundR :: - FilePath - -> FileType - -> FindR -foundR = - Found - -dropR :: - FilePath - -> FileType - -> FindR -dropR = - Drop - -recurseR :: - FilePath - -> FindR -recurseR = - Recurse +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} -noRecurseR :: - FilePath - -> FindR -noRecurseR = - NoRecurse +module System.FilePath.FilePather.Find( + findFiles +, always +, findFilesAlways +) where -foundL :: - PartialLens FindR (FilePath, FileType) -foundL = - PLens $ \r -> - case r of - Found p t -> Just (store (uncurry Found) (p, t)) - _ -> Nothing +import Control.Applicative ( Applicative(liftA2, pure) ) +import Control.Category ( Category(id) ) +import Control.Lens ( view ) +import Control.Monad ( join, Monad((>>=)) ) +import System.FilePath.FilePather.Posix + ( (), FilePath, dropTrailingPathSeparator ) +import System.IO ( IO ) +import Data.Bool ( Bool(True), bool ) +import Data.Function(($)) +import Data.Functor ( Functor(fmap) ) +import Data.Traversable ( Traversable(traverse) ) +import Data.Semigroup ( Semigroup((<>)) ) +import System.Directory(doesDirectoryExist, listDirectory) +import System.FilePath.FilePather.ReadFilePath + ( ReadFilePathT(..), readFilePath ) -dropL :: - PartialLens FindR (FilePath, FileType) -dropL = - PLens $ \r -> - case r of - Drop p t -> Just (store (uncurry Drop) (p, t)) - _ -> Nothing +findFiles :: + ReadFilePathT IO Bool + -> ReadFilePathT IO [FilePath] +findFiles (ReadFilePathT test) = + let bool' :: + Monad f => + f a + -> f a + -> f Bool + -> f a + bool' f t p = + p >>= bool f t + partitionM :: + Applicative m => + (a -> m Bool) + -> [a] + -> m ([a], [a]) + partitionM _ [] = + pure ([], []) + partitionM f (x:xs) = + liftA2 + (\res (as, bs) -> + let onres p q = + bool p q res + in (onres id (x:) as, onres (x:) id bs) + ) + (f x) + (partitionM f xs) + findFiles' base dx = + bool' + (pure []) + ( + let findFiles'' dir = + let dir' = + base dir + in do (dirs,files) <- listDirectory dir' >>= partitionM (\d -> doesDirectoryExist (dir' d)) + rest <- fmap join (traverse (\d -> findFiles'' (dir d)) dirs) + pure (fmap (dir ) files <> rest) + in findFiles'' dx + ) + (test $ view readFilePath dropTrailingPathSeparator dx) + in ReadFilePathT (`findFiles'` "") -recurseL :: - PartialLens FindR FilePath -recurseL = - PLens $ \r -> - case r of - Recurse p -> Just (store Recurse p) - _ -> Nothing +always :: + Applicative f => + ReadFilePathT f Bool +always = + ReadFilePathT (pure (pure True)) -noRecurseL :: - PartialLens FindR FilePath -noRecurseL = - PLens $ \r -> - case r of - NoRecurse p -> Just (store NoRecurse p) - _ -> Nothing +findFilesAlways :: + ReadFilePathT IO [FilePath] +findFilesAlways = + findFiles always diff --git a/src/System/FilePath/FilePather/LiftI.hs b/src/System/FilePath/FilePather/LiftI.hs deleted file mode 100644 --- a/src/System/FilePath/FilePather/LiftI.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} - -module System.FilePath.FilePather.LiftI -( - LiftI(..) -) where - -import System.FilePath.FilePather.RecursePredicate -import System.FilePath.FilePather.FilterPredicate - --- | A type-class for lifting a value. --- This type-class probably belongs elsewhere (pointers appreciated!). -class LiftI f a | f -> a where - liftI :: - Monad g => - g a - -> f g - -instance LiftI RecursePredicateT Bool where - liftI = - recursePredicateT . const - -instance LiftI FilterPredicateT Bool where - liftI = - filterPredicateT . const . const - diff --git a/src/System/FilePath/FilePather/Posix.hs b/src/System/FilePath/FilePather/Posix.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePath/FilePather/Posix.hs @@ -0,0 +1,300 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module System.FilePath.FilePather.Posix( + splitExtension +, takeExtension +, replaceExtension +, dropExtension +, addExtension +, hasExtension +, splitExtensions +, dropExtensions +, takeExtensions +, replaceExtensions +, isExtensionOf +, stripExtension +, splitFileName +, takeFileName +, replaceFileName +, dropFileName +, takeBaseName +, replaceBaseName +, takeDirectory +, replaceDirectory +, combine +, splitPath +, joinPath +, splitDirectories +, splitDrive +, joinDrive +, takeDrive +, hasDrive +, dropDrive +, isDrive +, hasTrailingPathSeparator +, addTrailingPathSeparator +, dropTrailingPathSeparator +, normalise +, equalFilePath +, makeRelative +, isRelative +, isAbsolute +, isValid +, makeValid +, module SFP +) where + +import Control.Applicative ( Applicative ) +import Control.Category((.)) +import Control.Lens ( (#) ) +import Data.String( String ) +import Data.Bool( Bool ) +import Data.Maybe ( Maybe ) +import qualified System.FilePath as FP +import System.FilePath as SFP(FilePath, pathSeparator, pathSeparators, isPathSeparator, extSeparator, isExtSeparator, splitSearchPath, (-<.>), ()) +import System.FilePath.FilePather.ToFilePath + ( ToFilePath, toFilePath ) +import System.FilePath.FilePather.ReadFilePath + ( ReadFilePathT, liftReadFilePath ) + +splitExtension :: + Applicative f => + ReadFilePathT f (String, String) +splitExtension = + liftReadFilePath FP.splitExtension + +takeExtension :: + Applicative f => + ReadFilePathT f String +takeExtension = + liftReadFilePath FP.takeExtension + +replaceExtension :: + Applicative f => + ReadFilePathT f (String -> FilePath) +replaceExtension = + liftReadFilePath FP.replaceExtension + +dropExtension :: + Applicative f => + ReadFilePathT f FilePath +dropExtension = + liftReadFilePath FP.dropExtensions + +addExtension :: + Applicative f => + ReadFilePathT f (String -> FilePath) +addExtension = + liftReadFilePath FP.addExtension + +hasExtension :: + Applicative f => + ReadFilePathT f Bool +hasExtension = + liftReadFilePath FP.hasExtension + +splitExtensions :: + Applicative f => + ReadFilePathT f (FilePath, String) +splitExtensions = + liftReadFilePath FP.splitExtensions + +dropExtensions :: + Applicative f => + ReadFilePathT f FilePath +dropExtensions = + liftReadFilePath FP.dropExtensions + +takeExtensions :: + Applicative f => + ReadFilePathT f String +takeExtensions = + liftReadFilePath FP.takeExtensions + +replaceExtensions :: + Applicative f => + ReadFilePathT f (String -> FilePath) +replaceExtensions = + liftReadFilePath FP.replaceExtensions + +isExtensionOf :: + Applicative f => + String + -> ReadFilePathT f Bool +isExtensionOf = + liftReadFilePath . FP.isExtensionOf + +stripExtension :: + Applicative f => + String + -> ReadFilePathT f (Maybe FilePath) +stripExtension = + liftReadFilePath . FP.stripExtension + +splitFileName :: + Applicative f => + ReadFilePathT f (String, String) +splitFileName = + liftReadFilePath FP.splitFileName + +takeFileName :: + Applicative f => + ReadFilePathT f String +takeFileName = + liftReadFilePath FP.takeFileName + +replaceFileName :: + Applicative f => + ReadFilePathT f (String -> FilePath) +replaceFileName = + liftReadFilePath FP.replaceFileName + +dropFileName :: + Applicative f => + ReadFilePathT f FilePath +dropFileName = + liftReadFilePath FP.dropFileName + +takeBaseName :: + Applicative f => + ReadFilePathT f String +takeBaseName = + liftReadFilePath FP.takeBaseName + +replaceBaseName :: + Applicative f => + ReadFilePathT f (String -> FilePath) +replaceBaseName = + liftReadFilePath FP.replaceBaseName + +takeDirectory :: + Applicative f => + ReadFilePathT f FilePath +takeDirectory = + liftReadFilePath FP.takeDirectory + +replaceDirectory :: + Applicative f => + ReadFilePathT f (String -> FilePath) +replaceDirectory = + liftReadFilePath FP.replaceDirectory + +combine :: + Applicative f => + ReadFilePathT f (FilePath -> FilePath) +combine = + liftReadFilePath FP.combine + +splitPath :: + Applicative f => + ReadFilePathT f [FilePath] +splitPath = + liftReadFilePath FP.splitPath + +joinPath :: + ToFilePath [FilePath] +joinPath = + toFilePath # FP.joinPath + +splitDirectories :: + Applicative f => + ReadFilePathT f [FilePath] +splitDirectories = + liftReadFilePath FP.splitDirectories + +splitDrive :: + Applicative f => + ReadFilePathT f (FilePath, FilePath) +splitDrive = + liftReadFilePath FP.splitDrive + +joinDrive :: + Applicative f => + ReadFilePathT f (FilePath -> FilePath) +joinDrive = + liftReadFilePath FP.joinDrive + +takeDrive :: + Applicative f => + ReadFilePathT f FilePath +takeDrive = + liftReadFilePath FP.takeDrive + +hasDrive :: + Applicative f => + ReadFilePathT f Bool +hasDrive = + liftReadFilePath FP.hasDrive + +dropDrive :: + Applicative f => + ReadFilePathT f FilePath +dropDrive = + liftReadFilePath FP.dropDrive + +isDrive :: + Applicative f => + ReadFilePathT f Bool +isDrive = + liftReadFilePath FP.isDrive + +hasTrailingPathSeparator :: + Applicative f => + ReadFilePathT f Bool +hasTrailingPathSeparator = + liftReadFilePath FP.hasTrailingPathSeparator + +addTrailingPathSeparator :: + Applicative f => + ReadFilePathT f FilePath +addTrailingPathSeparator = + liftReadFilePath FP.addTrailingPathSeparator + +dropTrailingPathSeparator :: + Applicative f => + ReadFilePathT f FilePath +dropTrailingPathSeparator = + liftReadFilePath FP.dropTrailingPathSeparator + +normalise :: + Applicative f => + ReadFilePathT f FilePath +normalise = + liftReadFilePath FP.normalise + +equalFilePath :: + Applicative f => + ReadFilePathT f (FilePath -> Bool) +equalFilePath = + liftReadFilePath FP.equalFilePath + +makeRelative :: + Applicative f => + ReadFilePathT f (FilePath -> FilePath) +makeRelative = + liftReadFilePath FP.makeRelative + +isRelative :: + Applicative f => + ReadFilePathT f Bool +isRelative = + liftReadFilePath FP.isRelative + +isAbsolute :: + Applicative f => + ReadFilePathT f Bool +isAbsolute = + liftReadFilePath FP.isAbsolute + +isValid :: + Applicative f => + ReadFilePathT f Bool +isValid = + liftReadFilePath FP.isValid + +makeValid :: + Applicative f => + ReadFilePathT f FilePath +makeValid = + liftReadFilePath FP.makeValid diff --git a/src/System/FilePath/FilePather/ReadFilePath.hs b/src/System/FilePath/FilePather/ReadFilePath.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePath/FilePather/ReadFilePath.hs @@ -0,0 +1,241 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module System.FilePath.FilePather.ReadFilePath( + ReadFilePathT(..) +, ReadFilePath +, ReadFilePathT1 +, ReadFilePath1 +, readFilePath +, hoistReadFilePath +, liftReadFilePath +) where + +import Control.Applicative + ( Applicative(liftA2, (<*>), pure), Alternative((<|>), empty) ) +import Control.Category((.)) +import Control.Lens + ( iso, Iso, Rewrapped, Wrapped(Unwrapped, _Wrapped'), view, _Wrapped, ( # ) ) +import Control.Monad + ( Monad((>>=), return), Functor(fmap), MonadPlus(mplus, mzero) ) +import Control.Monad.Cont.Class ( MonadCont(callCC) ) +import Control.Monad.Error.Class ( MonadError(throwError, catchError) ) +import Control.Monad.Fail ( MonadFail(fail) ) +import Control.Monad.Fix ( MonadFix(mfix) ) +import Control.Monad.IO.Class ( MonadIO(liftIO) ) +import Control.Monad.Morph ( MFunctor(hoist), MMonad(embed) ) +import Control.Monad.Reader.Class ( MonadReader(reader, local, ask) ) +import Control.Monad.State.Class ( MonadState(state, get, put) ) +import Control.Monad.Trans.Class(MonadTrans(lift)) +import Control.Monad.Writer.Class ( MonadWriter(pass, tell, writer, listen) ) +import Control.Monad.Zip ( MonadZip(mzipWith) ) +import Data.Functor.Apply ( Apply(liftF2, (<.>)) ) +import Data.Functor.Alt ( Alt(()) ) +import Data.Functor.Bind ( Bind((>>-)) ) +import Data.Functor.Identity(Identity(Identity, runIdentity)) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Semigroup(Semigroup((<>))) +import System.FilePath(FilePath) + +newtype ReadFilePathT f a = + ReadFilePathT (FilePath -> f a) + +instance ReadFilePathT f a ~ t => + Rewrapped (ReadFilePathT f' a') t + +instance Wrapped (ReadFilePathT f a) where + type Unwrapped (ReadFilePathT f a) = + FilePath + -> f a + _Wrapped' = + iso (\(ReadFilePathT x) -> x) ReadFilePathT + {-# INLINE _Wrapped' #-} + +type ReadFilePath a = + ReadFilePathT Identity a + +type ReadFilePathT1 f = + ReadFilePathT f () + +type ReadFilePath1 f = + ReadFilePath () + +readFilePath :: + Iso + (ReadFilePath a) + (ReadFilePath a') + (FilePath -> a) + (FilePath -> a') +readFilePath = + iso + (\(ReadFilePathT x) -> runIdentity . x) + (\p -> ReadFilePathT (Identity . p)) +{-# INLINE readFilePath #-} + +instance (Apply f, Semigroup a) => Semigroup (ReadFilePathT f a) where + ReadFilePathT a <> ReadFilePathT b = + ReadFilePathT (\p -> liftF2 (<>) (a p) (b p)) + {-# INLINE (<>) #-} + +instance (Apply f, Applicative f, Monoid a) => Monoid (ReadFilePathT f a) where + ReadFilePathT a `mappend` ReadFilePathT b = + ReadFilePathT (\p -> liftA2 mappend (a p) (b p)) + {-# INLINE mappend #-} + mempty = + ReadFilePathT (pure (pure mempty)) + {-# INLINE mempty #-} + +instance Functor f => Functor (ReadFilePathT f) where + fmap f (ReadFilePathT x) = + ReadFilePathT (fmap (fmap f) x) + {-# INLINE fmap #-} + +instance Apply f => Apply (ReadFilePathT f) where + ReadFilePathT f <.> ReadFilePathT a = + ReadFilePathT (\p -> f p <.> a p) + {-# INLINE (<.>) #-} + +instance Bind f => Bind (ReadFilePathT f) where + ReadFilePathT f >>- g = + ReadFilePathT (\p -> f p >>- \a -> view _Wrapped (g a) p) + {-# INLINE (>>-) #-} + +instance Applicative f => Applicative (ReadFilePathT f) where + ReadFilePathT f <*> ReadFilePathT a = + ReadFilePathT (\p -> f p <*> a p) + {-# INLINE (<*>) #-} + pure = + ReadFilePathT . pure . pure + {-# INLINE pure #-} + +instance Alt f => Alt (ReadFilePathT f) where + ReadFilePathT a ReadFilePathT b = + ReadFilePathT (\p -> a p b p) + {-# INLINE () #-} + +instance Alternative f => Alternative (ReadFilePathT f) where + ReadFilePathT a <|> ReadFilePathT b = + ReadFilePathT (\p -> a p <|> b p) + {-# INLINE (<|>) #-} + empty = + ReadFilePathT (pure empty) + {-# INLINE empty #-} + +instance Monad f => Monad (ReadFilePathT f) where + ReadFilePathT f >>= g = + ReadFilePathT (\p -> f p >>= \a -> view _Wrapped (g a) p) + {-# INLINE (>>=) #-} + return = + ReadFilePathT . return . return + {-# INLINE return #-} + +instance MonadTrans ReadFilePathT where + lift = + ReadFilePathT . pure + {-# INLINE lift #-} + +instance MonadIO f => MonadIO (ReadFilePathT f) where + liftIO = + ReadFilePathT . pure . liftIO + {-# INLINE liftIO #-} + +instance MFunctor ReadFilePathT where + hoist k (ReadFilePathT f) = + ReadFilePathT (k .f) + {-# INLINE hoist #-} + +instance MMonad ReadFilePathT where + embed k (ReadFilePathT f) = + ReadFilePathT (\p -> view _Wrapped (k (f p)) p) + {-# INLINE embed #-} + +instance Monad f => MonadReader FilePath (ReadFilePathT f) where + ask = + ReadFilePathT pure + {-# INLINE ask #-} + local k (ReadFilePathT f) = + ReadFilePathT (f . k) + {-# INLINE local #-} + reader k = + ReadFilePathT (pure . k) + {-# INLINE reader #-} + +instance MonadState FilePath f => MonadState FilePath (ReadFilePathT f) where + state = + lift . state + {-# INLINE state #-} + get = + lift get + {-# INLINE get #-} + put = + lift . put + {-# INLINE put #-} + +instance MonadWriter FilePath f => MonadWriter FilePath (ReadFilePathT f) where + writer = + lift . writer + {-# INLINE writer #-} + tell = + lift . tell + {-# INLINE tell #-} + listen (ReadFilePathT f) = + ReadFilePathT (listen . f) + {-# INLINE listen #-} + pass (ReadFilePathT f) = + ReadFilePathT (pass . f) + {-# INLINE pass #-} + +instance MonadFail f => MonadFail (ReadFilePathT f) where + fail = + lift . fail + {-# INLINE fail #-} + +instance MonadFix f => MonadFix (ReadFilePathT f) where + mfix f = + ReadFilePathT (\p -> mfix (\a -> view _Wrapped (f a) p)) + {-# INLINE mfix #-} + +instance MonadZip f => MonadZip (ReadFilePathT f) where + mzipWith f (ReadFilePathT m) (ReadFilePathT n) = + ReadFilePathT (\a -> mzipWith f (m a) (n a)) + {-# INLINE mzipWith #-} + +instance MonadCont f => MonadCont (ReadFilePathT f) where + callCC p = + ReadFilePathT (\r -> callCC (\c -> view _Wrapped (p (ReadFilePathT . pure . c)) r)) + {-# INLINE callCC #-} + +instance MonadError e f => MonadError e (ReadFilePathT f) where + throwError = + lift . throwError + {-# INLINE throwError #-} + catchError (ReadFilePathT f) g = + ReadFilePathT (\ r -> catchError (f r) (\ e -> view _Wrapped (g e) r)) + {-# INLINE catchError #-} + +instance MonadPlus f => MonadPlus (ReadFilePathT f) where + mzero = + lift mzero + {-# INLINE mzero #-} + ReadFilePathT a `mplus` ReadFilePathT b = + ReadFilePathT (\ r -> a r `mplus` b r) + {-# INLINE mplus #-} + +hoistReadFilePath :: + Applicative f => + ReadFilePath a + -> ReadFilePathT f a +hoistReadFilePath = + hoist (pure . runIdentity) + +liftReadFilePath :: + Applicative f => + (FilePath -> a) + -> ReadFilePathT f a +liftReadFilePath = + hoistReadFilePath . (readFilePath #) diff --git a/src/System/FilePath/FilePather/RecursePredicate.hs b/src/System/FilePath/FilePather/RecursePredicate.hs deleted file mode 100644 --- a/src/System/FilePath/FilePather/RecursePredicate.hs +++ /dev/null @@ -1,59 +0,0 @@ -module System.FilePath.FilePather.RecursePredicate -( - RecursePredicateT -, RecursePredicate -, recursePredicateT -, recursePredicate -, runRecursePredicateT -, runRecursePredicate -, toFilterPredicate -) where - -import Control.Monad.Identity -import System.FilePath.FilePather.FilterPredicate - --- | A recurse predicate takes a 'FilePath', which is a directory, and returns whether or not to continue recursing down on that directory. -newtype RecursePredicateT f = - RecursePredicateT (FilePath -> f Bool) - --- | A recurse predicate that does not require effects to compute its result. -type RecursePredicate = - RecursePredicateT Identity - --- | Construct a recurse predicate. The most general construction function. -recursePredicateT :: - (FilePath -> f Bool) - -> RecursePredicateT f -recursePredicateT = - RecursePredicateT - --- | Construct a recurse predicate that does not require effects to compute its result. -recursePredicate :: - (FilePath -> Bool) - -> RecursePredicate -recursePredicate f = - recursePredicateT (Identity . f) - --- | Extract the recurse predicate function. -runRecursePredicateT :: - RecursePredicateT f - -> FilePath - -> f Bool -runRecursePredicateT (RecursePredicateT f) = - f - --- | Extract the recurse predicate function that does not require effects to compute its result. -runRecursePredicate :: - RecursePredicate - -> FilePath - -> Bool -runRecursePredicate p = - runIdentity . runRecursePredicateT p - --- | Convert the recurse predicate to a filter predicate. -toFilterPredicate :: - RecursePredicateT f - -> FilterPredicateT f -toFilterPredicate (RecursePredicateT f) = - filterPredicateT (const . f) - diff --git a/src/System/FilePath/FilePather/ToFilePath.hs b/src/System/FilePath/FilePather/ToFilePath.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePath/FilePather/ToFilePath.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +module System.FilePath.FilePather.ToFilePath( + ToFilePathT(..) +, ToFilePath +, toFilePath +, toRead +) where + +import Control.Category ( Category((.)) ) +import Control.Lens + ( view, + from, + iso, + Iso, + Iso', + Wrapped(..) ) +import Data.Functor.Contravariant ( Contravariant(contramap) ) +import Data.Functor.Identity ( Identity(..) ) +import System.FilePath ( FilePath ) +import System.FilePath.FilePather.ReadFilePath + ( ReadFilePath, readFilePath ) + +newtype ToFilePathT f a = + ToFilePathT (a -> f FilePath) + +type ToFilePath a = + ToFilePathT Identity a + +instance Wrapped (ToFilePathT f a) where + type Unwrapped (ToFilePathT f a) = + a + -> f FilePath + _Wrapped' = + iso (\(ToFilePathT x) -> x) ToFilePathT + {-# INLINE _Wrapped' #-} + +instance Contravariant (ToFilePathT f) where + contramap f (ToFilePathT g) = + ToFilePathT (g . f) + +toFilePath :: + Iso + (ToFilePath a) + (ToFilePath a') + (a -> FilePath) + (a' -> FilePath) +toFilePath = + iso + (\(ToFilePathT x) -> runIdentity . x) + (\p -> ToFilePathT (Identity . p)) +{-# INLINE toFilePath #-} + +toRead :: + Iso' + (ToFilePath FilePath) + (ReadFilePath FilePath) +toRead = + iso + (view (toFilePath . from readFilePath)) + (view (readFilePath . from toFilePath))