diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +Darcs 2.14.2, 26 January 2019 + + * Support GHC 8.6 (Ganesh Sittampalam) + * Some other dependency bumps (Ganesh Sittampalam) + * Fixed the following bugs: + * 2617 convert import crashes with out-of-order tags (Ben Franksen) + Darcs 2.14.1, 24 June 2018 * Some dependency bumps (Ganesh Sittampalam, Ben Franksen, Guillaume Hoffmann) diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.14.1 +version: 2.14.2 License: GPL-2 License-file: COPYING Author: David Roundy , @@ -112,7 +112,7 @@ -- ---------------------------------------------------------------------- custom-setup - setup-depends: base >= 4.9 && < 4.12, + setup-depends: base >= 4.9 && < 4.13, Cabal >= 1.24, process >= 1.2.3.0 && < 1.7, filepath >= 1.4.1 && < 1.5.0.0, @@ -380,8 +380,8 @@ else build-depends: unix >= 2.7.1.0 && < 2.8 - build-depends: base >= 4.9 && < 4.12, - stm >= 2.1 && < 2.5, + build-depends: base >= 4.9 && < 4.13, + stm >= 2.1 && < 2.6, binary >= 0.5 && < 0.10, containers >= 0.5.6.2 && < 0.7, regex-compat-tdfa >= 0.95.1 && < 0.96, @@ -389,7 +389,7 @@ mtl >= 2.2.1 && < 2.3, transformers >= 0.4.2.0 && < 0.6, parsec >= 3.1.9 && < 3.2, - fgl >= 5.5.2.3 && < 5.7, + fgl >= 5.5.2.3 && < 5.8, graphviz >= 2999.18.1 && < 2999.20.1, html >= 1.0.1.2 && < 1.1, filepath >= 1.4.1 && < 1.5.0.0, @@ -401,7 +401,7 @@ tar >= 0.5 && < 0.6, data-ordlist == 0.4.*, attoparsec >= 0.13.0.1 && < 0.14, - zip-archive >= 0.3 && < 0.4, + zip-archive >= 0.3 && < 0.5, async >= 2.0.2 && < 2.3, sandi >= 0.4 && < 0.5, unix-compat >= 0.4.2 && < 0.6, @@ -417,7 +417,7 @@ mmap >= 0.5.9 && < 0.6, zlib >= 0.6.1.2 && < 0.7.0.0, network-uri == 2.6.*, - network >= 2.6 && < 2.8, + network >= 2.6 && < 2.9, HTTP >= 4000.2.20 && < 4000.4 if flag(optimize) @@ -499,7 +499,7 @@ cc-options: -D_REENTRANT build-depends: darcs, - base >= 4.9 && < 4.12 + base >= 4.9 && < 4.13 -- ---------------------------------------------------------------------- -- unit test driver @@ -517,7 +517,7 @@ build-depends: Win32 >= 2.3.1 && < 2.4 build-depends: darcs, - base >= 4.9 && < 4.12, + base >= 4.9 && < 4.13, array >= 0.5.1.0 && < 0.6, bytestring >= 0.10.6 && < 0.11, cmdargs >= 0.10.10 && < 0.11, @@ -529,12 +529,12 @@ text >= 1.2.1.3 && < 1.3, directory >= 1.2.6.2 && < 1.4, FindBin >= 0.0.5 && < 0.1, - QuickCheck >= 2.8.2 && < 2.12, + QuickCheck >= 2.8.2 && < 2.13, HUnit >= 1.3 && < 1.7, test-framework >= 0.8.1.1 && < 0.9, test-framework-hunit >= 0.3.0.2 && < 0.4, test-framework-quickcheck2 >= 0.3.0.3 && < 0.4, - zip-archive >= 0.3 && < 0.4 + zip-archive >= 0.3 && < 0.5 -- https://github.com/yesodweb/Shelly.hs/issues/177 if os(windows) diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs @@ -19,7 +19,7 @@ import Darcs.Patch.Witnesses.Eq import Darcs.Patch.Witnesses.Unsafe import Darcs.Patch.Witnesses.Ordered -import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), isIdentity ) +import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), isIdentity ) import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) ) import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) ) import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) ) @@ -124,7 +124,7 @@ ---------------------------------------------------------------------- -- ** FilePatchType generators -aHunk :: forall wX wY . Content -> Gen (FilePatchType wX wY) +aHunk :: Content -> Gen (Int, [BC.ByteString], [BC.ByteString]) aHunk content = sized $ \n -> do pos <- choose (1, contentLen+1) @@ -153,20 +153,20 @@ ] new <- vectorOf newLen aLine let old = take oldLen $ drop prefixLen $ content - return $ Hunk pos old new + return (pos, old, new) where contentLen = length content -aTokReplace :: forall wX wY . Content -> Gen (FilePatchType wX wY) +aTokReplace :: Content -> Gen (String, String, String) aTokReplace [] = do w <- vectorOf 1 alpha w' <- vectorOf 1 alpha - return $ TokReplace defaultToks w w' + return (defaultToks, w, w') aTokReplace content = do let fileWords = concatMap BC.words content wB <- elements fileWords w' <- alphaBS `notIn` fileWords - return $ TokReplace defaultToks (BC.unpack wB) (BC.unpack w') + return (defaultToks, BC.unpack wB, BC.unpack w') where alphaBS = do x <- alpha; return $ BC.pack [x] @@ -175,14 +175,14 @@ aHunkP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY) aHunkP (path,file) - = do Hunk pos old new <- aHunk content + = do (pos, old, new) <- aHunk content return $ hunk (ap2fp path) pos old new where content = fileContent file aTokReplaceP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY) aTokReplaceP (path,file) - = do TokReplace tokchars old new <- aTokReplace content + = do (tokchars, old, new) <- aTokReplace content return $ tokreplace (ap2fp path) tokchars old new where content = fileContent file @@ -289,9 +289,9 @@ -- Try to generate commutable pairs of hunks hunkPairP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen ((prim :> prim) wX wY) hunkPairP (path,file) - = do h1@(Hunk l1 old1 new1) <- aHunk content - (delta, content') <- selectChunk h1 content - Hunk l2' old2 new2 <- aHunk content' + = do (l1, old1, new1) <- aHunk content + (delta, content') <- selectChunk (Hunk l1 old1 new1) content + (l2', old2, new2) <- aHunk content' let l2 = l2'+delta return (hunk fpPath l1 old1 new1 :> hunk fpPath l2 old2 new2) where diff --git a/harness/Darcs/Test/Patch/Check.hs b/harness/Darcs/Test/Patch/Check.hs --- a/harness/Darcs/Test/Patch/Check.hs +++ b/harness/Darcs/Test/Patch/Check.hs @@ -15,6 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Darcs.Test.Patch.Check ( PatchCheck(), doCheck, fileExists, dirExists, removeFile, removeDir, createFile, createDir, insertLine, deleteLine, isValid, doVerboseCheck, @@ -29,7 +30,8 @@ import qualified Data.ByteString as B (ByteString) import Data.List ( isPrefixOf, inits ) import Control.Monad.State ( State, evalState, runState ) -import Control.Monad.State.Class ( get, put, modify ) +import Control.Monad.State.Class ( get, put, modify, MonadState ) +import Control.Monad.Fail ( MonadFail(fail) ) -- use Map, not IntMap, because Map has mapKeys and IntMap hasn't import Data.Map ( Map ) import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null ) @@ -68,8 +70,12 @@ -- error handling mechanism. -- | PatchCheck is a state monad with a simulated repository state -type PatchCheck = State KnownState +newtype PatchCheck a = PatchCheck { runPatchCheck :: State KnownState a } + deriving (Functor, Applicative, Monad, MonadState KnownState) +instance MonadFail PatchCheck where + fail = error + -- | The @FileContents@ structure for an empty file emptyFilecontents :: FileContents emptyFilecontents = FC M.empty 0 @@ -85,12 +91,12 @@ _ -> a doCheck :: PatchCheck a -> a -doCheck p = evalState p (P [] []) +doCheck p = evalState (runPatchCheck p) (P [] []) -- | Run a check, and print the final repository state doVerboseCheck :: PatchCheck a -> a doVerboseCheck p = - case runState p (P [] []) of + case runState (runPatchCheck p) (P [] []) of (b, pc) -> unsafePerformIO $ do print pc return b diff --git a/harness/Darcs/Test/Patch/RepoModel.hs b/harness/Darcs/Test/Patch/RepoModel.hs --- a/harness/Darcs/Test/Patch/RepoModel.hs +++ b/harness/Darcs/Test/Patch/RepoModel.hs @@ -1,16 +1,37 @@ module Darcs.Test.Patch.RepoModel where import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL ) + +import Control.Monad.Fail ( MonadFail(fail) ) import Test.QuickCheck ( Gen ) -type Fail = Either String +data Fail a = Failed String | OK a + deriving (Eq, Show) -unFail :: Either [Char] t -> t -unFail (Right x) = x -unFail (Left err) = error $ "unFail failed: " ++ err +instance Functor Fail where + fmap _ (Failed s) = Failed s + fmap f (OK v) = OK (f v) -maybeFail :: Either t a -> Maybe a -maybeFail (Right x) = Just x +instance Applicative Fail where + pure = OK + Failed s <*> _ = Failed s + _ <*> Failed s = Failed s + OK f <*> OK v = OK (f v) + +instance Monad Fail where + return = OK + Failed s >>= _ = Failed s + OK v >>= f = f v + +instance MonadFail Fail where + fail = Failed + +unFail :: Fail t -> t +unFail (OK x) = x +unFail (Failed err) = error $ "unFail failed: " ++ err + +maybeFail :: Fail a -> Maybe a +maybeFail (OK x) = Just x maybeFail _ = Nothing class RepoModel model where 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[TAG 2.14.1\nGanesh Sittampalam **20180624165311\n Ignore-this: 5df6cb67e1a02b11e128e15877e4d206\n] \n" +Just "\nContext:\n\n[TAG 2.14.2\nGanesh Sittampalam **20190126112346\n Ignore-this: 5c94e042fbcfdf311008d6e980d9cf1d\n] \n" diff --git a/src/Darcs/UI/Commands/Convert.hs b/src/Darcs/UI/Commands/Convert.hs --- a/src/Darcs/UI/Commands/Convert.hs +++ b/src/Darcs/UI/Commands/Convert.hs @@ -676,6 +676,7 @@ type AuthorInfo = B.ByteString type Message = B.ByteString type Content = B.ByteString +type Tag = B.ByteString data RefId = MarkId Int | HashId B.ByteString | Inline deriving Show @@ -690,7 +691,7 @@ data Object = Blob (Maybe Int) Content | Reset Branch (Maybe RefId) | Commit Branch Marked AuthorInfo Message - | Tag Int AuthorInfo Message + | Tag Tag Int AuthorInfo Message | Modify (Either Int Content) B.ByteString -- (mark or content), filename | Gitlink B.ByteString | Copy CopyRenameNames @@ -819,11 +820,11 @@ BC.concat [BC.pack "pristine:", root] return Done - process (Toplevel n b) (Tag what author msg) = do + process (Toplevel n b) (Tag tag what author msg) = do if Just what == n then addtag author msg - else liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " ++ - head (lines $ decodeLocale msg) + else liftIO $ putStrLn $ + "WARNING: Ignoring out-of-order tag " ++ decodeLocale tag return (Toplevel n b) process (Toplevel n _) (Reset branch from) = @@ -1003,12 +1004,13 @@ message <- p_data return $ Commit branch mark committer message - p_tag = do _ <- lexString "tag" >> line -- FIXME we ignore branch for now + p_tag = do _ <- lexString "tag" + tag <- line lexString "from" mark <- p_marked author <- p_author "tagger" message <- p_data - return $ Tag mark author message + return $ Tag tag mark author message p_blob = do lexString "blob" mark <- optional p_mark diff --git a/src/Darcs/UI/Commands/Util/Tree.hs b/src/Darcs/UI/Commands/Util/Tree.hs --- a/src/Darcs/UI/Commands/Util/Tree.hs +++ b/src/Darcs/UI/Commands/Util/Tree.hs @@ -29,6 +29,7 @@ import Control.Monad ( forM ) import Control.Monad.State.Strict( gets ) +import Data.Maybe ( fromMaybe ) import qualified Darcs.Util.Tree.Monad as TM ( TreeMonad, withDirectory, fileExists, directoryExists @@ -52,7 +53,8 @@ existsAnycase (AnchoredPath []) = return True existsAnycase (AnchoredPath (x:xs)) = do wd <- TM.currentDirectory - Just tree <- gets (flip findTree wd . TM.tree) + tree <- fromMaybe (bug "invalid path passed to existsAnycase") <$> + gets (flip findTree wd . TM.tree) let subs = [ AnchoredPath [n] | (n, _) <- listImmediate tree, eqAnycase n x ] or `fmap` forM subs (\path -> do diff --git a/src/Darcs/Util/Tree.hs b/src/Darcs/Util/Tree.hs --- a/src/Darcs/Util/Tree.hs +++ b/src/Darcs/Util/Tree.hs @@ -417,9 +417,11 @@ partiallyUpdateTree fun predi t' = go (AnchoredPath []) t' where go path t = do items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t) - SubTree t'' <- fun . SubTree $ t { items = items' - , treeHash = NoHash } - return t'' + subtree <- fun . SubTree $ t { items = items' + , treeHash = NoHash } + case subtree of + SubTree t'' -> return t'' + _ -> bug "function passed to partiallyUpdateTree didn't changed SubTree to something else" maybeupdate path (k, item) = if predi (path `appendPath` k) item then update (path `appendPath` k) (k, item) else return (k, item) diff --git a/tests/data/patch-index-v2.tgz b/tests/data/patch-index-v2.tgz new file mode 100644 Binary files /dev/null and b/tests/data/patch-index-v2.tgz differ diff --git a/tests/patch-index-released.sh b/tests/patch-index-released.sh new file mode 100644 --- /dev/null +++ b/tests/patch-index-released.sh @@ -0,0 +1,40 @@ +#!/usr/bin/env bash + +# Check that the latest darcs can still use the patch index +# produced by released versions. + +. lib + +# A tarball of a repo with a v2 patch index, which at the +# time of writing was the version in use in the last released +# version of darcs. + +tar -xz < $TESTDATA/patch-index-v2.tgz + +cd pi + +# If darcs can't read the index but thinks it can, this will crash. +# If there's a new patch index format and the format version has +# been properly bumped, then darcs will simply delete and replace it +# and this command will work. +darcs annotate file1.txt + +# It would be nice to check that the released version of darcs also +# correctly handles any changes we make, but it's much harder to write +# a test that relies on the released version. + +# When a change is made to the patch index format, the +# format version should be bumped and a new sample repo should be +# added to this test, to ensure that the new format is properly +# covered by the tests as soon as it is released. + +# The "released" version above should be kept to maintain the +# guard against regressions. + +# If further changes to the format are made before the next release, +# it should be ok to keep the same (new) version, though it might +# mean developers/people using the bleeding edge see some breakage. + +# Once the release happens, it should be ok to delete the test for +# the old format, on the assumption we are unlikely to make a gross +# mistake like decrementing the format version.