diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -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 , @@ -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 diff --git a/darcs/darcs.hs b/darcs/darcs.hs --- a/darcs/darcs.hs +++ b/darcs/darcs.hs @@ -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 diff --git a/harness/Darcs/Test/Email.hs b/harness/Darcs/Test/Email.hs --- a/harness/Darcs/Test/Email.hs +++ b/harness/Darcs/Test/Email.hs @@ -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 diff --git a/harness/Darcs/Test/Misc.hs b/harness/Darcs/Test/Misc.hs --- a/harness/Darcs/Test/Misc.hs +++ b/harness/Darcs/Test/Misc.hs @@ -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')) diff --git a/harness/Darcs/Test/Patch/FileUUIDModel.hs b/harness/Darcs/Test/Patch/FileUUIDModel.hs --- a/harness/Darcs/Test/Patch/FileUUIDModel.hs +++ b/harness/Darcs/Test/Patch/FileUUIDModel.hs @@ -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 diff --git a/harness/Darcs/Test/Patch/Properties/RepoPatch.hs b/harness/Darcs/Test/Patch/Properties/RepoPatch.hs --- a/harness/Darcs/Test/Patch/Properties/RepoPatch.hs +++ b/harness/Darcs/Test/Patch/Properties/RepoPatch.hs @@ -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" diff --git a/harness/Darcs/Test/Shell.hs b/harness/Darcs/Test/Shell.hs --- a/harness/Darcs/Test/Shell.hs +++ b/harness/Darcs/Test/Shell.hs @@ -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 diff --git a/harness/Darcs/Test/UI.hs b/harness/Darcs/Test/UI.hs --- a/harness/Darcs/Test/UI.hs +++ b/harness/Darcs/Test/UI.hs @@ -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 ] diff --git a/harness/Darcs/Test/UI/Commands/Convert/Export.hs b/harness/Darcs/Test/UI/Commands/Convert/Export.hs new file mode 100644 --- /dev/null +++ b/harness/Darcs/Test/UI/Commands/Convert/Export.hs @@ -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 + ] diff --git a/harness/test.hs b/harness/test.hs --- a/harness/test.hs +++ b/harness/test.hs @@ -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 = diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n\n[TAG 2.18.1\nGanesh Sittampalam **20240225173219\n Ignore-this: dc3a92eafcab9d4fa9f53b1811d4c99d330615a8c202bff1b77f44d551d21684eee81e96c69be62b\n] \n" +Just "\nContext:\n\n\n[TAG 2.18.2\nGanesh Sittampalam **20240324205714\n Ignore-this: d03c480e509ce62eacaf0f1ad40f0cb7821163cac313d5ee4c977e7f77f9ec020b9e61214ddafe49\n] \n" diff --git a/src/Darcs/Patch/Annotate.hs b/src/Darcs/Patch/Annotate.hs --- a/src/Darcs/Patch/Annotate.hs +++ b/src/Darcs/Patch/Annotate.hs @@ -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 diff --git a/src/Darcs/Patch/Info.hs b/src/Darcs/Patch/Info.hs --- a/src/Darcs/Patch/Info.hs +++ b/src/Darcs/Patch/Info.hs @@ -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 diff --git a/src/Darcs/Patch/Prim/V1/Mangle.hs b/src/Darcs/Patch/Prim/V1/Mangle.hs --- a/src/Darcs/Patch/Prim/V1/Mangle.hs +++ b/src/Darcs/Patch/Prim/V1/Mangle.hs @@ -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] diff --git a/src/Darcs/Patch/V1/Commute.hs b/src/Darcs/Patch/V1/Commute.hs --- a/src/Darcs/Patch/V1/Commute.hs +++ b/src/Darcs/Patch/V1/Commute.hs @@ -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 diff --git a/src/Darcs/Repository/Clone.hs b/src/Darcs/Repository/Clone.hs --- a/src/Darcs/Repository/Clone.hs +++ b/src/Darcs/Repository/Clone.hs @@ -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] diff --git a/src/Darcs/Repository/PatchIndex.hs b/src/Darcs/Repository/PatchIndex.hs --- a/src/Darcs/Repository/PatchIndex.hs +++ b/src/Darcs/Repository/PatchIndex.hs @@ -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 diff --git a/src/Darcs/Repository/Prefs.hs b/src/Darcs/Repository/Prefs.hs --- a/src/Darcs/Repository/Prefs.hs +++ b/src/Darcs/Repository/Prefs.hs @@ -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 diff --git a/src/Darcs/UI/Commands/Convert/Darcs2.hs b/src/Darcs/UI/Commands/Convert/Darcs2.hs --- a/src/Darcs/UI/Commands/Convert/Darcs2.hs +++ b/src/Darcs/UI/Commands/Convert/Darcs2.hs @@ -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) diff --git a/src/Darcs/UI/Commands/Convert/Export.hs b/src/Darcs/UI/Commands/Convert/Export.hs --- a/src/Darcs/UI/Commands/Convert/Export.hs +++ b/src/Darcs/UI/Commands/Convert/Export.hs @@ -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 -- -> john 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 "" emailPad email = "<" ++ email ++ ">" mkAuthor name email = name ++ " " ++ email + +cleanPatchAuthorTestCases :: [(String, String)] +cleanPatchAuthorTestCases = + [ ("", "john ") + , ("john@home", "john ") + , ("john ", "john ") + , ("john ") + , ("", "john ") + , ("", "unknown ") + , (" ", "unknown ") + ] patchDate :: (PatchInfoAnd p) x y -> String patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime . diff --git a/src/Darcs/UI/Commands/Convert/Import.hs b/src/Darcs/UI/Commands/Convert/Import.hs --- a/src/Darcs/UI/Commands/Convert/Import.hs +++ b/src/Darcs/UI/Commands/Convert/Import.hs @@ -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" diff --git a/src/Darcs/UI/Commands/Pull.hs b/src/Darcs/UI/Commands/Pull.hs --- a/src/Darcs/UI/Commands/Pull.hs +++ b/src/Darcs/UI/Commands/Pull.hs @@ -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 diff --git a/src/Darcs/UI/Commands/Push.hs b/src/Darcs/UI/Commands/Push.hs --- a/src/Darcs/UI/Commands/Push.hs +++ b/src/Darcs/UI/Commands/Push.hs @@ -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 diff --git a/src/Darcs/UI/Commands/Record.hs b/src/Darcs/UI/Commands/Record.hs --- a/src/Darcs/UI/Commands/Record.hs +++ b/src/Darcs/UI/Commands/Record.hs @@ -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 diff --git a/src/Darcs/UI/Commands/Replace.hs b/src/Darcs/UI/Commands/Replace.hs --- a/src/Darcs/UI/Commands/Replace.hs +++ b/src/Darcs/UI/Commands/Replace.hs @@ -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" diff --git a/src/Darcs/UI/Commands/Send.hs b/src/Darcs/UI/Commands/Send.hs --- a/src/Darcs/UI/Commands/Send.hs +++ b/src/Darcs/UI/Commands/Send.hs @@ -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" diff --git a/src/Darcs/UI/Commands/ShowAuthors.hs b/src/Darcs/UI/Commands/ShowAuthors.hs --- a/src/Darcs/UI/Commands/ShowAuthors.hs +++ b/src/Darcs/UI/Commands/ShowAuthors.hs @@ -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 " 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 diff --git a/src/Darcs/UI/External.hs b/src/Darcs/UI/External.hs --- a/src/Darcs/UI/External.hs +++ b/src/Darcs/UI/External.hs @@ -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) diff --git a/src/Darcs/UI/Usage.hs b/src/Darcs/UI/Usage.hs --- a/src/Darcs/UI/Usage.hs +++ b/src/Darcs/UI/Usage.hs @@ -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: diff --git a/src/Darcs/Util/Diff/Patience.hs b/src/Darcs/Util/Diff/Patience.hs --- a/src/Darcs/Util/Diff/Patience.hs +++ b/src/Darcs/Util/Diff/Patience.hs @@ -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) diff --git a/src/Darcs/Util/Graph.hs b/src/Darcs/Util/Graph.hs --- a/src/Darcs/Util/Graph.hs +++ b/src/Darcs/Util/Graph.hs @@ -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 diff --git a/src/Darcs/Util/Lock.hs b/src/Darcs/Util/Lock.hs --- a/src/Darcs/Util/Lock.hs +++ b/src/Darcs/Util/Lock.hs @@ -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, diff --git a/tests/issue1465_ortryrunning.sh b/tests/issue1465_ortryrunning.sh --- a/tests/issue1465_ortryrunning.sh +++ b/tests/issue1465_ortryrunning.sh @@ -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 < 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 < 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.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 diff --git a/tests/issue189-external-merge-move.sh b/tests/issue189-external-merge-move.sh --- a/tests/issue189-external-merge-move.sh +++ b/tests/issue189-external-merge-move.sh @@ -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 diff --git a/tests/issue1898-set-default-notification.sh b/tests/issue1898-set-default-notification.sh new file mode 100644 --- /dev/null +++ b/tests/issue1898-set-default-notification.sh @@ -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 .. diff --git a/tests/issue2204-send-mail.sh b/tests/issue2204-send-mail.sh --- a/tests/issue2204-send-mail.sh +++ b/tests/issue2204-send-mail.sh @@ -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 diff --git a/tests/latin9-input.sh b/tests/latin9-input.sh --- a/tests/latin9-input.sh +++ b/tests/latin9-input.sh @@ -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 ' diff --git a/tests/network/external.sh b/tests/network/external.sh --- a/tests/network/external.sh +++ b/tests/network/external.sh @@ -11,7 +11,7 @@ cat >$fakessh.hs <> ../.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 diff --git a/tests/test-untestable.sh b/tests/test-untestable.sh --- a/tests/test-untestable.sh +++ b/tests/test-untestable.sh @@ -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 diff --git a/tests/trackdown-bisect.sh b/tests/trackdown-bisect.sh --- a/tests/trackdown-bisect.sh +++ b/tests/trackdown-bisect.sh @@ -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