[prev in list] [next in list] [prev in thread] [next in thread]
List: darcs-devel
Subject: [darcs-devel] [patch1147] Resolve Issue2244: darcs tag should warn about duplica...
From: Alejandro Gadea <bugs () darcs ! net>
Date: 2014-04-30 5:10:00
Message-ID: 536085a6.62b2340a.6029.ffffefc7 () mx ! google ! com
[Download RAW message or body]
Alejandro Gadea <alex.aegf@gmail.com> added the comment:
1 patch for repository http://darcs.net:
Wed Apr 30 02:00:29 ART 2014 Ale Gadea <alex.aegf@gmail.com>
* Resolve Issue2244: darcs tag should warn about duplicate tags
Make darcs tag t, with t already an existing tag, cause a warning message.
__________________________________
Darcs bug tracker <bugs@darcs.net>
<http://bugs.darcs.net/patch1147>
__________________________________
["patch-preview.txt" (text/x-darcs-patch)]
[Resolve Issue2244: darcs tag should warn about duplicate tags
Ale Gadea <alex.aegf@gmail.com>**20140430050029
Ignore-this: 576ba3928f9c4b200ba28fc378dc9529
Make darcs tag t, with t already an existing tag, cause a warning message.
] hunk ./src/Darcs/Repository/Util.hs 29
, maybeApplyToTree
, defaultToks
, getMovesPs
+ , patchSetfMap
) where
import Prelude hiding ( catch )
hunk ./src/Darcs/Repository/Util.hs 62
import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, primIsHunk, applyToTree,
tokreplace, forceTokReplace, move )
+import Darcs.Patch.Set ( newset2RL, PatchSet(..) )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Patchy ( Apply )
import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) )
hunk ./src/Darcs/Repository/Util.hs 68
import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize )
import Darcs.Patch.Permutations ( partitionRL )
+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Patch.TokenReplace ( breakOutToken )
import Darcs.Patch.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..),
hunk ./src/Darcs/Repository/Util.hs 71
- foldlFL, concatFL, toFL, (+>+) )
+ foldlFL, concatFL, toFL, (+>+), mapRL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, mapSeal, freeGap,
emptyGap, joinGap, FreeLeft, Gap(..) )
import Darcs.Repository
hunk ./src/Darcs/Repository/Util.hs 296
maybeApplyToTree patch tree =
(Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return \
Nothing)
+patchSetfMap:: (forall wW wZ . PatchInfoAnd p wW wZ -> IO a) -> PatchSet p wW' wZ' \
-> IO [a] +patchSetfMap f = sequence . mapRL f . newset2RL
+
defaultToks :: String
defaultToks = "A-Za-z_0-9"
hunk ./src/Darcs/UI/Commands/ShowTags.hs 22
( showTags
) where
-import Control.Monad ( unless )
+import Control.Monad ( unless, join )
import Data.Maybe ( fromMaybe )
import System.IO ( stderr, hPutStrLn )
hunk ./src/Darcs/UI/Commands/ShowTags.hs 26
-import Darcs.Patch.Info ( piTag )
-import Darcs.Patch.PatchInfoAnd ( info )
-import Darcs.Patch.Set ( newset2RL )
-import Darcs.Patch.Witnesses.Ordered ( mapRL )
+import Darcs.Patch.Set ( PatchSet(..) )
+import Darcs.Patch.MaybeInternal ( MaybeInternal )
import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) )
import Darcs.UI.Arguments ( DarcsFlag(..), possiblyRemoteRepoDir, getRepourl )
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository )
hunk ./src/Darcs/UI/Commands/ShowTags.hs 31
+import Darcs.UI.Commands.Tag ( getTags )
import Darcs.UI.Flags ( useCache )
import Darcs.Util.Text ( formatText )
import Darcs.Util.Path ( AbsolutePath )
hunk ./src/Darcs/UI/Commands/ShowTags.hs 66
tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in
- withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> do
- patches <- readRepo repo
- sequence_ $ mapRL process $ newset2RL patches
- where
- process hp = case piTag $ info hp of
- Just t -> normalize t t False >>= putStrLn
- Nothing -> return ()
- normalize :: String -> String -> Bool -> IO String
- normalize _ [] _ = return []
- normalize t (x : xs) flag =
- if x == '\t' then do
- unless flag $
- hPutStrLn stderr $ "warning: tag with TAB character: " ++ t
- rest <- normalize t xs True
- return $ ' ' : rest
- else do
- rest <- normalize t xs flag
- return $ x : rest
+ withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo ->
+ readRepo repo >>= printTags
+ where
+ printTags :: MaybeInternal p => PatchSet p wW wZ -> IO ()
+ printTags = join . fmap (sequence_ . map process) . getTags
+ where
+ process :: String -> IO ()
+ process t = normalize t t False >>= putStrLn
+ normalize :: String -> String -> Bool -> IO String
+ normalize _ [] _ = return []
+ normalize t (x : xs) flag =
+ if x == '\t' then do
+ unless flag $
+ hPutStrLn stderr $
+ "warning: tag with TAB character: " ++ t
+ rest <- normalize t xs True
+ return $ ' ' : rest
+ else do
+ rest <- normalize t xs flag
+ return $ x : rest
hunk ./src/Darcs/UI/Commands/Tag.hs 18
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.
-module Darcs.UI.Commands.Tag ( tag ) where
+module Darcs.UI.Commands.Tag ( tag, getTags ) where
import Control.Monad ( when )
hunk ./src/Darcs/UI/Commands/Tag.hs 20
+import Data.Maybe ( catMaybes )
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, amInHashedRepository )
import Darcs.UI.Commands.Record ( getDate, getLog )
hunk ./src/Darcs/UI/Commands/Tag.hs 32
tentativelyAddPatch, finalizeRepositoryChanges,
)
import Darcs.Patch ( infopatch, adddeps, Patchy, PrimPatch, PrimOf )
-import Darcs.Patch.Info ( patchinfo )
+import Darcs.Patch.Info ( patchinfo, piTag )
import Darcs.Patch.Depends ( getUncovered )
hunk ./src/Darcs/UI/Commands/Tag.hs 34
+import Darcs.Patch.PatchInfoAnd ( info )
import Darcs.Patch.MaybeInternal ( MaybeInternal(patchInternalChecker), \
InternalChecker(..) ) import Darcs.Patch.Named ( patchcontents )
import Darcs.Patch.Set ( PatchSet(..) )
hunk ./src/Darcs/UI/Commands/Tag.hs 40
import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL )
import Darcs.UI.Flags ( DarcsFlag(..), compression, verbosity, useCache, umask )
+import Darcs.Repository.Util ( patchSetfMap )
import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) )
import Darcs.Util.Path ( AbsolutePath )
import System.IO ( hPutStr, stderr )
hunk ./src/Darcs/UI/Commands/Tag.hs 101
withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \
\(repository :: Repository p wR wU wR) -> do date <- getDate opts
the_author <- getAuthor opts
- deps <- (getUncovered . filterNonInternal) `fmap` readRepo repository
- (name, long_comment) <- get_name_log (NilFL :: FL (PrimOf p) wA wA) opts args
+ patches <- readRepo repository
+ tags <- getTags patches
+ let deps = (getUncovered . filterNonInternal) patches
+ (name, long_comment) <- get_name_log (NilFL :: FL (PrimOf p) wA wA) opts args \
tags myinfo <- patchinfo date name the_author long_comment
let mypatch = infopatch myinfo NilFL
_ <- tentativelyAddPatch repository (compression opts) (verbosity opts) \
YesUpdateWorking hunk ./src/Darcs/UI/Commands/Tag.hs 111
$ n2pia $ adddeps mypatch deps
finalizeRepositoryChanges repository YesUpdateWorking (compression opts)
putStrLn $ "Finished tagging patch '"++name++"'"
- where get_name_log ::(Patchy prim, PrimPatch prim) => FL prim wA wA -> \
[DarcsFlag] -> [String] -> IO (String, [String])
- get_name_log nilFL o a
+ where
+ get_name_log ::(Patchy prim, PrimPatch prim) => FL prim wA wA -> \
[DarcsFlag] -> [String] -> [String] -> IO (String, [String]) + get_name_log \
nilFL o a tags
= do let o2 = if null a then o else add_patch_name o \
(unwords a)
(name, comment, _) <- getLog o2 Nothing nilFL
when (length name < 2) $ hPutStr stderr $
hunk ./src/Darcs/UI/Commands/Tag.hs 119
"Do you really want to tag '"
++name++"'? If not type: darcs obliterate \
--last=1\n" + when (name `elem` tags) $
+ putStrLn $ "WARNING: The tag " ++
+ "\"" ++ name ++ "\"" ++
+ " already exists."
return ("TAG " ++ name, comment)
add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag]
add_patch_name o a| has_patch_name o = o
hunk ./src/Darcs/UI/Commands/Tag.hs 131
has_patch_name (_:fs) = has_patch_name fs
has_patch_name [] = False
+getTags :: MaybeInternal p => PatchSet p wW wR -> IO [String]
+getTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps
+
-- This may be useful for developers, but users don't care about
-- internals:
--
addfile ./tests/issue2244-dup-tag-warning.sh
hunk ./tests/issue2244-dup-tag-warning.sh 1
+#!/usr/bin/env bash
+. lib # Load some portability helpers.
+
+t=`(dd if=/dev/urandom count=1 | tr -cd "a-zA-Z0-9" | head -c 10)` # Create de tag \
name. +darcs init --repo R # Create our test repos.
+
+# Test about issue 2244: darcs tag should warn about duplicate tags.
+
+cd R
+darcs tag "$t"
+darcs show tag | grep "$t"
+darcs tag "$t" | grep 'WARNING'
+cd ..
["resolve-issue2244_-darcs-tag-should-warn-about-duplicate-tags.dpatch" (application/x-darcs-patch)]
["unnamed" (application/octet-stream)]
_______________________________________________
darcs-devel mailing list
darcs-devel@darcs.net
http://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