darcs 2.18.1 → 2.18.2

raw patch · 42 files changed

+301/−95 lines, 42 filesdep +safePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: safe

API changes (from Hackage documentation)

Files

• CHANGELOG +11/−0
• darcs.cabal +4/−1
• darcs/darcs.hs +1/−1
• harness/Darcs/Test/Email.hs +2/−1
• harness/Darcs/Test/Misc.hs +3/−2
• harness/Darcs/Test/Patch/FileUUIDModel.hs +3/−3
• harness/Darcs/Test/Patch/Properties/RepoPatch.hs +2/−1
• harness/Darcs/Test/Shell.hs +5/−1
• harness/Darcs/Test/UI.hs +2/−0
• harness/Darcs/Test/UI/Commands/Convert/Export.hs +14/−0
• harness/test.hs +4/−2
• release/distributed-context +1/−1
• src/Darcs/Patch/Annotate.hs +5/−3
• src/Darcs/Patch/Info.hs +9/−4
• src/Darcs/Patch/Prim/V1/Mangle.hs +3/−2
• src/Darcs/Patch/V1/Commute.hs +2/−1
• src/Darcs/Repository/Clone.hs +3/−2
• src/Darcs/Repository/PatchIndex.hs +3/−1
• src/Darcs/Repository/Prefs.hs +26/−12
• src/Darcs/UI/Commands/Convert/Darcs2.hs +2/−1
• src/Darcs/UI/Commands/Convert/Export.hs +25/−6
• src/Darcs/UI/Commands/Convert/Import.hs +9/−9
• src/Darcs/UI/Commands/Pull.hs +4/−3
• src/Darcs/UI/Commands/Push.hs +1/−1
• src/Darcs/UI/Commands/Record.hs +6/−1
• src/Darcs/UI/Commands/Replace.hs +4/−3
• src/Darcs/UI/Commands/Send.hs +1/−1
• src/Darcs/UI/Commands/ShowAuthors.hs +5/−3
• src/Darcs/UI/External.hs +10/−10
• src/Darcs/UI/Usage.hs +2/−1
• src/Darcs/Util/Diff/Patience.hs +8/−6
• src/Darcs/Util/Graph.hs +3/−1
• src/Darcs/Util/Lock.hs +3/−1
• tests/issue1465_ortryrunning.sh +4/−4
• tests/issue189-external-merge-move.sh +1/−1
• tests/issue1898-set-default-notification.sh +51/−0
• tests/issue2204-send-mail.sh +1/−1
• tests/latin9-input.sh +1/−1
• tests/network/external.sh +1/−1
• tests/set-default-hint.sh +54/−0
• tests/test-untestable.sh +1/−1
• tests/trackdown-bisect.sh +1/−1

@@ -1,3 +1,14 @@+Darcs 2.18.2, 24 Mar 2024++  * Fix deprecated head/tail warnings on GHC 9.8, making the build there+    warning-free.++  * Replace the set-default hint that was removed in 2.18.1++  * Add a --ghcflags/-g option to the test suite to allow flags+    like -dynamic to be passed to GHC when it builds helper exes+    in various test scripts.+ Darcs 2.18.1, 25 Feb 2024    * Supports GHC 9.8 and the most recent version of other dependencies

@@ -1,6 +1,6 @@ Cabal-Version:  2.4 Name:           darcs-version:        2.18.1+version:        2.18.2 License:        GPL-2.0-or-later License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>@@ -413,6 +413,7 @@       build-depends:  unix >= 2.7.1.0 && < 2.9      build-depends:    base              >= 4.10 && < 4.20,+                      safe              >= 0.3.20 && < 0.4,                       stm               >= 2.1 && < 2.6,                       binary            >= 0.5 && < 0.11,                       containers        >= 0.5.11 && < 0.8,@@ -571,6 +572,7 @@                     constraints,                     filepath,                     mtl,+                    safe,                     transformers,                     text,                     directory,@@ -655,6 +657,7 @@                     Darcs.Test.Shell                     Darcs.Test.TestOnly.Instance                     Darcs.Test.UI+                    Darcs.Test.UI.Commands.Convert.Export                     Darcs.Test.UI.Commands.Test                     Darcs.Test.UI.Commands.Test.Commutable                     Darcs.Test.UI.Commands.Test.IndexedApply

@@ -81,7 +81,7 @@         ["-V"] -> putStrLn version         ["--version"] -> putStrLn version         ["--exact-version"] -> printExactVersion-        _ -> runTheCommand commandControlList (head argv) (tail argv)+        cmd:args -> runTheCommand commandControlList cmd args   where     handleErrors = handle errorExceptionHandler     handleExecFail = handle execExceptionHandler

@@ -36,6 +36,7 @@  import Darcs.Util.Printer ( text, renderPS, packedString ) import Darcs.UI.Email ( makeEmail, readEmail, formatHeader, prop_qp_roundtrip )+import Safe ( tailErr )  testSuite :: Test testSuite = testGroup "Darcs.Email"@@ -79,7 +80,7 @@     testProperty "Checking for spaces at start of folded email header lines" $ \field value ->       let headerLines = bsLines (formatHeader cleanField value)           cleanField  = cleanFieldString field-      in all (\l -> B.null l || B.head l == 32) (tail headerLines)+      in all (\l -> B.null l || B.head l == 32) (tailErr headerLines)  -- Checks that there are no lines in email headers with only whitespace emailHeaderNoEmptyLines :: Test

@@ -42,6 +42,7 @@ import Data.Coerce ( coerce ) import Data.Maybe ( isJust ) import Control.Monad.ST+import Safe ( tailErr ) import Test.HUnit ( assertBool, assertEqual, assertFailure ) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework.Providers.HUnit ( testCase )@@ -148,8 +149,8 @@            p_b = listArray (0, length sb) $ B.empty:(toPS sb)        shiftBoundaries ca_arr cb_arr p_a 1 1        shiftBoundaries cb_arr ca_arr p_b 1 1-       ca_res <- fmap (fromBool . tail) $ getElems ca_arr-       cb_res <- fmap (fromBool . tail) $ getElems cb_arr+       ca_res <- fmap (fromBool . tailErr) $ getElems ca_arr+       cb_res <- fmap (fromBool . tailErr) $ getElems cb_arr        return $ if ca_res  == ca' && cb_res == cb' then []                 else ["shiftBoundaries failed on "++sa++" and "++sb++" with "                       ++(show (ca,cb))++" expected "++(show (ca', cb'))

@@ -162,11 +162,11 @@      return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids)             : (fileids `zip` files) ++ dirs   where subdirs [] _ _ = return []-        subdirs tomake dirs files = do+        subdirs (uuid:uuids) dirs files = do           dirsplit <- choose (1, length dirs)           filesplit <- choose (1, length files)-          dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files)-          remaining <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files)+          dir <- aDir (uuid : take dirsplit dirs) (take filesplit files)+          remaining <- subdirs uuids (drop dirsplit dirs) (drop filesplit files)           return $ dir ++ remaining  

@@ -10,6 +10,7 @@ import Darcs.Prelude  import Data.Maybe ( catMaybes )+import Safe ( tailErr )  import Darcs.Test.Patch.Arbitrary.Generic ( PrimBased ) import Darcs.Test.Patch.Arbitrary.PatchTree@@ -68,7 +69,7 @@       let flat = take 20 flat' in       case map (start `repoApply`) flat of         rms ->-          if and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)+          if and $ zipWith assertEqualFst (zip rms flat) (tailErr $ zip rms flat)             then succeeded             else failed $ redText "oops" 

@@ -61,6 +61,7 @@   , testfile :: FilePath   , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly   , darcspath :: FilePath+  , ghcflags :: String   , diffalgorithm :: DiffAlgorithm   , useindex :: UseIndex   , usecache :: UseCache@@ -124,6 +125,7 @@           -- double-check that the darcs on the path is the expected one,           -- so is passed as a string directly without any translation           , ("DARCS"                     , EnvString darcspath)+          , ("GHC_FLAGS"                 , EnvString ghcflags)           , ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))           -- https://www.joshkel.com/2018/01/18/symlinks-in-windows/           , ("MSYS"                      , EnvString "winsymlinks:nativestrict")@@ -237,12 +239,13 @@   :: FilePath   -> [FilePath]   -> Maybe FilePath+  -> String   -> [DiffAlgorithm]   -> [Format]   -> [UseIndex]   -> [UseCache]   -> IO [Test]-findShell dp files tdir diffAlgorithms repoFormats useindexs usecaches =+findShell dp files tdir ghcflags diffAlgorithms repoFormats useindexs usecaches =   do     return       [ shellTest@@ -251,6 +254,7 @@             , testfile = file             , testdir = tdir             , darcspath = dp+            , ghcflags = ghcflags             , diffalgorithm = da             , useindex = ui             , usecache = uc

@@ -1,6 +1,7 @@ module Darcs.Test.UI ( testSuite ) where  import qualified Darcs.Test.UI.Commands.Test ( testSuite )+import qualified Darcs.Test.UI.Commands.Convert.Export ( testSuite )  import Test.Framework ( Test, testGroup ) @@ -8,4 +9,5 @@ testSuite =   testGroup "Darcs.UI"     [ Darcs.Test.UI.Commands.Test.testSuite+    , Darcs.Test.UI.Commands.Convert.Export.testSuite     ]

@@ -0,0 +1,14 @@+module Darcs.Test.UI.Commands.Convert.Export ( testSuite ) where++import Darcs.Prelude+import Darcs.UI.Commands.Convert.Export ( cleanPatchAuthor, cleanPatchAuthorTestCases )++import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )+import Test.HUnit ( (@?=) )++testSuite :: Test+testSuite = testGroup "Darcs.UI.Commands.Convert.Export"+  [ testGroup "cleanPatchAuthor" $ flip map cleanPatchAuthorTestCases $ \(input, expected) ->+      testCase (show input) $ cleanPatchAuthor input @?= expected+  ]

@@ -38,6 +38,7 @@                      , darcs :: String                      , tests :: [String]                      , testDir :: Maybe FilePath+                     , ghcFlags :: String                      , plain :: Bool                      , hideSuccesses :: Bool                      , threads :: Int@@ -59,6 +60,7 @@      , darcs         := ""       += help "Darcs binary path" += typ "PATH"      , tests         := []       += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"      , testDir       := Nothing  += help "Directory to run tests in" += typ "PATH" += name "d"+     , ghcFlags      := ""       += help "GHC flags to use when compiling tests" += typ "FLAGS" += name "g"      , plain         := False    += help "Use plain-text output [no]"      , hideSuccesses := False    += help "Hide successes [no]"      , threads       := 1        += help "Number of threads [1]" += name "j"@@ -176,14 +178,14 @@       if shell         then do           files <- findTestFiles "tests"-          findShell darcsBin files (testDir conf) diffAlgorithm+          findShell darcsBin files (testDir conf) (ghcFlags conf) diffAlgorithm             repoFormat useIndex useCache         else return []     ntests <-       if network         then do           files <- findTestFiles "tests/network"-          findShell darcsBin files (testDir conf) diffAlgorithm+          findShell darcsBin files (testDir conf) (ghcFlags conf) diffAlgorithm             repoFormat useIndex useCache         else return []     let utests =

@@ -1,1 +1,1 @@-Just "\nContext:\n\n\n[TAG 2.18.1\nGanesh Sittampalam <ganesh@earth.li>**20240225173219\n Ignore-this: dc3a92eafcab9d4fa9f53b1811d4c99d330615a8c202bff1b77f44d551d21684eee81e96c69be62b\n] \n"+Just "\nContext:\n\n\n[TAG 2.18.2\nGanesh Sittampalam <ganesh@earth.li>**20240324205714\n Ignore-this: d03c480e509ce62eacaf0f1ad40f0cb7821163cac313d5ee4c977e7f77f9ec020b9e61214ddafe49\n] \n"

@@ -53,7 +53,9 @@ import qualified Data.Vector as V  import Data.Function ( on )-import Data.List( nub, groupBy )+import Data.List( nub )+import Data.List.NonEmpty ( groupBy )+import qualified Data.List.NonEmpty as NE import Data.Maybe( isJust, mapMaybe )  import qualified Darcs.Patch.Prim.FileUUID as FileUUID@@ -233,8 +235,8 @@     pi_list = unlines [ show n ++ ": " ++ renderString (displayPatchInfo i)                       | (n :: Int, i) <- zip [1..] pis ] -    file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) ++-                    "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]+    file = concat [ annotation (fst $ NE.head chunk) ++ " | " ++ line (NE.head chunk) +++                    "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- NE.tail chunk ]                   | chunk <- file_ann ]      pis = nub $ mapMaybe fst $ V.toList a

@@ -74,6 +74,8 @@ import qualified Data.ByteString.Char8 as BC     ( index, head, notElem, all, unpack, pack ) import Data.List( isPrefixOf )+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE  import Darcs.Util.Printer ( Doc, packedString,                  empty, ($$), (<+>), vcat, text, cyanText, blueText, prefix )@@ -212,18 +214,21 @@                           "will not be shown when displaying a patch."                confirmed <- promptYorn "Proceed? "                unless confirmed $ fail "User cancelled because of Ignore-this."-       return $ pinf { _piLog = BC.pack (head ignored++showHex x ""):+       return $ pinf { _piLog = BC.pack (NE.head ignored++showHex x ""):                                  _piLog pinf }  replaceJunk :: PatchInfo -> IO PatchInfo replaceJunk pi@(PatchInfo {_piLog=log}) = addJunk $ pi{_piLog = ignoreJunk log} -ignored :: [String] -- this is a [String] so we can change the junk header.-ignored = ["Ignore-this: "]+-- This is a list so we can change the junk header.+-- The first element will be used for new patches, the rest are also recognised+-- in existing patches.+ignored :: NonEmpty String+ignored = "Ignore-this: " :| []  ignoreJunk :: [B.ByteString] -> [B.ByteString] ignoreJunk = filter isnt_ignored-    where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO+    where isnt_ignored x = doesnt_start_with x (map BC.pack (NE.toList ignored)) -- TODO           doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys  

@@ -8,6 +8,7 @@ import qualified Data.ByteString as B (null, ByteString) import Data.Maybe ( isJust, listToMaybe ) import Data.List ( sort, intercalate, nub )+import Safe ( headErr, tailErr )  import Darcs.Patch.Apply ( ObjectIdOfPatch ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )@@ -102,9 +103,9 @@         where           -- head and tail are safe here because all inner lists are infinite           go n pps =-            if any (isJust . head) pps+            if any (isJust . headErr) pps               then n-              else go (n + 1) $ map tail pps+              else go (n + 1) $ map tailErr pps        -- | The chunk of defined lines starting at the given position (1-based).       makeChunk :: Int -> Sealed FileState -> [B.ByteString]

@@ -31,6 +31,7 @@ import Control.Monad ( MonadPlus, mplus, msum, mzero, guard ) import Control.Applicative ( Alternative(..) ) import Data.Maybe ( fromMaybe )+import Safe ( headErr )  import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Commute ( selfCommuter )@@ -390,7 +391,7 @@           _ `iso` NilFL = True           NilFL `iso` _ = False           a `iso` (b:>:bs) =-              head $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False]+              headErr $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False]  -- | merger takes two patches, (which have been determined to conflict) and -- constructs a Merger patch to represent the conflict. @p1@ is considered to

@@ -9,6 +9,7 @@ import qualified Data.ByteString.Char8 as BC import Data.List( intercalate ) import Data.Maybe( catMaybes )+import Safe ( tailErr ) import System.FilePath.Posix ( (</>) ) import System.Directory     ( removeFile@@ -185,7 +186,7 @@           (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)           useCache withPrefsTemplates       debugMessage "Finished initializing new repository."-      addRepoSource repourl NoDryRun setDefault inheritDefault+      addRepoSource repourl NoDryRun setDefault inheritDefault False        debugMessage "Identifying remote repository..."       fromRepo <- identifyRepositoryFor Reading _toRepo useCache repourl@@ -412,7 +413,7 @@   do  ps <- readPatches toRepo       let patches = patchSet2RL ps           ppatches = progressRLShowTags "Copying patches" patches-          (first, other) = splitAt (100 - 1) $ tail $ hashes patches+          (first, other) = splitAt (100 - 1) $ tailErr $ hashes patches           speculate = [] : first : map (:[]) other       mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])   where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [PatchHash]

@@ -50,6 +50,8 @@ import qualified Data.Map as M import qualified Data.Set as S +import Safe ( tailErr )+ import System.Directory     ( createDirectory     , doesDirectoryExist@@ -750,7 +752,7 @@       let f :: FilePathSpan -> FilePathSpan -> Bool           f (FpSpan _ x _) (FpSpan _ _ (Just y)) = x == y           f _ _ = error "adj test of fpspans fail"-      unless (and $ zipWith f spans (tail spans)) (fail $ "Adjcency test failed! fid: " ++ show fid)+      unless (and $ zipWith f spans (tailErr spans)) (fail $ "Adjcency test failed! fid: " ++ show fid)    putStrLn "fpspans tests passed"     -- test infomap

@@ -68,6 +68,7 @@ import qualified Control.Exception as C import qualified Data.ByteString       as B  ( empty, null, hPut, ByteString ) import qualified Data.ByteString.Char8 as BC ( unpack )+import Safe ( tailErr ) import System.Directory     ( createDirectory     , doesDirectoryExist@@ -100,7 +101,7 @@     ) import Darcs.Repository.Paths ( prefsDirPath ) import Darcs.Util.Lock( readTextFile, writeTextFile )-import Darcs.Util.Exception ( catchall, ifIOError )+import Darcs.Util.Exception ( catchall ) import Darcs.Util.Global ( darcsdir, debugMessage ) import Darcs.Util.Path     ( AbsoluteOrRemotePath@@ -498,7 +499,7 @@     return $ case map snd $ filter ((== p) . fst) $ map (break (== ' ')) pl of                  [val] -> case words val of                     [] -> Nothing-                    _ -> Just $ tail val+                    _ -> Just $ tailErr val                  _ -> Nothing  setPrefval :: String -> String -> IO ()@@ -527,20 +528,33 @@               -> DryRun               -> SetDefault               -> InheritDefault+              -> Bool               -> IO ()-addRepoSource r isDryRun setDefault inheritDefault =-  ifIOError () $ do+addRepoSource r isDryRun setDefault inheritDefault isInteractive = (do     olddef <- getDefaultRepo     newdef <- newDefaultRepo-    let shouldDoIt =-          noSetDefault && isDryRun == NoDryRun && olddef /= Just newdef-    when shouldDoIt $ setPreflist Defaultrepo [newdef]-    addToPreflist Repos newdef+    let shouldDoIt = null noSetDefault && greenLight+        greenLight = shouldAct && olddef /= Just newdef+    -- the nuance here is that we should only notify when the reason we're not+    -- setting default is the --no-set-default flag, not the various automatic+    -- show stoppers+    if shouldDoIt+       then setPreflist Defaultrepo [newdef]+       else when (True `notElem` noSetDefault && greenLight && inheritDefault == NoInheritDefault) $+                putStr . unlines $ setDefaultMsg+    addToPreflist Repos newdef) `catchall` return ()   where-    noSetDefault =-      case setDefault of-        NoSetDefault _ -> False-        _ -> True+    shouldAct = isDryRun == NoDryRun+    noSetDefault = case setDefault of+                       NoSetDefault x -> [x]+                       _ -> []+    setDefaultMsg =+        [ "By the way, to change the default remote repository to"+        , "      " ++ r ++ ","+        , "you can " +++          (if isInteractive then "quit now and " else "") +++          "issue the same command with the --set-default flag."+        ]     newDefaultRepo :: IO String     newDefaultRepo = case inheritDefault of       YesInheritDefault -> getRemoteDefaultRepo

@@ -22,6 +22,7 @@ import Data.Char ( toLower ) import Data.Maybe ( catMaybes ) import Data.List ( lookup )+import Safe ( headErr ) import System.FilePath.Posix ( (</>) ) import System.Directory ( doesDirectoryExist, doesFileExist ) @@ -270,7 +271,7 @@  modifyRepoName :: String -> IO String modifyRepoName name =-    if head name == '/'+    if headErr name == '/'     then mrn name (-1)     else do cwd <- getCurrentDirectory             mrn (cwd ++ "/" ++ name) (-1)

@@ -17,7 +17,12 @@  {-# LANGUAGE OverloadedStrings #-} -module Darcs.UI.Commands.Convert.Export ( convertExport ) where+module Darcs.UI.Commands.Convert.Export+  ( convertExport+  -- exported for testing+  , cleanPatchAuthor+  , cleanPatchAuthorTestCases+  ) where  import Darcs.Prelude hiding ( readFile, lex ) @@ -313,29 +318,43 @@ -- john <john@home  -> john <john@home> -- <john>           -> john <unknown> patchAuthor :: (PatchInfoAnd p) x y -> String-patchAuthor p+patchAuthor = cleanPatchAuthor . piAuthor . info++cleanPatchAuthor :: String -> String+cleanPatchAuthor authorString  | null author = unknownEmail "unknown"  | otherwise = case span (/='<') author of                -- No name, but have email (nothing spanned)-               ("", email) -> case span (/='@') (tail email) of+               ("", _:email) -> case span (/='@') email of                    -- Not a real email address (no @).                    (n, "") -> case span (/='>') n of                        (name, _) -> unknownEmail name                    -- A "real" email address.-                   (user, rest) -> case span (/= '>') (tail rest) of+                   (user, _:rest) -> case span (/= '>') rest of                        (dom, _) -> mkAuthor user $ emailPad (user ++ "@" ++ dom)                -- No email (everything spanned)                (_, "") -> case span (/='@') author of                    (n, "") -> unknownEmail n                    (name, _) -> mkAuthor name $ emailPad author                -- Name and email-               (n, rest) -> case span (/='>') $ tail rest of+               (n, _:rest) -> case span (/='>') rest of                    (email, _) -> n ++ emailPad email  where-   author = dropWhile isSpace $ piAuthor (info p)+   author = dropWhile isSpace authorString    unknownEmail = flip mkAuthor "<unknown>"    emailPad email = "<" ++ email ++ ">"    mkAuthor name email = name ++ " " ++ email++cleanPatchAuthorTestCases :: [(String, String)]+cleanPatchAuthorTestCases =+  [ ("<john@home>", "john <john@home>")+  , ("john@home", "john <john@home>")+  , ("john <john@home>", "john <john@home>")+  , ("john <john@home", "john <john@home>")+  , ("<john>", "john <unknown>")+  , ("", "unknown <unknown>")+  , (" ", "unknown <unknown>")+  ]  patchDate :: (PatchInfoAnd p) x y -> String patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime .

@@ -36,6 +36,8 @@ import Data.Maybe (fromMaybe) import Data.Word (Word8) +import Safe (headErr, tailErr)+ import System.Directory (doesFileExist) import System.FilePath.Posix ((</>)) import System.IO (stdin)@@ -266,7 +268,7 @@         makeinfo author message tag = do           let (name, log) = case unpackPSFromUTF8 message of                                       "" -> ("Unnamed patch", [])-                                      msg -> (head &&& tail) . lines $ msg+                                      msg -> (headErr &&& tailErr) . lines $ msg               (author'', date'') = span (/='>') $ unpackPSFromUTF8 author               date' = dropWhile (`notElem` ("0123456789" :: String)) date''               author' = author'' ++ ">"@@ -290,7 +292,7 @@         --   but only for blobs and excluding anything under _darcs         -- * it also returns the resulting tree with _darcs filtered out         updateHashes = do-          let nodarcs = \(AnchoredPath xs) _ -> head xs /= darcsdirName+          let nodarcs = \(AnchoredPath xs) _ -> headErr xs /= darcsdirName               hashblobs (File blob@(T.Blob con Nothing)) =                 do hash <- sha256 `fmap` readBlob blob                    return $ File (T.Blob con (Just hash))@@ -464,13 +466,11 @@             Unquoted uqNames -> do                 let spaceIndices = BC.elemIndices ' ' uqNames                     splitStr = second (BC.drop 1) . flip BC.splitAt uqNames-                    -- Reverse the components, so we find the longest-                    -- prefix existing name.-                    spaceComponents = reverse $ map splitStr spaceIndices-                    componentCount = length spaceComponents-                if componentCount == 1-                    then return $ head spaceComponents-                    else do+                -- Reverse the components, so we find the longest+                -- prefix existing name.+                case reverse $ map splitStr spaceIndices of+                    [component] -> return component+                    spaceComponents -> do                         let dieMessage = unwords                                 [ "Couldn't determine move/rename"                                 , "source/destination filenames, with the"

@@ -29,6 +29,7 @@ import Control.Monad ( when, unless, (>=>) ) import Data.List ( nub ) import Data.Maybe ( fromMaybe )+import Safe ( headErr, tailErr )  import Darcs.UI.Commands     ( DarcsCommand(..)@@ -273,8 +274,8 @@                       O.NoDryRun -> "Pulling"       in  putInfo opts $ text pulling <+> "from" <+> hsep (map quoted repourls) <> "..."   (Sealed them, Sealed compl) <- readRepos repository opts repourls-  addRepoSource (head repourls) (dryRun ? opts)-      (setDefault False opts) (O.inheritDefault ? opts)+  addRepoSource (headErr repourls) (dryRun ? opts)+      (setDefault False opts) (O.inheritDefault ? opts) (isInteractive True opts)   mapM_ (addToPreflist Repos) repourls   unless (quiet opts || hasXmlOutput opts) $ mapM_ showMotd repourls   us <- readPatches repository@@ -354,7 +355,7 @@                             return $ seal ps) us        return $ case parseFlags O.repoCombinator opts of                   O.Intersection -> (patchSetIntersection rs, seal emptyPatchSet)-                  O.Complement -> (head rs, patchSetUnion $ tail rs)+                  O.Complement -> (headErr rs, patchSetUnion $ tailErr rs)                   O.Union -> (patchSetUnion rs, seal emptyPatchSet)  pullPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions

@@ -199,7 +199,7 @@        in  putInfo opts $ text pushing <+> "to" <+> quoted repodir <> "..."   them <- identifyRepositoryFor Writing repository (useCache ? opts) repodir >>= readPatches   addRepoSource repodir (dryRun ? opts) (setDefault False opts)-      (O.inheritDefault ? opts)+      (O.inheritDefault ? opts) (isInteractive True opts)   us <- readPatches repository   common :> only_us <- return $ findCommonWithThem us them   prePushChatter opts us (reverseFL only_us) them

@@ -252,7 +252,12 @@ checkNameIsNotOption Nothing     _      = return () checkNameIsNotOption _           False  = return () checkNameIsNotOption (Just name) True   =-    when (length name == 1 || (length name == 2 && head name == '-')) $ do+  case name of+    [_] -> warnPatchName+    ('-':_) -> warnPatchName+    _ -> return ()+  where+    warnPatchName = do         confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?"         unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure 

@@ -28,6 +28,7 @@ import Data.Char ( isAscii, isPrint, isSpace ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( fromJust, isJust )+import Safe ( headErr, tailErr ) import Control.Monad ( unless, filterM, void, when ) import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree                       , makeBlobBS )@@ -253,9 +254,9 @@     | length t <= 2 =         badTokenSpec $ "It must contain more than 2 characters, because it"                        ++ " should be enclosed in square brackets"-    | head t /= '[' || last t /= ']' =+    | headErr t /= '[' || last t /= ']' =         badTokenSpec "It should be enclosed in square brackets"-    | '^' == head tok && length tok == 1 =+    | '^' == headErr tok && length tok == 1 =         badTokenSpec "Must be at least one character in the complementary set"     | any isSpace t =         badTokenSpec "Space is not allowed"@@ -269,7 +270,7 @@     | not (isTok tok b) = badTokenSpec $ notAToken b     | otherwise = return tok   where-    tok = init $ tail t :: String+    tok = init $ tailErr t :: String     badTokenSpec msg = fail $ "Bad token spec: " ++ show t ++ " (" ++ msg ++ ")"     spaceyToken x = x ++ " must not contain any space"     notAToken x = x ++ " is not a token, according to your spec"

@@ -215,7 +215,7 @@         repo <- identifyRepositoryFor Reading repository (useCache ? opts) repodir         them <- readPatches repo         addRepoSource repodir (dryRun ? opts) (setDefault False opts)-          (O.inheritDefault ? opts)+          (O.inheritDefault ? opts) (isInteractive True opts)         wtds <- decideOnBehavior opts (Just repo)         sendToThem repository opts wtds repodir them sendCmd _ _ _ = error "impossible case"

@@ -22,7 +22,9 @@ import Control.Arrow ( (&&&), (***) ) import Data.Char ( toLower, isSpace ) import Data.Function ( on )-import Data.List ( isInfixOf, sortBy, groupBy, group, sort )+import Data.List ( isInfixOf, sortBy, sort )+import Data.List.NonEmpty ( group, groupBy )+import qualified Data.List.NonEmpty as NE import Data.Maybe( isJust ) import Data.Ord ( comparing ) import System.IO.Error ( catchIOError )@@ -132,13 +134,13 @@               reverse $ sortBy (comparing fst) .               -- Combine duplicates from a list [(count, canonized name)]               -- with duplicates canonized names (see next comment).-              map ((sum *** head) . unzip) .+              map ((sum *** NE.head) . NE.unzip) .               groupBy ((==) `on` snd) .               sortBy  (comparing snd) .               -- Because it would take a long time to canonize "foo" into               -- "foo <foo@bar.baz>" once per patch, the code below               -- generates a list [(count, canonized name)].-              map (length &&& (canonizeAuthor spellings . head)) .+              map (length &&& (canonizeAuthor spellings . NE.head)) .               group $ sort authors  canonizeAuthor :: [Spelling] -> String -> String

@@ -23,9 +23,7 @@ import Darcs.Prelude  import Data.Maybe ( isJust )-#ifndef WIN32-import Data.Maybe ( isNothing, maybeToList )-#endif+import Safe ( tailErr ) import Control.Monad ( unless, when, filterM, void ) #ifndef WIN32 import Control.Monad ( liftM2 )@@ -113,17 +111,19 @@                 searchPath                 [ "sendmail" ]   ex <- findExecutable "sendmail"-  when (isNothing ex && null l) $-    fail $ "Cannot find the 'sendmail' program in " +++  case (ex, l) of+    (Just v, _) -> return v+    (_, v:_) -> return v+    _ -> fail $ "Cannot find the 'sendmail' program in " ++       orClauses ("your PATH" : searchPath) ++ "."-  return $ head $ maybeToList ex ++ l #endif  diffProgram :: IO String diffProgram = do   l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]-  when (null l) $ fail "Cannot find the \"diff\" program."-  return $ head l+  case l of+    [] -> fail "Cannot find the \"diff\" program."+    v:_ -> return v  -- |Get the name of the darcs executable (as supplied by @getExecutablePath@) darcsProgram :: IO String@@ -348,7 +348,7 @@                     x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"                     &&                     x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"-                in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s+                in unlinesPS $ map fix_line $ tailErr $ dropWhile not_begin_signature $ linesPS s             fix_line x | B.length x < 3 = x                        | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x                        | otherwise = x@@ -364,7 +364,7 @@     certdata <- opensslPS ["smime", "-pk7out"] s                 >>= opensslPS ["pkcs7", "-print_certs"]     cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata-    let key_used = B.concat $ tail $+    let key_used = B.concat $ tailErr $                    takeWhile (/= BC.pack"-----END PUBLIC KEY-----")                            $ linesPS cruddy_pk         in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)

@@ -10,6 +10,7 @@ import Darcs.Prelude  import Data.Functor.Compose+import Safe ( headErr ) import System.Console.GetOpt( OptDescr(..), ArgDescr(..) ) import Darcs.UI.Options.All ( stdCmdActions ) import Darcs.UI.Commands@@ -35,7 +36,7 @@                                           (sameLen $ map last ls))                             ds          shortPadded    = sameLen ss-         prePad         = replicate (3 + length (head shortPadded)) ' '+         prePad         = replicate (3 + length (headErr shortPadded)) ' '          -- Similar to unlines (additional ',' and padding):          unlines'       = concatMap (\x -> x ++ ",\n" ++ prePad)          -- Unchanged:

@@ -21,7 +21,6 @@ import Darcs.Prelude  import Data.List ( sort )-import Data.Maybe ( fromJust ) import Data.Array.Unboxed import Data.Array.ST import Control.Monad.ST@@ -96,11 +95,14 @@  --Given a HunkMap, check collisions and return the line with an updated Map toHunk' :: HunkMap -> B.ByteString -> (Hunk, HunkMap)-toHunk' lmap bs | oldbs == Nothing || null oldhunkpair = insert hash bs lmap-                | otherwise = (fst $ head oldhunkpair, lmap)-                    where hash = H.hash bs-                          oldbs = M.lookup hash (getMap lmap)-                          oldhunkpair = filter ((== bs) . snd) $ fromJust oldbs+toHunk' lmap bs =+  case M.lookup hash (getMap lmap) of+    Nothing -> insert hash bs lmap+    Just hunkpairs ->+        case filter ((== bs) . snd) hunkpairs of+            [] -> insert hash bs lmap+            (hunknumber, _):_ -> (hunknumber, lmap)+    where hash = H.hash bs  listToHunk :: [B.ByteString] -> HunkMap -> ([Hunk], HunkMap) listToHunk [] hmap = ([], hmap)

@@ -43,6 +43,8 @@ import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU +import Safe ( tailErr )+ import Darcs.Prelude  -- | Vertices are represented as 'Int'.@@ -241,7 +243,7 @@ prop_connected :: Graph -> VertexSet -> Bool prop_connected g = not . any (prop_self_contained g) . proper_non_empty_subsets   where-    proper_non_empty_subsets = filter (not . null) . tail . powerset+    proper_non_empty_subsets = filter (not . null) . tailErr . powerset  -- | Whether a 'VertexSet' is a connected component of the 'Graph'. prop_connected_component :: Component -> Bool

@@ -89,6 +89,8 @@  import GHC.IO.Encoding ( getFileSystemEncoding ) +import Safe ( headErr )+ import Darcs.Util.URL ( isRelative ) import Darcs.Util.Exception     ( firstJustIO@@ -172,7 +174,7 @@  tempdirLoc :: IO FilePath tempdirLoc = fromJust <$>-    firstJustIO [ fmap (Just . head . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,+    firstJustIO [ fmap (Just . headErr . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,                   lookupEnv "DARCS_TMPDIR" >>= chkdir,                   getTemporaryDirectory >>= chkdir . Just,                   getCurrentDirectorySansDarcs,

@@ -33,26 +33,26 @@ import System.IO main = getArgs >>= \[name] -> writeFile name "fake" FAKE-ghc -o editor-good --make editor-good.hs+ghc $GHC_FLAGS -o editor-good --make editor-good.hs  cat <<FAKE > editor-bad.hs import System.Exit main = exitWith (ExitFailure 127) FAKE-ghc -o editor-bad --make editor-bad.hs+ghc $GHC_FLAGS -o editor-bad --make editor-bad.hs  cat <<FAKE > editor-gave-up.hs import System.Exit main = exitWith (ExitFailure 1) FAKE-ghc -o editor-gave-up --make editor-gave-up.hs+ghc $GHC_FLAGS -o editor-gave-up --make editor-gave-up.hs  cat <<VI > vi.hs import System.Environment import System.IO main = getArgs >>= \[name] -> writeFile name "vi" VI-ghc -o vi --make vi.hs+ghc $GHC_FLAGS -o vi --make vi.hs  cd R mkdir d

@@ -43,7 +43,7 @@   when (c2 /= "content2\n") exitFailure   when (co /= "content\n") exitFailure EOF-ghc --make external_merge.hs+ghc $GHC_FLAGS --make external_merge.hs merge_tool=$(pwd)/external_merge  # try to merge them with our external_merge script

@@ -0,0 +1,51 @@+#!/usr/bin/env bash+## Test for issue1898 - set-default mechanism+##+## Copyright (C) 2010 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R0 R1 R2 S               # Another script may have left a mess.+darcs init      --repo R0       # Create our test repos.++darcs get R0 R1+darcs get R0 R2+darcs get R0 S++cd S+# default to no-set-default+darcs push ../R1 > log+test R0 = $(cat _darcs/prefs/defaultrepo | xargs basename)+# notification when using no-set-default+grep -- "--set-default" log+# ...but not when --inherit-default is active+darcs push ../R1 --inherit-default > log+not grep -- "--set-default" log+# set-default works+darcs push ../R1 --set-default > log+test R1 = $(cat _darcs/prefs/defaultrepo | xargs basename)+# no notification when already using --set-default+not grep -- "--set-default" log+# no notification when already pushing to the default repo+darcs push > log+not grep -- "--set-default" log+cd ..

@@ -33,7 +33,7 @@ import System.IO main = hGetContents stdin >>= writeFile "message" FAKE-ghc -o dummy-sendmail --make dummy-sendmail.hs+ghc $GHC_FLAGS -o dummy-sendmail --make dummy-sendmail.hs  cd R echo 'foo@example.com' > _darcs/prefs/email

@@ -132,7 +132,7 @@ str = B.pack [65,108,108,32,109,121,32,164,115,32,97,114,101,32,103,111,110,101] main = getArgs >>= \[x] -> B.writeFile x str FAKE-ghc --make -o editor editor.hs+ghc $GHC_FLAGS --make -o editor editor.hs export DARCS_EDITOR="`pwd`/editor" if echo $OS | not grep -i windows; then # issue2591     printf "y\ny\n" | darcs amend --edit -p 'Patch by '

@@ -11,7 +11,7 @@ cat >$fakessh.hs <<EOF main = writeFile "touchedby_fakessh" "hello\n" EOF-ghc --make $fakessh.hs+ghc $GHC_FLAGS --make $fakessh.hs  export DARCS_SSH=$fakessh export DARCS_SCP=$fakessh

@@ -0,0 +1,54 @@+#!/usr/bin/env bash+## Test that set-default hint messages are produced at the right times+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R1 R2 R3                 # Another script may have left a mess.++darcs init      --repo R1+darcs get R1 R2+darcs get R1 R3++HINTSTRING="issue the same command with the --set-default flag"++cd R3+for command in pull push send+do+   opt=+   test "$command" = "send" && opt=-O++   # R1 should be the default for R3+   darcs $command $opt ../R1 | not grep "$HINTSTRING"+   darcs $command $opt ../R2 | grep "$HINTSTRING"++   # can disable message on the command-line+   darcs $command $opt --no-set-default ../R2 | not grep "$HINTSTRING"++   # or using defaults+   echo "$command no-set-default" >> ../.darcs/defaults+   darcs $command $opt ../R2 | not grep "$HINTSTRING"++   darcs $command $opt --set-default ../R2 | not grep "$HINTSTRING"+   darcs $command $opt --set-default ../R1 | not grep "$HINTSTRING"+done

@@ -38,7 +38,7 @@     when (n /= 0) (exitWith (ExitFailure n)) END -ghc --make -o runtest runtest.hs+ghc $GHC_FLAGS --make -o runtest runtest.hs  export RUNTEST=`pwd`/runtest 

@@ -13,7 +13,7 @@ fi  cp $TESTBIN/trackdown-bisect-helper.hs .-ghc -o trackdown-bisect-helper trackdown-bisect-helper.hs+ghc $GHC_FLAGS -o trackdown-bisect-helper trackdown-bisect-helper.hs  function make_repo_with_test {     rm -fr temp1