From 9de99e2864ffc590568e148202122f598c4abc96 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 13:38:24 -0700 Subject: [PATCH 01/21] nix flake update --- flake.lock | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/flake.lock b/flake.lock index c0ecefd..953b7c2 100644 --- a/flake.lock +++ b/flake.lock @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1681202837, - "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "cfacdce06f30d2b68473a46042957675eebb3401", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", "type": "github" }, "original": { @@ -20,11 +20,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1682879489, - "narHash": "sha256-sASwo8gBt7JDnOOstnps90K1wxmVfyhsTPPNTGBPjjg=", + "lastModified": 1714076141, + "narHash": "sha256-Drmja/f5MRHZCskS6mvzFqxEaZMeciScCTFxWVLqWEY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "da45bf6ec7bbcc5d1e14d3795c025199f28e0de0", + "rev": "7bb2ccd8cdc44c91edba16c48d2c8f331fb3d856", "type": "github" }, "original": { From 92963babca954fd669ef5609734a314cdddcd12f Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 13:38:45 -0700 Subject: [PATCH 02/21] gitignore vim files --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index cb59204..b380600 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,5 @@ dist cabal.sandbox.config + +# vim swapfiles +*.sw* From 12b1bc3ab05d293472e8cdda106be697025e7c75 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 13:53:43 -0700 Subject: [PATCH 03/21] gitignore nix result links --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index b380600..9616d84 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,6 @@ cabal.sandbox.config # vim swapfiles *.sw* + +# nix result symlinks +result* From 3d2b73343f118368827d3ad166e36ad6a8bdf792 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 14:01:21 -0700 Subject: [PATCH 04/21] gitignore dist-newstyle --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 9616d84..d67aa00 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ dist +dist-newstyle cabal.sandbox.config # vim swapfiles From f8126eaed537b34469c0d5dcaa5188e518d4c300 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 16:46:50 -0700 Subject: [PATCH 05/21] todos --- todo.txt | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 todo.txt diff --git a/todo.txt b/todo.txt new file mode 100644 index 0000000..591c1e0 --- /dev/null +++ b/todo.txt @@ -0,0 +1,7 @@ +typeclass idea: + make a TreeName class + instances need fns: + packName (start as fp2n) + unpackName (start as n2fp) + joinNames? (maybe later, with default to unpack, , pack again) + showName? (or can that just be unpackName?) From e7b481f721368408e239565b470de9665f05748a Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 16:59:10 -0700 Subject: [PATCH 06/21] wip on TreeName typeclass idea --- System/Directory/Tree.hs | 66 +++++++++++++++++++++++----------------- 1 file changed, 38 insertions(+), 28 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 583d60c..f720c03 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -164,23 +164,29 @@ import System.IO.Unsafe(unsafeInterleaveIO) import Control.Applicative #endif +-- TODO add a join function to avoid packing + unpacking? +-- TODO wait can I just use IsString instead? +class TreeName a where + fp2n :: FilePath -> a + n2fp :: a -> FilePath + -- | the String in the name field is always a file name, never a full path. -- The free type variable is used in the File constructor and can hold Handles, -- Strings representing a file's contents or anything else you can think of. -- We catch any IO errors in the Failed constructor. an Exception can be -- converted to a String with 'show'. -data DirTree a = Failed { name :: FileName, - err :: IOException } - | Dir { name :: FileName, - contents :: [DirTree a] } - | File { name :: FileName, - file :: a } - deriving Show +data DirTree n a = Failed { name :: n, + err :: IOException } + | Dir { name :: n, + contents :: [DirTree n a] } + | File { name :: n, + file :: a } + deriving Show -- TODO will this work? -- | Two DirTrees are equal if they have the same constructor, the same name -- (and in the case of `Dir`s) their sorted `contents` are equal: -instance (Eq a)=> Eq (DirTree a) where +instance (Eq n, Eq a)=> Eq (DirTree n a) where (File n a) == (File n' a') = n == n' && a == a' (Dir n cs) == (Dir n' cs') = n == n' && sortBy comparingConstr cs == sortBy comparingConstr cs' @@ -191,7 +197,7 @@ instance (Eq a)=> Eq (DirTree a) where -- | First compare constructors: Failed < Dir < File... -- Then compare `name`... -- Then compare free variable parameter of `File` constructors -instance (Ord a,Eq a) => Ord (DirTree a) where +instance (Ord n, Ord a, Eq n, Eq a) => Ord (DirTree n a) where compare (File n a) (File n' a') = case compare n n' of EQ -> compare a a' @@ -209,21 +215,25 @@ instance (Ord a,Eq a) => Ord (DirTree a) where -- absolute or relative path. This lets us give the DirTree a context, while -- still letting us store only directory and file /names/ (not full paths) in -- the DirTree. (uses an infix constructor; don't be scared) -data AnchoredDirTree a = (:/) { anchor :: FilePath, dirTree :: DirTree a } +data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } deriving (Show, Ord, Eq) -- | an element in a FilePath: type FileName = String +-- TODO what's illegal about this? +instance TreeName String where + fp2n = id + n2fp = id -instance Functor DirTree where +instance Functor (DirTree n) where fmap = T.fmapDefault -instance F.Foldable DirTree where +instance F.Foldable (DirTree n) where foldMap = T.foldMapDefault -instance T.Traversable DirTree where +instance T.Traversable (DirTree n) where traverse f (Dir n cs) = Dir n <$> T.traverse (T.traverse f) cs traverse f (File n a) = File n <$> f a traverse _ (Failed n e) = pure (Failed n e) @@ -231,7 +241,7 @@ instance T.Traversable DirTree where -- for convenience: -instance Functor AnchoredDirTree where +instance Functor (AnchoredDirTree n) where fmap f (b:/d) = b :/ fmap f d @@ -263,7 +273,7 @@ readDirectory = readDirectoryWith readFile -- > readDirectoryWith return "../tmp" -- -- Note though that the 'build' function below already does this. -readDirectoryWith :: (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree a) +readDirectoryWith :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree a) readDirectoryWith f p = buildWith' buildAtOnce' f p @@ -275,17 +285,17 @@ readDirectoryWith f p = buildWith' buildAtOnce' f p -- -- * side effects are tied to evaluation order and only run on demand -- * you might receive exceptions in pure code -readDirectoryWithL :: (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree a) +readDirectoryWithL :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree a) readDirectoryWithL f p = buildWith' buildLazilyUnsafe' f p -- | Generate a string that represents tree command-like output for a -- given DirTree. -- Instances of Failed will be removed from the tree before it is displayed. -- Use showTreeFormatted to apply formatting to the output. -showTree :: DirTree a -> String +showTree :: TreeName n => DirTree n a -> String showTree tree = let treeNoFailed = filterDir notFailed tree - nameOnlyF = \x -> name x + nameOnlyF = \x -> n2fp $ name x treeM = showTree' nameOnlyF "" True treeNoFailed in fromMaybe "" treeM where notFailed (Failed _ _) = False @@ -297,7 +307,7 @@ showTree tree = -- objects within the tree to be customized. -- If combined with a package such as ansi-terminal, this allows the tree -- output to be colourized. -showTreeFormatted :: (DirTree a -> String) -> DirTree a -> String +showTreeFormatted :: (DirTree n a -> String) -> DirTree n a -> String showTreeFormatted formatF tree = let treeNoFailed = filterDir notFailed tree treeM = showTree' formatF "" True treeNoFailed @@ -315,7 +325,7 @@ substituteJoiner joiner str = then take (length str - indWidth) str <> (joiner:"──") else str -showTree' :: (DirTree a -> String) -> String -> Bool -> DirTree a -> Maybe String +showTree' :: (DirTree n a -> String) -> String -> Bool -> DirTree n a -> Maybe String showTree' formatF prelimStr isLast dir@(Dir nm conts) = let joiner = if isLast then '└' else '├' thisLineStr = substituteJoiner joiner prelimStr @@ -337,7 +347,7 @@ showTree' _ _ _ (Failed _ _) = error "Cannot showTree' for Failed" -- Doesn't affect files in the directories (if any already exist) with -- different names. Returns a new AnchoredDirTree where failures were -- lifted into a `Failed` constructor: -writeDirectory :: AnchoredDirTree String -> IO (AnchoredDirTree ()) +writeDirectory :: TreeName n => AnchoredDirTree n String -> IO (AnchoredDirTree n ()) writeDirectory = writeDirectoryWith writeFile @@ -346,10 +356,10 @@ writeDirectory = writeDirectoryWith writeFile -- become the new `contents` of the returned, where IO errors at each node are -- replaced with `Failed` constructors. The returned tree can be compared to -- the passed tree to see what operations, if any, failed: -writeDirectoryWith :: (FilePath -> a -> IO b) -> AnchoredDirTree a -> IO (AnchoredDirTree b) +writeDirectoryWith :: TreeName n => (n -> a -> IO b) -> AnchoredDirTree n a -> IO (AnchoredDirTree n b) writeDirectoryWith f (b:/t) = (b:/) <$> write' b t where write' b' (File n a) = handleDT n $ - File n <$> f (b'n) a + File n <$> f ( (n2fp b') (n2fp n) ) a write' b' (Dir n cs) = handleDT n $ do let bas = b'n createDirectoryIfMissing True bas @@ -367,7 +377,7 @@ writeDirectoryWith f (b:/t) = (b:/) <$> write' b t -- | a simple application of readDirectoryWith openFile: -openDirectory :: FilePath -> IOMode -> IO (AnchoredDirTree Handle) +openDirectory :: TreeName n => FilePath -> IOMode -> IO (AnchoredDirTree n Handle) openDirectory p m = readDirectoryWith (flip openFile m) p @@ -376,13 +386,13 @@ openDirectory p m = readDirectoryWith (flip openFile m) p -- the base directory in the Anchored* wrapper. Errors are caught in the tree in -- the Failed constructor. The 'file' fields initially are populated with full -- paths to the files they are abstracting. -build :: FilePath -> IO (AnchoredDirTree FilePath) +build :: TreeName n => FilePath -> IO (AnchoredDirTree n FilePath) build = buildWith' buildAtOnce' return -- we say 'return' here to get -- back a tree of FilePaths -- | identical to `build` but does directory reading IO lazily as needed: -buildL :: FilePath -> IO (AnchoredDirTree FilePath) +buildL :: TreeName n => FilePath -> IO (AnchoredDirTree n FilePath) buildL = buildWith' buildLazilyUnsafe' return @@ -392,11 +402,11 @@ buildL = buildWith' buildLazilyUnsafe' return type UserIO a = FilePath -> IO a -type Builder a = UserIO a -> FilePath -> IO (DirTree a) +type Builder n a = TreeName n => UserIO a -> FilePath -> IO (DirTree n a) -- remove non-existent file errors, which are artifacts of the "non-atomic" -- nature of traversing a system directory tree: -buildWith' :: Builder a -> UserIO a -> FilePath -> IO (AnchoredDirTree a) +buildWith' :: TreeName n => Builder a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) buildWith' bf' f p = do tree <- bf' f p return (baseDir p :/ removeNonexistent tree) From fe0d8cd8093a98870b6c25ecb9a018b1431806db Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 17:17:11 -0700 Subject: [PATCH 07/21] wip start adding s parameter --- System/Directory/Tree.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index f720c03..e9a0f73 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} -------------------------------------------------------------------- -- | -- Module : System.Directory.Tree @@ -164,8 +165,12 @@ import System.IO.Unsafe(unsafeInterleaveIO) import Control.Applicative #endif --- TODO add a join function to avoid packing + unpacking? --- TODO wait can I just use IsString instead? +-- | A typclass for things that can be converted to and from FilePaths (Strings). +-- You would expect `IsString` to work this way, but it only provides half. +-- And `Show` is problematic too. +-- TODO is there anything built in that does this properly? +-- TODO add a join function to avoid unpacking + packing for path conversions? +-- TODO need a newtype to get around the FilePath being a list thing class TreeName a where fp2n :: FilePath -> a n2fp :: a -> FilePath @@ -219,7 +224,9 @@ data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } deriving (Show, Ord, Eq) --- | an element in a FilePath: +-- | an element in a FilePath. +-- TODO newtype wrapper here rather than using FlexibleInstances? +-- https://stackoverflow.com/a/8663534 type FileName = String -- TODO what's illegal about this? @@ -402,7 +409,7 @@ buildL = buildWith' buildLazilyUnsafe' return type UserIO a = FilePath -> IO a -type Builder n a = TreeName n => UserIO a -> FilePath -> IO (DirTree n a) +type Builder n a = UserIO a -> FilePath -> IO (DirTree n a) -- remove non-existent file errors, which are artifacts of the "non-atomic" -- nature of traversing a system directory tree: From 3df92f83c4f0f703be2f7c43082bd8900aaed0d5 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 17:47:15 -0700 Subject: [PATCH 08/21] wip adding TreeName typeclass --- System/Directory/Tree.hs | 76 ++++++++++++++++++++-------------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index e9a0f73..b62ede3 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -217,7 +217,7 @@ instance (Ord n, Ord a, Eq n, Eq a) => Ord (DirTree n a) where -- | a simple wrapper to hold a base directory name, which can be either an --- absolute or relative path. This lets us give the DirTree a context, while +-- absolute or relative path. This lets us give the DirTree n a context, while -- still letting us store only directory and file /names/ (not full paths) in -- the DirTree. (uses an infix constructor; don't be scared) data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } @@ -266,7 +266,7 @@ infixl 4 -- Uses @readDirectoryWith readFile@ internally and has the effect of traversing the -- entire directory structure. See `readDirectoryWithL` for lazy production -- of a DirTree structure. -readDirectory :: FilePath -> IO (AnchoredDirTree String) +readDirectory :: TreeName n => FilePath -> IO (AnchoredDirTree n String) readDirectory = readDirectoryWith readFile @@ -280,7 +280,7 @@ readDirectory = readDirectoryWith readFile -- > readDirectoryWith return "../tmp" -- -- Note though that the 'build' function below already does this. -readDirectoryWith :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree a) +readDirectoryWith :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWith f p = buildWith' buildAtOnce' f p @@ -292,7 +292,7 @@ readDirectoryWith f p = buildWith' buildAtOnce' f p -- -- * side effects are tied to evaluation order and only run on demand -- * you might receive exceptions in pure code -readDirectoryWithL :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree a) +readDirectoryWithL :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWithL f p = buildWith' buildLazilyUnsafe' f p -- | Generate a string that represents tree command-like output for a @@ -413,7 +413,7 @@ type Builder n a = UserIO a -> FilePath -> IO (DirTree n a) -- remove non-existent file errors, which are artifacts of the "non-atomic" -- nature of traversing a system directory tree: -buildWith' :: TreeName n => Builder a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) +buildWith' :: TreeName n => Builder n a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) buildWith' bf' f p = do tree <- bf' f p return (baseDir p :/ removeNonexistent tree) @@ -421,7 +421,7 @@ buildWith' bf' f p = -- IO function passed to our builder and finally executed here: -buildAtOnce' :: Builder a +buildAtOnce' :: Builder n a buildAtOnce' f p = handleDT n $ do isFile <- doesFileExist p if isFile @@ -442,7 +442,7 @@ unsafeMapM f (x:xs) = unsafeInterleaveIO io -- using unsafeInterleaveIO to get "lazy" traversal: -buildLazilyUnsafe' :: Builder a +buildLazilyUnsafe' :: Builder n a buildLazilyUnsafe' f p = handleDT n $ do isFile <- doesFileExist p if isFile @@ -470,27 +470,27 @@ buildLazilyUnsafe' f p = handleDT n $ -- | True if any Failed constructors in the tree -anyFailed :: DirTree a -> Bool +anyFailed :: DirTree n a -> Bool anyFailed = not . successful -- | True if there are no Failed constructors in the tree -successful :: DirTree a -> Bool +successful :: DirTree n a -> Bool successful = null . failures -- | returns true if argument is a `Failed` constructor: -failed :: DirTree a -> Bool +failed :: DirTree n a -> Bool failed (Failed _ _) = True failed _ = False -- | returns a list of 'Failed' constructors only: -failures :: DirTree a -> [DirTree a] +failures :: DirTree n a -> [DirTree n a] failures = filter failed . flattenDir -- | maps a function to convert Failed DirTrees to Files or Dirs -failedMap :: (FileName -> IOException -> DirTree a) -> DirTree a -> DirTree a +failedMap :: (FileName -> IOException -> DirTree n a) -> DirTree n a -> DirTree n a failedMap f = transformDir unFail where unFail (Failed n e) = f n e unFail c = c @@ -500,16 +500,16 @@ failedMap f = transformDir unFail -- | Recursively sort a directory tree according to the Ord instance -sortDir :: (Ord a)=> DirTree a -> DirTree a +sortDir :: (Ord a)=> DirTree n a -> DirTree n a sortDir = sortDirBy compare -- | Recursively sort a tree as in `sortDir` but ignore the file contents of a -- File constructor -sortDirShape :: DirTree a -> DirTree a +sortDirShape :: DirTree n a -> DirTree n a sortDirShape = sortDirBy comparingShape where -- HELPER: -sortDirBy :: (DirTree a -> DirTree a -> Ordering) -> DirTree a -> DirTree a +sortDirBy :: (DirTree n a -> DirTree n a -> Ordering) -> DirTree n a -> DirTree n a sortDirBy cf = transformDir sortD where sortD (Dir n cs) = Dir n (sortBy cf cs) sortD c = c @@ -517,13 +517,13 @@ sortDirBy cf = transformDir sortD -- | Tests equality of two trees, ignoring their free variable portion. Can be -- used to check if any files have been added or deleted, for instance. -equalShape :: DirTree a -> DirTree b -> Bool +equalShape :: DirTree n a -> DirTree n b -> Bool equalShape d d' = comparingShape d d' == EQ -- TODO: we should use equalFilePath here, but how to sort properly? with System.Directory.canonicalizePath, before compare? -- | a compare function that ignores the free "file" type variable: -comparingShape :: DirTree a -> DirTree b -> Ordering +comparingShape :: DirTree n a -> DirTree n b -> Ordering comparingShape (Dir n cs) (Dir n' cs') = case compare n n' of EQ -> comp (sortCs cs) (sortCs cs') @@ -541,7 +541,7 @@ comparingShape t t' = comparingConstr t t' -- HELPER: a non-recursive comparison -comparingConstr :: DirTree a -> DirTree a1 -> Ordering +comparingConstr :: DirTree n a -> DirTree n a1 -> Ordering comparingConstr (Failed _ _) (Dir _ _) = LT comparingConstr (Failed _ _) (File _ _) = LT comparingConstr (File _ _) (Failed _ _) = GT @@ -559,13 +559,13 @@ comparingConstr t t' = compare (name t) (name t') {-# DEPRECATED free "Use record 'dirTree'" #-} -- | DEPRECATED. Use record 'dirTree' instead. -free :: AnchoredDirTree a -> DirTree a +free :: AnchoredDirTree n a -> DirTree n a free = dirTree -- | If the argument is a 'Dir' containing a sub-DirTree matching 'FileName' -- then return that subtree, appending the 'name' of the old root 'Dir' to the -- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@. -dropTo :: FileName -> AnchoredDirTree a -> Maybe (AnchoredDirTree a) +dropTo :: FileName -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) dropTo n' (p :/ Dir n ds') = search ds' where search [] = Nothing search (d:ds) | equalFilePath n' (name d) = Just ((pn) :/ d) @@ -576,7 +576,7 @@ dropTo _ _ = Nothing -- | applies the predicate to each constructor in the tree, removing it (and -- its children, of course) when the predicate returns False. The topmost -- constructor will always be preserved: -filterDir :: (DirTree a -> Bool) -> DirTree a -> DirTree a +filterDir :: (DirTree n a -> Bool) -> DirTree n a -> DirTree n a filterDir p = transformDir filterD where filterD (Dir n cs) = Dir n $ filter p cs filterD c = c @@ -584,7 +584,7 @@ filterDir p = transformDir filterD -- | Flattens a `DirTree` into a (never empty) list of tree constructors. `Dir` -- constructors will have [] as their `contents`: -flattenDir :: DirTree a -> [ DirTree a ] +flattenDir :: DirTree n a -> [ DirTree n a ] flattenDir (Dir n cs) = Dir n [] : concatMap flattenDir cs flattenDir f = [f] @@ -594,8 +594,8 @@ flattenDir f = [f] -- | Allows for a function on a bare DirTree to be applied to an AnchoredDirTree -- within a Functor. Very similar to and useful in combination with `<$>`: -() :: (Functor f) => (DirTree a -> DirTree b) -> f (AnchoredDirTree a) -> - f (AnchoredDirTree b) +() :: (Functor f) => (DirTree n a -> DirTree n b) -> f (AnchoredDirTree n a) -> + f (AnchoredDirTree n b) () f = fmap (\(b :/ t) -> b :/ f t) @@ -606,11 +606,11 @@ flattenDir f = [f] ---- CONSTRUCTOR IDENTIFIERS ---- {- -isFileC :: DirTree a -> Bool +isFileC :: DirTree n a -> Bool isFileC (File _ _) = True isFileC _ = False -isDirC :: DirTree a -> Bool +isDirC :: DirTree n a -> Bool isDirC (Dir _ _) = True isDirC _ = False -} @@ -626,7 +626,7 @@ isDirC _ = False -- -- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of -- strings, although 'writeDirectory' does a better job of this. -zipPaths :: AnchoredDirTree a -> DirTree (FilePath, a) +zipPaths :: AnchoredDirTree n a -> DirTree (FilePath, a) zipPaths (b :/ t) = zipP b t where zipP p (File n a) = File n (pn , a) zipP p (Dir n cs) = Dir n $ map (zipP $ pn) cs @@ -646,7 +646,7 @@ baseDir = joinPath . init . splitDirectories -- | writes the directory structure (not files) of a DirTree to the anchored -- directory. Returns a structure identical to the supplied tree with errors -- replaced by `Failed` constructors: -writeJustDirs :: AnchoredDirTree a -> IO (AnchoredDirTree a) +writeJustDirs :: AnchoredDirTree n a -> IO (AnchoredDirTree n a) writeJustDirs = writeDirectoryWith (const return) @@ -666,7 +666,7 @@ getDirsFiles cs = do let cs' = if null cs then "." else cs -- handles an IO exception by returning a Failed constructor filled with that -- exception: -handleDT :: FileName -> IO (DirTree a) -> IO (DirTree a) +handleDT :: TreeName n => FileName -> IO (DirTree n a) -> IO (DirTree n a) handleDT n = handle (return . Failed n) @@ -676,7 +676,7 @@ handleDT n = handle (return . Failed n) -- So we filter those errors out because the user should not see errors -- raised by the internal implementation of this module: -- This leaves the error if it exists in the top (user-supplied) level: -removeNonexistent :: DirTree a -> DirTree a +removeNonexistent :: DirTree n a -> DirTree n a removeNonexistent = filterDir isOkConstructor where isOkConstructor c = not (failed c) || isOkError c isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err @@ -685,7 +685,7 @@ removeNonexistent = filterDir isOkConstructor -- | At 'Dir' constructor, apply transformation function to all of directory's -- contents, then remove the Nothing's and recurse. This always preserves the -- topomst constructor. -transformDir :: (DirTree a -> DirTree a) -> DirTree a -> DirTree a +transformDir :: (DirTree n a -> DirTree n a) -> DirTree n a -> DirTree n a transformDir f t = case f t of (Dir n cs) -> Dir n $ map (transformDir f) cs t' -> t' @@ -695,29 +695,29 @@ transformDir f t = case f t of -- for users to generate their own lenses. _contents :: Applicative f => - ([DirTree a] -> f [DirTree a]) -> DirTree a -> f (DirTree a) + ([DirTree n a] -> f [DirTree n a]) -> DirTree n a -> f (DirTree n a) _err :: Applicative f => - (IOException -> f IOException) -> DirTree a -> f (DirTree a) + (IOException -> f IOException) -> DirTree n a -> f (DirTree n a) _file :: Applicative f => - (a -> f a) -> DirTree a -> f (DirTree a) + (a -> f a) -> DirTree n a -> f (DirTree n a) _name :: Functor f => - (FileName -> f FileName) -> DirTree a -> f (DirTree a) + (FileName -> f FileName) -> DirTree n a -> f (DirTree n a) _anchor :: Functor f => (FilePath -> f FilePath) - -> AnchoredDirTree a -> f (AnchoredDirTree a) + -> AnchoredDirTree n a -> f (AnchoredDirTree n a) _dirTree :: Functor f => - (DirTree t -> f (DirTree a)) - -> AnchoredDirTree t -> f (AnchoredDirTree a) + (DirTree t -> f (DirTree n a)) + -> AnchoredDirTree t -> f (AnchoredDirTree n a) --makeLensesFor [("name","_name"),("err","_err"),("contents","_contents"),("file","_file")] ''DirTree _contents _f_a6s2 (Failed _name_a6s3 _err_a6s4) From cfd5c430d25de713c12b59dbc26f83fdd188c356 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 18:10:41 -0700 Subject: [PATCH 09/21] wip on TreeName typeclass --- System/Directory/Tree.hs | 168 ++++++++++++++++++++------------------- 1 file changed, 87 insertions(+), 81 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index b62ede3..1b2cdd6 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -172,9 +172,14 @@ import Control.Applicative -- TODO add a join function to avoid unpacking + packing for path conversions? -- TODO need a newtype to get around the FilePath being a list thing class TreeName a where + fp2n :: FilePath -> a + n2fp :: a -> FilePath + join :: a -> a -> a + join p n = fp2n $ (n2fp p) (n2fp n) + -- | the String in the name field is always a file name, never a full path. -- The free type variable is used in the File constructor and can hold Handles, -- Strings representing a file's contents or anything else you can think of. @@ -229,8 +234,8 @@ data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } -- https://stackoverflow.com/a/8663534 type FileName = String --- TODO what's illegal about this? -instance TreeName String where +-- TODO does anyone mind that this requires FlexibleInstances? +instance TreeName FilePath where fp2n = id n2fp = id @@ -266,7 +271,7 @@ infixl 4 -- Uses @readDirectoryWith readFile@ internally and has the effect of traversing the -- entire directory structure. See `readDirectoryWithL` for lazy production -- of a DirTree structure. -readDirectory :: TreeName n => FilePath -> IO (AnchoredDirTree n String) +readDirectory :: FilePath -> IO (AnchoredDirTree FilePath String) readDirectory = readDirectoryWith readFile @@ -500,16 +505,16 @@ failedMap f = transformDir unFail -- | Recursively sort a directory tree according to the Ord instance -sortDir :: (Ord a)=> DirTree n a -> DirTree n a +sortDir :: (Ord n, Ord a)=> DirTree n a -> DirTree n a sortDir = sortDirBy compare -- | Recursively sort a tree as in `sortDir` but ignore the file contents of a -- File constructor -sortDirShape :: DirTree n a -> DirTree n a +sortDirShape :: (Ord n) => DirTree n a -> DirTree n a sortDirShape = sortDirBy comparingShape where -- HELPER: -sortDirBy :: (DirTree n a -> DirTree n a -> Ordering) -> DirTree n a -> DirTree n a +sortDirBy :: (Ord n) => (DirTree n a -> DirTree n a -> Ordering) -> DirTree n a -> DirTree n a sortDirBy cf = transformDir sortD where sortD (Dir n cs) = Dir n (sortBy cf cs) sortD c = c @@ -517,13 +522,13 @@ sortDirBy cf = transformDir sortD -- | Tests equality of two trees, ignoring their free variable portion. Can be -- used to check if any files have been added or deleted, for instance. -equalShape :: DirTree n a -> DirTree n b -> Bool +equalShape :: (Eq n, Ord n) => DirTree n a -> DirTree n b -> Bool equalShape d d' = comparingShape d d' == EQ -- TODO: we should use equalFilePath here, but how to sort properly? with System.Directory.canonicalizePath, before compare? -- | a compare function that ignores the free "file" type variable: -comparingShape :: DirTree n a -> DirTree n b -> Ordering +comparingShape :: (Eq n, Ord n) => DirTree n a -> DirTree n b -> Ordering comparingShape (Dir n cs) (Dir n' cs') = case compare n n' of EQ -> comp (sortCs cs) (sortCs cs') @@ -541,7 +546,8 @@ comparingShape t t' = comparingConstr t t' -- HELPER: a non-recursive comparison -comparingConstr :: DirTree n a -> DirTree n a1 -> Ordering +-- TODO should the constraint here be TreeName n? +comparingConstr :: (Eq n, Ord n) => DirTree n a -> DirTree n a1 -> Ordering comparingConstr (Failed _ _) (Dir _ _) = LT comparingConstr (Failed _ _) (File _ _) = LT comparingConstr (File _ _) (Failed _ _) = GT @@ -565,10 +571,10 @@ free = dirTree -- | If the argument is a 'Dir' containing a sub-DirTree matching 'FileName' -- then return that subtree, appending the 'name' of the old root 'Dir' to the -- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@. -dropTo :: FileName -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) +dropTo :: TreeName n => n -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) dropTo n' (p :/ Dir n ds') = search ds' where search [] = Nothing - search (d:ds) | equalFilePath n' (name d) = Just ((pn) :/ d) + search (d:ds) | equalFilePath (n2fp n') (n2fp $ name d) = Just ((join p n) :/ d) | otherwise = search ds dropTo _ _ = Nothing @@ -626,10 +632,10 @@ isDirC _ = False -- -- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of -- strings, although 'writeDirectory' does a better job of this. -zipPaths :: AnchoredDirTree n a -> DirTree (FilePath, a) +zipPaths :: TreeName n => AnchoredDirTree n a -> DirTree n (n, a) zipPaths (b :/ t) = zipP b t - where zipP p (File n a) = File n (pn , a) - zipP p (Dir n cs) = Dir n $ map (zipP $ pn) cs + where zipP p (File n a) = File n (join p n, a) + zipP p (Dir n cs) = Dir n $ map (zipP $ join p n) cs zipP _ (Failed n e) = Failed n e @@ -646,7 +652,7 @@ baseDir = joinPath . init . splitDirectories -- | writes the directory structure (not files) of a DirTree to the anchored -- directory. Returns a structure identical to the supplied tree with errors -- replaced by `Failed` constructors: -writeJustDirs :: AnchoredDirTree n a -> IO (AnchoredDirTree n a) +writeJustDirs :: TreeName n => AnchoredDirTree n a -> IO (AnchoredDirTree n a) writeJustDirs = writeDirectoryWith (const return) @@ -666,7 +672,7 @@ getDirsFiles cs = do let cs' = if null cs then "." else cs -- handles an IO exception by returning a Failed constructor filled with that -- exception: -handleDT :: TreeName n => FileName -> IO (DirTree n a) -> IO (DirTree n a) +handleDT :: TreeName n => n -> IO (DirTree n a) -> IO (DirTree n a) handleDT n = handle (return . Failed n) @@ -693,68 +699,68 @@ transformDir f t = case f t of -- Lenses, generated with TH from "lens" ----------- -- TODO deprecate these? Pain in the ass to generate, and maybe it's intended -- for users to generate their own lenses. -_contents :: - Applicative f => - ([DirTree n a] -> f [DirTree n a]) -> DirTree n a -> f (DirTree n a) - -_err :: - Applicative f => - (IOException -> f IOException) -> DirTree n a -> f (DirTree n a) - -_file :: - Applicative f => - (a -> f a) -> DirTree n a -> f (DirTree n a) - -_name :: - Functor f => - (FileName -> f FileName) -> DirTree n a -> f (DirTree n a) - -_anchor :: - Functor f => - (FilePath -> f FilePath) - -> AnchoredDirTree n a -> f (AnchoredDirTree n a) - -_dirTree :: - Functor f => - (DirTree t -> f (DirTree n a)) - -> AnchoredDirTree t -> f (AnchoredDirTree n a) - ---makeLensesFor [("name","_name"),("err","_err"),("contents","_contents"),("file","_file")] ''DirTree -_contents _f_a6s2 (Failed _name_a6s3 _err_a6s4) - = pure (Failed _name_a6s3 _err_a6s4) -_contents _f_a6s5 (Dir _name_a6s6 _contents'_a6s7) - = ((\ _contents_a6s8 -> Dir _name_a6s6 _contents_a6s8) - <$> (_f_a6s5 _contents'_a6s7)) -_contents _f_a6s9 (File _name_a6sa _file_a6sb) - = pure (File _name_a6sa _file_a6sb) -_err _f_a6sd (Failed _name_a6se _err'_a6sf) - = ((\ _err_a6sg -> Failed _name_a6se _err_a6sg) - <$> (_f_a6sd _err'_a6sf)) -_err _f_a6sh (Dir _name_a6si _contents_a6sj) - = pure (Dir _name_a6si _contents_a6sj) -_err _f_a6sk (File _name_a6sl _file_a6sm) - = pure (File _name_a6sl _file_a6sm) -_file _f_a6so (Failed _name_a6sp _err_a6sq) - = pure (Failed _name_a6sp _err_a6sq) -_file _f_a6sr (Dir _name_a6ss _contents_a6st) - = pure (Dir _name_a6ss _contents_a6st) -_file _f_a6su (File _name_a6sv _file'_a6sw) - = ((\ _file_a6sx -> File _name_a6sv _file_a6sx) - <$> (_f_a6su _file'_a6sw)) -_name _f_a6sz (Failed _name'_a6sA _err_a6sC) - = ((\ _name_a6sB -> Failed _name_a6sB _err_a6sC) - <$> (_f_a6sz _name'_a6sA)) -_name _f_a6sD (Dir _name'_a6sE _contents_a6sG) - = ((\ _name_a6sF -> Dir _name_a6sF _contents_a6sG) - <$> (_f_a6sD _name'_a6sE)) -_name _f_a6sH (File _name'_a6sI _file_a6sK) - = ((\ _name_a6sJ -> File _name_a6sJ _file_a6sK) - <$> (_f_a6sH _name'_a6sI)) - ---makeLensesFor [("anchor","_anchor"),("dirTree","_dirTree")] ''AnchoredDirTree -_anchor _f_a7wT (_anchor'_a7wU :/ _dirTree_a7wW) - = ((\ _anchor_a7wV -> (:/) _anchor_a7wV _dirTree_a7wW) - <$> (_f_a7wT _anchor'_a7wU)) -_dirTree _f_a7wZ (_anchor_a7x0 :/ _dirTree'_a7x1) - = ((\ _dirTree_a7x2 -> (:/) _anchor_a7x0 _dirTree_a7x2) - <$> (_f_a7wZ _dirTree'_a7x1)) +-- _contents :: +-- Applicative f => +-- ([DirTree n a] -> f [DirTree n a]) -> DirTree n a -> f (DirTree n a) +-- +-- _err :: +-- Applicative f => +-- (IOException -> f IOException) -> DirTree n a -> f (DirTree n a) +-- +-- _file :: +-- Applicative f => +-- (a -> f a) -> DirTree n a -> f (DirTree n a) +-- +-- _name :: +-- Functor f => +-- (FileName -> f FileName) -> DirTree n a -> f (DirTree n a) +-- +-- _anchor :: +-- Functor f => +-- (FilePath -> f FilePath) +-- -> AnchoredDirTree n a -> f (AnchoredDirTree n a) +-- +-- _dirTree :: +-- Functor f => +-- (DirTree n t -> f (DirTree n a)) +-- -> AnchoredDirTree n t -> f (AnchoredDirTree n a) +-- +-- --makeLensesFor [("name","_name"),("err","_err"),("contents","_contents"),("file","_file")] ''DirTree +-- _contents _f_a6s2 (Failed _name_a6s3 _err_a6s4) +-- = pure (Failed _name_a6s3 _err_a6s4) +-- _contents _f_a6s5 (Dir _name_a6s6 _contents'_a6s7) +-- = ((\ _contents_a6s8 -> Dir _name_a6s6 _contents_a6s8) +-- <$> (_f_a6s5 _contents'_a6s7)) +-- _contents _f_a6s9 (File _name_a6sa _file_a6sb) +-- = pure (File _name_a6sa _file_a6sb) +-- _err _f_a6sd (Failed _name_a6se _err'_a6sf) +-- = ((\ _err_a6sg -> Failed _name_a6se _err_a6sg) +-- <$> (_f_a6sd _err'_a6sf)) +-- _err _f_a6sh (Dir _name_a6si _contents_a6sj) +-- = pure (Dir _name_a6si _contents_a6sj) +-- _err _f_a6sk (File _name_a6sl _file_a6sm) +-- = pure (File _name_a6sl _file_a6sm) +-- _file _f_a6so (Failed _name_a6sp _err_a6sq) +-- = pure (Failed _name_a6sp _err_a6sq) +-- _file _f_a6sr (Dir _name_a6ss _contents_a6st) +-- = pure (Dir _name_a6ss _contents_a6st) +-- _file _f_a6su (File _name_a6sv _file'_a6sw) +-- = ((\ _file_a6sx -> File _name_a6sv _file_a6sx) +-- <$> (_f_a6su _file'_a6sw)) +-- _name _f_a6sz (Failed _name'_a6sA _err_a6sC) +-- = ((\ _name_a6sB -> Failed _name_a6sB _err_a6sC) +-- <$> (_f_a6sz _name'_a6sA)) +-- _name _f_a6sD (Dir _name'_a6sE _contents_a6sG) +-- = ((\ _name_a6sF -> Dir _name_a6sF _contents_a6sG) +-- <$> (_f_a6sD _name'_a6sE)) +-- _name _f_a6sH (File _name'_a6sI _file_a6sK) +-- = ((\ _name_a6sJ -> File _name_a6sJ _file_a6sK) +-- <$> (_f_a6sH _name'_a6sI)) +-- +-- --makeLensesFor [("anchor","_anchor"),("dirTree","_dirTree")] ''AnchoredDirTree +-- _anchor _f_a7wT (_anchor'_a7wU :/ _dirTree_a7wW) +-- = ((\ _anchor_a7wV -> (:/) _anchor_a7wV _dirTree_a7wW) +-- <$> (_f_a7wT _anchor'_a7wU)) +-- _dirTree _f_a7wZ (_anchor_a7x0 :/ _dirTree'_a7x1) +-- = ((\ _dirTree_a7x2 -> (:/) _anchor_a7x0 _dirTree_a7x2) +-- <$> (_f_a7wZ _dirTree'_a7x1)) From e6209a90ccf8295f742363ce441fee8a68d03ec8 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 18:15:17 -0700 Subject: [PATCH 10/21] wip on TreeName typeclass --- System/Directory/Tree.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 1b2cdd6..08d2357 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -389,7 +389,7 @@ writeDirectoryWith f (b:/t) = (b:/) <$> write' b t -- | a simple application of readDirectoryWith openFile: -openDirectory :: TreeName n => FilePath -> IOMode -> IO (AnchoredDirTree n Handle) +openDirectory :: FilePath -> IOMode -> IO (AnchoredDirTree FilePath Handle) openDirectory p m = readDirectoryWith (flip openFile m) p @@ -421,19 +421,19 @@ type Builder n a = UserIO a -> FilePath -> IO (DirTree n a) buildWith' :: TreeName n => Builder n a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) buildWith' bf' f p = do tree <- bf' f p - return (baseDir p :/ removeNonexistent tree) + return (fp2n (baseDir p) :/ removeNonexistent tree) -- IO function passed to our builder and finally executed here: -buildAtOnce' :: Builder n a +buildAtOnce' :: TreeName n => Builder n a buildAtOnce' f p = handleDT n $ do isFile <- doesFileExist p if isFile then File n <$> f p else do cs <- getDirsFiles p Dir n <$> T.mapM (buildAtOnce' f . combine p) cs - where n = topDir p + where n = fp2n $ topDir p unsafeMapM :: (a -> IO b) -> [a] -> IO [b] @@ -447,7 +447,7 @@ unsafeMapM f (x:xs) = unsafeInterleaveIO io -- using unsafeInterleaveIO to get "lazy" traversal: -buildLazilyUnsafe' :: Builder n a +buildLazilyUnsafe' :: TreeName n => Builder n a buildLazilyUnsafe' f p = handleDT n $ do isFile <- doesFileExist p if isFile @@ -460,7 +460,7 @@ buildLazilyUnsafe' f p = handleDT n $ return (Dir n dirTrees) where rec = buildLazilyUnsafe' f - n = topDir p + n = fp2n $ topDir p @@ -495,7 +495,7 @@ failures = filter failed . flattenDir -- | maps a function to convert Failed DirTrees to Files or Dirs -failedMap :: (FileName -> IOException -> DirTree n a) -> DirTree n a -> DirTree n a +failedMap :: TreeName n => (n -> IOException -> DirTree n a) -> DirTree n a -> DirTree n a failedMap f = transformDir unFail where unFail (Failed n e) = f n e unFail c = c From c791558674774d5c8a2c998a126ac06fe05d7a58 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 18:17:56 -0700 Subject: [PATCH 11/21] wip on TreeName typeclass --- System/Directory/Tree.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 08d2357..738d717 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -359,7 +359,8 @@ showTree' _ _ _ (Failed _ _) = error "Cannot showTree' for Failed" -- Doesn't affect files in the directories (if any already exist) with -- different names. Returns a new AnchoredDirTree where failures were -- lifted into a `Failed` constructor: -writeDirectory :: TreeName n => AnchoredDirTree n String -> IO (AnchoredDirTree n ()) +-- TODO less specialized version of this? +writeDirectory :: AnchoredDirTree FilePath String -> IO (AnchoredDirTree FilePath ()) writeDirectory = writeDirectoryWith writeFile @@ -371,10 +372,10 @@ writeDirectory = writeDirectoryWith writeFile writeDirectoryWith :: TreeName n => (n -> a -> IO b) -> AnchoredDirTree n a -> IO (AnchoredDirTree n b) writeDirectoryWith f (b:/t) = (b:/) <$> write' b t where write' b' (File n a) = handleDT n $ - File n <$> f ( (n2fp b') (n2fp n) ) a + File n <$> f (join b' n) a write' b' (Dir n cs) = handleDT n $ - do let bas = b'n - createDirectoryIfMissing True bas + do let bas = join b' n + createDirectoryIfMissing True $ n2fp bas Dir n <$> mapM (write' bas) cs write' _ (Failed n e) = return $ Failed n e From c87df8adca2d3781747cd2343b0f7c4eb4d0009e Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 18:18:22 -0700 Subject: [PATCH 12/21] wip on TreeName typeclass --- System/Directory/Tree.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 738d717..adba66e 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -297,7 +297,7 @@ readDirectoryWith f p = buildWith' buildAtOnce' f p -- -- * side effects are tied to evaluation order and only run on demand -- * you might receive exceptions in pure code -readDirectoryWithL :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree n a) +readDirectoryWithL :: TreeName n => (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWithL f p = buildWith' buildLazilyUnsafe' f p -- | Generate a string that represents tree command-like output for a From 94467faaafd83b7e363ccaa783875bdb22b2c618 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 18:19:47 -0700 Subject: [PATCH 13/21] wip on TreeName typeclass --- System/Directory/Tree.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index adba66e..c657d4a 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -285,7 +285,7 @@ readDirectory = readDirectoryWith readFile -- > readDirectoryWith return "../tmp" -- -- Note though that the 'build' function below already does this. -readDirectoryWith :: TreeName n => (n -> IO a) -> FilePath -> IO (AnchoredDirTree n a) +readDirectoryWith :: TreeName n => UserIO a -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWith f p = buildWith' buildAtOnce' f p @@ -297,7 +297,7 @@ readDirectoryWith f p = buildWith' buildAtOnce' f p -- -- * side effects are tied to evaluation order and only run on demand -- * you might receive exceptions in pure code -readDirectoryWithL :: TreeName n => (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree n a) +readDirectoryWithL :: TreeName n => UserIO a -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWithL f p = buildWith' buildLazilyUnsafe' f p -- | Generate a string that represents tree command-like output for a From daae7fb9b0d3c8cdc2d0a1aa31f75c8614824254 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 18:20:50 -0700 Subject: [PATCH 14/21] got it compiling --- System/Directory/Tree.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index c657d4a..0b8f028 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -83,8 +83,8 @@ module System.Directory.Tree ( -- * Lenses {- | These are compatible with the "lens" library -} - , _contents, _err, _file, _name - , _anchor, _dirTree + -- , _contents, _err, _file, _name + -- , _anchor, _dirTree ) where @@ -196,7 +196,7 @@ data DirTree n a = Failed { name :: n, -- | Two DirTrees are equal if they have the same constructor, the same name -- (and in the case of `Dir`s) their sorted `contents` are equal: -instance (Eq n, Eq a)=> Eq (DirTree n a) where +instance (Eq n, Ord n, Eq a)=> Eq (DirTree n a) where (File n a) == (File n' a') = n == n' && a == a' (Dir n cs) == (Dir n' cs') = n == n' && sortBy comparingConstr cs == sortBy comparingConstr cs' From d694c11f7e922de50ee657ec8acc2f5ebd97b9cc Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 19:45:53 -0700 Subject: [PATCH 15/21] export TreeName --- System/Directory/Tree.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 0b8f028..9f04280 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -37,6 +37,7 @@ module System.Directory.Tree ( -- * Data types for representing directory trees DirTree (..) , AnchoredDirTree (..) + , TreeName (..) , FileName From 1011741f566eb2ce57760354d0e5b3558fa711e4 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 19:51:39 -0700 Subject: [PATCH 16/21] Test.hs annotate trees with FilePath names --- Test.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/Test.hs b/Test.hs index ebdc932..a15294e 100644 --- a/Test.hs +++ b/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Main where @@ -58,7 +60,7 @@ main = do -- run lazy fold, concating file contents. compare for equality: - tL_again <- sortDir readDirectoryWithL readFile testDir + (tL_again :: AnchoredDirTree FilePath String) <- sortDir readDirectoryWithL readFile testDir let tL_concated = F.concat $ dirTree tL_again if tL_concated == "abcdef" then return () else error "foldable broke" putStrLn "OK" @@ -71,9 +73,9 @@ main = do putStrLn "\nOK" - let undefinedOrdFailed = Failed undefined undefined :: DirTree Char - undefinedOrdDir = Dir undefined undefined :: DirTree Char - undefinedOrdFile = File undefined undefined :: DirTree Char + let undefinedOrdFailed = Failed undefined undefined :: DirTree FilePath Char + undefinedOrdDir = Dir undefined undefined :: DirTree FilePath Char + undefinedOrdFile = File undefined undefined :: DirTree FilePath Char -- simple equality and sorting if Dir "d" [File "b" "b",File "a" "a"] == Dir "d" [File "a" "a", File "b" "b"] && -- recursive sort order, enforces non-recursive sorting of Dirs @@ -139,7 +141,7 @@ main = do <> "directories, but tree string " <> dirsOnlyTestStr <> "has " <> (show dirsInStringCount) -testTree :: AnchoredDirTree String +testTree :: AnchoredDirTree FilePath String testTree = "" :/ Dir testDir [dA , dB , dC , Failed "FAAAIIILL" undefined] where dA = Dir "A" [dA1 , dA2 , Failed "FAIL" undefined] dA1 = Dir "A1" [File "A" "a", File "B" "b"] From da01718b00c817671dbfc3915ee47edd194ae801 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 20:19:58 -0700 Subject: [PATCH 17/21] todos --- todo.txt | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/todo.txt b/todo.txt index 591c1e0..d010afc 100644 --- a/todo.txt +++ b/todo.txt @@ -1,7 +1,3 @@ -typeclass idea: - make a TreeName class - instances need fns: - packName (start as fp2n) - unpackName (start as n2fp) - joinNames? (maybe later, with default to unpack, , pack again) - showName? (or can that just be unpackName?) +clean up the TreeName typeclass: + rename IsFileName, toFileName, fromFileName? + rename joinFileNames, and maybe add an infix version From 97f0cb6b630e2c0347a349e46901afd83311f4b5 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Fri, 26 Apr 2024 21:22:03 -0700 Subject: [PATCH 18/21] TreeName, fp2n, n2fp -> IsName, p2n, n2p --- System/Directory/Tree.hs | 69 +++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 36 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 9f04280..9cf97eb 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -37,7 +37,7 @@ module System.Directory.Tree ( -- * Data types for representing directory trees DirTree (..) , AnchoredDirTree (..) - , TreeName (..) + , IsName (..) , FileName @@ -166,20 +166,17 @@ import System.IO.Unsafe(unsafeInterleaveIO) import Control.Applicative #endif --- | A typclass for things that can be converted to and from FilePaths (Strings). --- You would expect `IsString` to work this way, but it only provides half. --- And `Show` is problematic too. --- TODO is there anything built in that does this properly? --- TODO add a join function to avoid unpacking + packing for path conversions? --- TODO need a newtype to get around the FilePath being a list thing -class TreeName a where +-- | A class of file names that can be converted to and from FilePaths (Strings). +-- TODO is there anything built in that does this properly? Not IsString or Show. +class IsName n where - fp2n :: FilePath -> a + p2n :: FilePath -> n - n2fp :: a -> FilePath + n2p :: n -> FilePath - join :: a -> a -> a - join p n = fp2n $ (n2fp p) (n2fp n) + -- TODO is this actually more like append, because the first one could be a path? + join :: n -> n -> n + join n1 n2 = p2n $ (n2p n1) (n2p n2) -- | the String in the name field is always a file name, never a full path. -- The free type variable is used in the File constructor and can hold Handles, @@ -236,9 +233,9 @@ data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } type FileName = String -- TODO does anyone mind that this requires FlexibleInstances? -instance TreeName FilePath where - fp2n = id - n2fp = id +instance IsName FilePath where + p2n = id + n2p = id instance Functor (DirTree n) where fmap = T.fmapDefault @@ -286,7 +283,7 @@ readDirectory = readDirectoryWith readFile -- > readDirectoryWith return "../tmp" -- -- Note though that the 'build' function below already does this. -readDirectoryWith :: TreeName n => UserIO a -> FilePath -> IO (AnchoredDirTree n a) +readDirectoryWith :: IsName n => UserIO a -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWith f p = buildWith' buildAtOnce' f p @@ -298,17 +295,17 @@ readDirectoryWith f p = buildWith' buildAtOnce' f p -- -- * side effects are tied to evaluation order and only run on demand -- * you might receive exceptions in pure code -readDirectoryWithL :: TreeName n => UserIO a -> FilePath -> IO (AnchoredDirTree n a) +readDirectoryWithL :: IsName n => UserIO a -> FilePath -> IO (AnchoredDirTree n a) readDirectoryWithL f p = buildWith' buildLazilyUnsafe' f p -- | Generate a string that represents tree command-like output for a -- given DirTree. -- Instances of Failed will be removed from the tree before it is displayed. -- Use showTreeFormatted to apply formatting to the output. -showTree :: TreeName n => DirTree n a -> String +showTree :: IsName n => DirTree n a -> String showTree tree = let treeNoFailed = filterDir notFailed tree - nameOnlyF = \x -> n2fp $ name x + nameOnlyF = \x -> n2p $ name x treeM = showTree' nameOnlyF "" True treeNoFailed in fromMaybe "" treeM where notFailed (Failed _ _) = False @@ -370,13 +367,13 @@ writeDirectory = writeDirectoryWith writeFile -- become the new `contents` of the returned, where IO errors at each node are -- replaced with `Failed` constructors. The returned tree can be compared to -- the passed tree to see what operations, if any, failed: -writeDirectoryWith :: TreeName n => (n -> a -> IO b) -> AnchoredDirTree n a -> IO (AnchoredDirTree n b) +writeDirectoryWith :: IsName n => (n -> a -> IO b) -> AnchoredDirTree n a -> IO (AnchoredDirTree n b) writeDirectoryWith f (b:/t) = (b:/) <$> write' b t where write' b' (File n a) = handleDT n $ File n <$> f (join b' n) a write' b' (Dir n cs) = handleDT n $ do let bas = join b' n - createDirectoryIfMissing True $ n2fp bas + createDirectoryIfMissing True $ n2p bas Dir n <$> mapM (write' bas) cs write' _ (Failed n e) = return $ Failed n e @@ -400,13 +397,13 @@ openDirectory p m = readDirectoryWith (flip openFile m) p -- the base directory in the Anchored* wrapper. Errors are caught in the tree in -- the Failed constructor. The 'file' fields initially are populated with full -- paths to the files they are abstracting. -build :: TreeName n => FilePath -> IO (AnchoredDirTree n FilePath) +build :: IsName n => FilePath -> IO (AnchoredDirTree n FilePath) build = buildWith' buildAtOnce' return -- we say 'return' here to get -- back a tree of FilePaths -- | identical to `build` but does directory reading IO lazily as needed: -buildL :: TreeName n => FilePath -> IO (AnchoredDirTree n FilePath) +buildL :: IsName n => FilePath -> IO (AnchoredDirTree n FilePath) buildL = buildWith' buildLazilyUnsafe' return @@ -420,22 +417,22 @@ type Builder n a = UserIO a -> FilePath -> IO (DirTree n a) -- remove non-existent file errors, which are artifacts of the "non-atomic" -- nature of traversing a system directory tree: -buildWith' :: TreeName n => Builder n a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) +buildWith' :: IsName n => Builder n a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) buildWith' bf' f p = do tree <- bf' f p - return (fp2n (baseDir p) :/ removeNonexistent tree) + return (p2n (baseDir p) :/ removeNonexistent tree) -- IO function passed to our builder and finally executed here: -buildAtOnce' :: TreeName n => Builder n a +buildAtOnce' :: IsName n => Builder n a buildAtOnce' f p = handleDT n $ do isFile <- doesFileExist p if isFile then File n <$> f p else do cs <- getDirsFiles p Dir n <$> T.mapM (buildAtOnce' f . combine p) cs - where n = fp2n $ topDir p + where n = p2n $ topDir p unsafeMapM :: (a -> IO b) -> [a] -> IO [b] @@ -449,7 +446,7 @@ unsafeMapM f (x:xs) = unsafeInterleaveIO io -- using unsafeInterleaveIO to get "lazy" traversal: -buildLazilyUnsafe' :: TreeName n => Builder n a +buildLazilyUnsafe' :: IsName n => Builder n a buildLazilyUnsafe' f p = handleDT n $ do isFile <- doesFileExist p if isFile @@ -462,7 +459,7 @@ buildLazilyUnsafe' f p = handleDT n $ return (Dir n dirTrees) where rec = buildLazilyUnsafe' f - n = fp2n $ topDir p + n = p2n $ topDir p @@ -497,7 +494,7 @@ failures = filter failed . flattenDir -- | maps a function to convert Failed DirTrees to Files or Dirs -failedMap :: TreeName n => (n -> IOException -> DirTree n a) -> DirTree n a -> DirTree n a +failedMap :: IsName n => (n -> IOException -> DirTree n a) -> DirTree n a -> DirTree n a failedMap f = transformDir unFail where unFail (Failed n e) = f n e unFail c = c @@ -548,7 +545,7 @@ comparingShape t t' = comparingConstr t t' -- HELPER: a non-recursive comparison --- TODO should the constraint here be TreeName n? +-- TODO should the constraint here be IsName n? comparingConstr :: (Eq n, Ord n) => DirTree n a -> DirTree n a1 -> Ordering comparingConstr (Failed _ _) (Dir _ _) = LT comparingConstr (Failed _ _) (File _ _) = LT @@ -573,10 +570,10 @@ free = dirTree -- | If the argument is a 'Dir' containing a sub-DirTree matching 'FileName' -- then return that subtree, appending the 'name' of the old root 'Dir' to the -- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@. -dropTo :: TreeName n => n -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) +dropTo :: IsName n => n -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) dropTo n' (p :/ Dir n ds') = search ds' where search [] = Nothing - search (d:ds) | equalFilePath (n2fp n') (n2fp $ name d) = Just ((join p n) :/ d) + search (d:ds) | equalFilePath (n2p n') (n2p $ name d) = Just ((join p n) :/ d) | otherwise = search ds dropTo _ _ = Nothing @@ -634,7 +631,7 @@ isDirC _ = False -- -- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of -- strings, although 'writeDirectory' does a better job of this. -zipPaths :: TreeName n => AnchoredDirTree n a -> DirTree n (n, a) +zipPaths :: IsName n => AnchoredDirTree n a -> DirTree n (n, a) zipPaths (b :/ t) = zipP b t where zipP p (File n a) = File n (join p n, a) zipP p (Dir n cs) = Dir n $ map (zipP $ join p n) cs @@ -654,7 +651,7 @@ baseDir = joinPath . init . splitDirectories -- | writes the directory structure (not files) of a DirTree to the anchored -- directory. Returns a structure identical to the supplied tree with errors -- replaced by `Failed` constructors: -writeJustDirs :: TreeName n => AnchoredDirTree n a -> IO (AnchoredDirTree n a) +writeJustDirs :: IsName n => AnchoredDirTree n a -> IO (AnchoredDirTree n a) writeJustDirs = writeDirectoryWith (const return) @@ -674,7 +671,7 @@ getDirsFiles cs = do let cs' = if null cs then "." else cs -- handles an IO exception by returning a Failed constructor filled with that -- exception: -handleDT :: TreeName n => n -> IO (DirTree n a) -> IO (DirTree n a) +handleDT :: IsName n => n -> IO (DirTree n a) -> IO (DirTree n a) handleDT n = handle (return . Failed n) From 6eb55ca2ffa466c007d17a2a90ecff67404bb959 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Sat, 27 Apr 2024 14:53:36 -0700 Subject: [PATCH 19/21] use FilePath rather than name types for anchors --- System/Directory/Tree.hs | 34 +++++++++++++++++++--------------- todo.txt | 5 +++++ 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 9cf97eb..bb9cfb3 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -167,18 +167,20 @@ import Control.Applicative #endif -- | A class of file names that can be converted to and from FilePaths (Strings). +-- Although not enforced, they should never contain path separators. -- TODO is there anything built in that does this properly? Not IsString or Show. class IsName n where + -- TODO is this safe without checking for path separators? p2n :: FilePath -> n n2p :: n -> FilePath - -- TODO is this actually more like append, because the first one could be a path? - join :: n -> n -> n - join n1 n2 = p2n $ (n2p n1) (n2p n2) + -- Append a name to a FilePath + nappend :: FilePath -> n -> FilePath + nappend p n = p n2p n --- | the String in the name field is always a file name, never a full path. +-- | The name field is always a file name, never a full path. -- The free type variable is used in the File constructor and can hold Handles, -- Strings representing a file's contents or anything else you can think of. -- We catch any IO errors in the Failed constructor. an Exception can be @@ -189,7 +191,7 @@ data DirTree n a = Failed { name :: n, contents :: [DirTree n a] } | File { name :: n, file :: a } - deriving Show -- TODO will this work? + deriving Show -- | Two DirTrees are equal if they have the same constructor, the same name @@ -223,7 +225,9 @@ instance (Ord n, Ord a, Eq n, Eq a) => Ord (DirTree n a) where -- absolute or relative path. This lets us give the DirTree n a context, while -- still letting us store only directory and file /names/ (not full paths) in -- the DirTree. (uses an infix constructor; don't be scared) -data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } +-- TODO the anchor should be either a full path or a list of names, right? +-- TODO use Sequence for the anchor lists for efficient append +data AnchoredDirTree n a = (:/) { anchor :: FilePath, dirTree :: DirTree n a } deriving (Show, Ord, Eq) @@ -233,7 +237,7 @@ data AnchoredDirTree n a = (:/) { anchor :: n, dirTree :: DirTree n a } type FileName = String -- TODO does anyone mind that this requires FlexibleInstances? -instance IsName FilePath where +instance IsName FileName where p2n = id n2p = id @@ -367,12 +371,12 @@ writeDirectory = writeDirectoryWith writeFile -- become the new `contents` of the returned, where IO errors at each node are -- replaced with `Failed` constructors. The returned tree can be compared to -- the passed tree to see what operations, if any, failed: -writeDirectoryWith :: IsName n => (n -> a -> IO b) -> AnchoredDirTree n a -> IO (AnchoredDirTree n b) +writeDirectoryWith :: IsName n => (FilePath -> a -> IO b) -> AnchoredDirTree n a -> IO (AnchoredDirTree n b) writeDirectoryWith f (b:/t) = (b:/) <$> write' b t where write' b' (File n a) = handleDT n $ - File n <$> f (join b' n) a + File n <$> f (nappend b' n) a write' b' (Dir n cs) = handleDT n $ - do let bas = join b' n + do let bas = nappend b' n createDirectoryIfMissing True $ n2p bas Dir n <$> mapM (write' bas) cs write' _ (Failed n e) = return $ Failed n e @@ -571,9 +575,9 @@ free = dirTree -- then return that subtree, appending the 'name' of the old root 'Dir' to the -- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@. dropTo :: IsName n => n -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) -dropTo n' (p :/ Dir n ds') = search ds' +dropTo n' (ns :/ Dir n ds') = search ds' where search [] = Nothing - search (d:ds) | equalFilePath (n2p n') (n2p $ name d) = Just ((join p n) :/ d) + search (d:ds) | equalFilePath (n2p n') (n2p $ name d) = Just (nappend ns n :/ d) | otherwise = search ds dropTo _ _ = Nothing @@ -631,10 +635,10 @@ isDirC _ = False -- -- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of -- strings, although 'writeDirectory' does a better job of this. -zipPaths :: IsName n => AnchoredDirTree n a -> DirTree n (n, a) +zipPaths :: IsName n => AnchoredDirTree n a -> DirTree n (FilePath, a) zipPaths (b :/ t) = zipP b t - where zipP p (File n a) = File n (join p n, a) - zipP p (Dir n cs) = Dir n $ map (zipP $ join p n) cs + where zipP p (File n a) = File n (nappend p n, a) + zipP p (Dir n cs) = Dir n $ map (zipP $ nappend p n) cs zipP _ (Failed n e) = Failed n e diff --git a/todo.txt b/todo.txt index d010afc..9e697b3 100644 --- a/todo.txt +++ b/todo.txt @@ -1,3 +1,8 @@ clean up the TreeName typeclass: rename IsFileName, toFileName, fromFileName? rename joinFileNames, and maybe add an infix version + +use Sequence for the anchors: + https://hackage.haskell.org/package/containers-0.7/docs/Data-Sequence.html + https://stackoverflow.com/a/5188681 + makes anchor lists strict, but i think we would always want that anyway? From f4a3d457360f8da33bd80e506877af8eeb0ec853 Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Sat, 27 Apr 2024 15:10:58 -0700 Subject: [PATCH 20/21] minor cleanup --- System/Directory/Tree.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index bb9cfb3..556e5c7 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -377,7 +377,7 @@ writeDirectoryWith f (b:/t) = (b:/) <$> write' b t File n <$> f (nappend b' n) a write' b' (Dir n cs) = handleDT n $ do let bas = nappend b' n - createDirectoryIfMissing True $ n2p bas + createDirectoryIfMissing True bas Dir n <$> mapM (write' bas) cs write' _ (Failed n e) = return $ Failed n e @@ -575,9 +575,9 @@ free = dirTree -- then return that subtree, appending the 'name' of the old root 'Dir' to the -- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@. dropTo :: IsName n => n -> AnchoredDirTree n a -> Maybe (AnchoredDirTree n a) -dropTo n' (ns :/ Dir n ds') = search ds' +dropTo n' (p :/ Dir n ds') = search ds' where search [] = Nothing - search (d:ds) | equalFilePath (n2p n') (n2p $ name d) = Just (nappend ns n :/ d) + search (d:ds) | equalFilePath (n2p n') (n2p $ name d) = Just (nappend p n :/ d) | otherwise = search ds dropTo _ _ = Nothing From 7cbc7a64a897a87ca11161c0fb2526feaae5d6cc Mon Sep 17 00:00:00 2001 From: jefdaj <1198065+jefdaj@users.noreply.github.com> Date: Sat, 27 Apr 2024 16:40:46 -0700 Subject: [PATCH 21/21] misc small cleanup --- System/Directory/Tree.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs index 556e5c7..2f5b3be 100644 --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -177,14 +177,14 @@ class IsName n where n2p :: n -> FilePath -- Append a name to a FilePath + -- TODO call it pappend? something else? nappend :: FilePath -> n -> FilePath nappend p n = p n2p n --- | The name field is always a file name, never a full path. --- The free type variable is used in the File constructor and can hold Handles, --- Strings representing a file's contents or anything else you can think of. --- We catch any IO errors in the Failed constructor. an Exception can be --- converted to a String with 'show'. +-- | The first free type variable is for file names. The second is used in the +-- File constructor and can hold Handles, Strings representing a file's contents +-- or anything else you can think of. We catch any IO errors in the Failed +-- constructor. an Exception can be converted to a String with 'show'. data DirTree n a = Failed { name :: n, err :: IOException } | Dir { name :: n, @@ -225,8 +225,6 @@ instance (Ord n, Ord a, Eq n, Eq a) => Ord (DirTree n a) where -- absolute or relative path. This lets us give the DirTree n a context, while -- still letting us store only directory and file /names/ (not full paths) in -- the DirTree. (uses an infix constructor; don't be scared) --- TODO the anchor should be either a full path or a list of names, right? --- TODO use Sequence for the anchor lists for efficient append data AnchoredDirTree n a = (:/) { anchor :: FilePath, dirTree :: DirTree n a } deriving (Show, Ord, Eq) @@ -236,7 +234,6 @@ data AnchoredDirTree n a = (:/) { anchor :: FilePath, dirTree :: DirTree n a } -- https://stackoverflow.com/a/8663534 type FileName = String --- TODO does anyone mind that this requires FlexibleInstances? instance IsName FileName where p2n = id n2p = id @@ -273,6 +270,7 @@ infixl 4 -- Uses @readDirectoryWith readFile@ internally and has the effect of traversing the -- entire directory structure. See `readDirectoryWithL` for lazy production -- of a DirTree structure. +-- TODO version not specialized to FilePath? readDirectory :: FilePath -> IO (AnchoredDirTree FilePath String) readDirectory = readDirectoryWith readFile @@ -361,7 +359,7 @@ showTree' _ _ _ (Failed _ _) = error "Cannot showTree' for Failed" -- Doesn't affect files in the directories (if any already exist) with -- different names. Returns a new AnchoredDirTree where failures were -- lifted into a `Failed` constructor: --- TODO less specialized version of this? +-- TODO version not specialized to FilePath? writeDirectory :: AnchoredDirTree FilePath String -> IO (AnchoredDirTree FilePath ()) writeDirectory = writeDirectoryWith writeFile @@ -392,6 +390,7 @@ writeDirectoryWith f (b:/t) = (b:/) <$> write' b t -- | a simple application of readDirectoryWith openFile: +-- TODO version not specialized to FilePath? openDirectory :: FilePath -> IOMode -> IO (AnchoredDirTree FilePath Handle) openDirectory p m = readDirectoryWith (flip openFile m) p @@ -424,7 +423,7 @@ type Builder n a = UserIO a -> FilePath -> IO (DirTree n a) buildWith' :: IsName n => Builder n a -> UserIO a -> FilePath -> IO (AnchoredDirTree n a) buildWith' bf' f p = do tree <- bf' f p - return (p2n (baseDir p) :/ removeNonexistent tree) + return (baseDir p :/ removeNonexistent tree)