[prev in list] [next in list] [prev in thread] [next in thread]
List: darcs-devel
Subject: [darcs-devel] [patch1772] remove currentDirectory from TreeMonad
From: Ben Franksen <bugs () darcs ! net>
Date: 2019-08-29 22:31:41
Message-ID: 1N6sWd-1iGUGP1M6x-018HMS () mrelayeu ! kundenserver ! de
[Download RAW message or body]
Ben Franksen <ben.franksen@online.de> added the comment:
I have separated out or removed all the gratuitious layout changes. This
should be easier to review now.
3 patches for repository http://darcs.net/screened:
patch fc0252b62b16206b74b6847ed4baae4741d6c5bc
Author: Ben Franksen <ben.franksen@online.de>
Date: Mon Dec 3 14:37:26 CET 2018
* remove currentDirectory from TreeMonad
Adding a notion of "current directory" to the TreeMonad is an unnecessary
complication at best. It is clearer to explicitly pass the current directory
when using the TreeMonad interface. Thankfully, this feature was used only
in a single function in Darcs.UI.Commands.Util.
patch de379eef2e7c552013acadd3f94918149e1add06
Author: Ben Franksen <ben.franksen@online.de>
Date: Fri Aug 30 00:32:52 CEST 2019
* cleanup layout and import lists in Darcs.UI.Commands.Util.Tree
patch c6597e29db19c1ac3c9fd65c878ff671204180b7
Author: Ben Franksen <ben.franksen@online.de>
Date: Tue Feb 26 08:42:27 CET 2019
* existsAnycase: don't error if subdir is not found
This function queries whether a path exists, disregarding upper/lower case,
so it makes sense to just return False if a prefix of the path is not found.
__________________________________
Darcs bug tracker <bugs@darcs.net>
<http://bugs.darcs.net/patch1772>
__________________________________
["patch-preview.txt" (text/x-darcs-patch)]
[remove currentDirectory from TreeMonad
Ben Franksen <ben.franksen@online.de>**20181203133726
Ignore-this: 346228a12b224923b9b5e886e1360253b90fd0982c8dd2ad4ac931a1ae81e972412717d18ecec46a
Adding a notion of "current directory" to the TreeMonad is an unnecessary
complication at best. It is clearer to explicitly pass the current directory
when using the TreeMonad interface. Thankfully, this feature was used only
in a single function in Darcs.UI.Commands.Util.
] hunk ./src/Darcs/UI/Commands/Util/Tree.hs 35
- - ( TreeMonad, withDirectory, fileExists, directoryExists
- - , virtualTreeMonad, currentDirectory, exists, tree )
+ ( TreeMonad, fileExists, directoryExists
+ , virtualTreeMonad, exists, tree, expandTo )
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 40
- - ( AnchoredPath(..), eqAnycase )
+ ( AnchoredPath(..), anchoredRoot, catPaths, eqAnycase )
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 53
- -existsAnycase (AnchoredPath []) = return True
- -existsAnycase (AnchoredPath (x:xs)) = do
- - wd <- TM.currentDirectory
- - tree <- fromMaybe (error "invalid path passed to existsAnycase") <$>
- - gets (flip findTree wd . TM.tree)
- - let subs = [ AnchoredPath [n] | (n, _) <- listImmediate tree,
+existsAnycase = go anchoredRoot
+ where
+ go _ (AnchoredPath []) = return True
+ go wd (AnchoredPath (x:xs)) = do
+ TM.expandTo wd
+ tree <- fromMaybe (error "invalid path passed to existsAnycase") .
+ flip findTree wd <$> gets TM.tree
+ let subs = [ catPaths wd (AnchoredPath [n]) | (n, _) <- listImmediate tree,
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 65
- - else TM.withDirectory path (existsAnycase $ AnchoredPath xs))
- -
+ else go path (AnchoredPath xs))
hunk ./src/Darcs/Util/Tree/Monad.hs 7
- --- simulate IO-ish manipulation of real filesystem (that's the state part of
- --- the monad), and to keep memory usage down by reasonably often dumping the
- --- intermediate data to disk and forgetting it. The monad interface itself is
- --- generic, and a number of actual implementations can be used. This module
- --- provides just 'virtualTreeIO' that never writes any changes, but may trigger
- --- filesystem reads as appropriate.
+-- simulate IO-ish manipulation of real filesystem, and to keep memory usage
+-- down by reasonably often dumping the intermediate data to disk and
+-- forgetting it. The monad interface itself is generic, and a number of actual
+-- implementations can be used. This module provides just 'virtualTreeIO' that
+-- never writes any changes, but may trigger filesystem reads as appropriate.
hunk ./src/Darcs/Util/Tree/Monad.hs 15
- - , fileExists, directoryExists, exists, withDirectory
- - , currentDirectory
+ , fileExists, directoryExists, exists, expandTo
hunk ./src/Darcs/Util/Tree/Monad.hs 34
- -import Control.Monad.RWS.Strict
+import Control.Monad.State.Strict
hunk ./src/Darcs/Util/Tree/Monad.hs 39
- --- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree
- --- content, unsync'd changes and a current working directory (of the monad).
+-- | Internal state of the 'TreeMonad'. Keeps track of the current 'Tree'
+-- content and unsync'd changes.
hunk ./src/Darcs/Util/Tree/Monad.hs 55
- -type TreeMonad m = RWST AnchoredPath () (TreeState m) m
+type TreeMonad m = StateT (TreeState m) m
hunk ./src/Darcs/Util/Tree/Monad.hs 59
- - currentDirectory :: m AnchoredPath
- - withDirectory :: AnchoredPath -> m a -> m a
- - expandTo :: AnchoredPath -> m AnchoredPath
+ expandTo :: AnchoredPath -> m ()
hunk ./src/Darcs/Util/Tree/Monad.hs 95
- - (out, final, _) <- runRWST action (AnchoredPath []) initial
+ (out, final) <- runStateT action initial
hunk ./src/Darcs/Util/Tree/Monad.hs 123
- - path' <- (`catPaths` path) `fmap` currentDirectory
hunk ./src/Darcs/Util/Tree/Monad.hs 128
- - let change = case M.lookup path' changed' of
+ let change = case M.lookup path changed' of
hunk ./src/Darcs/Util/Tree/Monad.hs 132
- - modify $ \st -> st { tree = modifyTree (tree st) path' item
- - , changed = M.insert path' (size, age) (changed st)
+ modify $ \st -> st { tree = modifyTree (tree st) path item
+ , changed = M.insert path (size, age) (changed st)
hunk ./src/Darcs/Util/Tree/Monad.hs 153
- - path' <- (`catPaths` path) `fmap` currentDirectory
- - modify $ \st -> st { tree = modifyTree (tree st) path' item }
+ modify $ \st -> st { tree = modifyTree (tree st) path item }
hunk ./src/Darcs/Util/Tree/Monad.hs 191
- - p' <- (`catPaths` p) `fmap` ask
- - t' <- lift $ expandPath t p'
+ t' <- lift $ expandPath t p
hunk ./src/Darcs/Util/Tree/Monad.hs 193
- - return p'
hunk ./src/Darcs/Util/Tree/Monad.hs 195
- - do p' <- expandTo p
- - (isJust . (`findFile` p')) `fmap` gets tree
+ do expandTo p
+ (isJust . (`findFile` p)) `fmap` gets tree
hunk ./src/Darcs/Util/Tree/Monad.hs 199
- - do p' <- expandTo p
- - (isJust . (`findTree` p')) `fmap` gets tree
+ do expandTo p
+ (isJust . (`findTree` p)) `fmap` gets tree
hunk ./src/Darcs/Util/Tree/Monad.hs 203
- - do p' <- expandTo p
- - (isJust . (`find` p')) `fmap` gets tree
+ do expandTo p
+ (isJust . (`find` p)) `fmap` gets tree
hunk ./src/Darcs/Util/Tree/Monad.hs 207
- - do p' <- expandTo p
+ do expandTo p
hunk ./src/Darcs/Util/Tree/Monad.hs 209
- - let f = findFile t p'
+ let f = findFile t p
hunk ./src/Darcs/Util/Tree/Monad.hs 211
- - Nothing -> fail $ "No such file " ++ show p'
+ Nothing -> fail $ "No such file " ++ show p
hunk ./src/Darcs/Util/Tree/Monad.hs 214
- - currentDirectory = ask
- - withDirectory dir act = do
- - dir' <- expandTo dir
- - local (const dir') act
- -
hunk ./src/Darcs/Util/Tree/Monad.hs 216
- - do _ <- expandTo p
+ do expandTo p
hunk ./src/Darcs/Util/Tree/Monad.hs 227
- - do _ <- expandTo p
+ do expandTo p
hunk ./src/Darcs/Util/Tree/Monad.hs 231
- - do _ <- expandTo p
+ do expandTo p
hunk ./src/Darcs/Util/Tree/Monad.hs 235
- - do from' <- expandTo from
- - to' <- expandTo to
+ do expandTo from
+ expandTo to
hunk ./src/Darcs/Util/Tree/Monad.hs 238
- - let item = find tr from'
- - found_to = find tr to'
+ let item = find tr from
+ found_to = find tr to
hunk ./src/Darcs/Util/Tree/Monad.hs 248
- - do from' <- expandTo from
- - _ <- expandTo to
+ do expandTo from
+ expandTo to
hunk ./src/Darcs/Util/Tree/Monad.hs 251
- - let item = find tr from'
+ let item = find tr from
hunk ./src/Darcs/Util/Tree/Monad.hs 258
- - look = expandTo >=> \p' -> flip what p' <$> gets tree
+ look p = expandTo p >> flip what p <$> gets tree
[cleanup layout and import lists in Darcs.UI.Commands.Util.Tree
Ben Franksen <ben.franksen@online.de>**20190829223252
Ignore-this: 37fec40e831a0bc8def475288213d97190a048f65e9f475de467e0ad1f0e3c403fb0f0bcc29b10ce
] hunk ./src/Darcs/UI/Commands/Util/Tree.hs 34
+import Darcs.Util.Path ( AnchoredPath(..), anchoredRoot, catPaths, eqAnycase )
+import Darcs.Util.Tree ( Tree, findTree, listImmediate )
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 37
- - ( TreeMonad, fileExists, directoryExists
- - , virtualTreeMonad, exists, tree, expandTo )
- -import Darcs.Util.Tree ( Tree, listImmediate, findTree )
+ ( TreeMonad
+ , directoryExists
+ , exists
+ , expandTo
+ , fileExists
+ , tree
+ , virtualTreeMonad
+ )
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 46
- -import Darcs.Util.Path
- - ( AnchoredPath(..), anchoredRoot, catPaths, eqAnycase )
- -
- -treeHasAnycase :: Monad m
- - => Tree m
- - -> AnchoredPath
- - -> m Bool
+treeHasAnycase :: Monad m => Tree m -> AnchoredPath -> m Bool
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 50
- -
- -existsAnycase :: Monad m
- - => AnchoredPath
- - -> TM.TreeMonad m Bool
+existsAnycase :: Monad m => AnchoredPath -> TM.TreeMonad m Bool
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 54
- - go wd (AnchoredPath (x:xs)) = do
- - TM.expandTo wd
- - tree <- fromMaybe (error "invalid path passed to existsAnycase") .
- - flip findTree wd <$> gets TM.tree
- - let subs = [ catPaths wd (AnchoredPath [n]) | (n, _) <- listImmediate tree,
- - eqAnycase n x ]
- - or `fmap` forM subs (\path -> do
- - file <- TM.fileExists path
- - if file then return True
- - else go path (AnchoredPath xs))
+ go dir (AnchoredPath (x:xs)) = do
+ TM.expandTo dir
+ subtree <-
+ fromMaybe (error "invalid path passed to existsAnycase") .
+ flip findTree dir <$> gets TM.tree
+ let subs = [ catPaths dir (AnchoredPath [n]) | (n, _) <- listImmediate subtree
+ , eqAnycase n x ]
+ or `fmap` forM subs ( \path -> do
+ file <- TM.fileExists path
+ if file
+ then return True
+ else go path (AnchoredPath xs) )
[existsAnycase: don't error if subdir is not found
Ben Franksen <ben.franksen@online.de>**20190226074227
Ignore-this: 72cb1aa816eba5de21cc8c83e726c7b8853a638cdcc67cd63ae710a37801df066d375fa474b326e0
This function queries whether a path exists, disregarding upper/lower case,
so it makes sense to just return False if a prefix of the path is not found.
] hunk ./src/Darcs/UI/Commands/Util/Tree.hs 32
- -import Data.Maybe ( fromMaybe )
hunk ./src/Darcs/UI/Commands/Util/Tree.hs 55
- - subtree <-
- - fromMaybe (error "invalid path passed to existsAnycase") .
- - flip findTree dir <$> gets TM.tree
- - let subs = [ catPaths dir (AnchoredPath [n]) | (n, _) <- listImmediate subtree
- - , eqAnycase n x ]
- - or `fmap` forM subs ( \path -> do
- - file <- TM.fileExists path
- - if file
- - then return True
- - else go path (AnchoredPath xs) )
+ maybe_subtree <- flip findTree dir <$> gets TM.tree
+ case maybe_subtree of
+ Nothing -> return False
+ Just subtree -> do
+ let subs = [ catPaths dir (AnchoredPath [n])
+ | (n, _) <- listImmediate subtree, eqAnycase n x ]
+ or `fmap` forM subs ( \path -> do
+ file <- TM.fileExists path
+ if file
+ then return True
+ else go path (AnchoredPath xs) )
["remove-currentdirectory-from-treemonad.dpatch" (application/x-darcs-patch)]
["unnamed" (text/plain)]
.
_______________________________________________
darcs-devel mailing list
darcs-devel@osuosl.org
https://lists.osuosl.org/mailman/listinfo/darcs-devel
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic