diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +Darcs 2.18.4, 26 Oct 2024 + + * darcs can now be built with stack against stackage lts-22.34, which is + the version that the debian haskell team currently targets + + * resolve issue2725: the permissions of _darcs/patch_index are now + generically set to those of its parent directory + Darcs 2.18.3, 26 May 2024 * relax upper bounds for some 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.3 +version: 2.18.4 License: GPL-2.0-or-later License-file: COPYING Author: David Roundy , @@ -376,6 +376,7 @@ Darcs.Util.Show Darcs.Util.SignalHandler Darcs.Util.Ssh + Darcs.Util.StrictIdentity Darcs.Util.Tree Darcs.Util.Tree.Hashed Darcs.Util.Tree.Monad @@ -408,9 +409,12 @@ System.Posix.IO cpp-options: -DWIN32 c-sources: src/win32/send_email.c - build-depends: Win32 >= 2.4.0 && < 2.14 + build-depends: Win32 >= 2.4.0 && < 2.14, + -- exclude 1.3.8 .. 1.3.8.4 due to bug on windows + directory >= 1.2.7 && < 1.3.8 || >= 1.3.8.5 && < 1.4 else - build-depends: unix >= 2.7.1.0 && < 2.9 + build-depends: unix >= 2.7.1.0 && < 2.9, + directory >= 1.2.7 && < 1.4 build-depends: base >= 4.10 && < 4.20, safe >= 0.3.20 && < 0.4, @@ -443,7 +447,6 @@ old-time >= 1.1.0.3 && < 1.2, time >= 1.9 && < 1.15, text >= 1.2.1.3 && < 2.2, - directory >= 1.2.7 && < 1.3.8 || >= 1.3.8.5 && < 1.4, temporary >= 1.2.1 && < 1.4, process >= 1.2.3.0 && < 1.7, array >= 0.5.1.0 && < 0.6, @@ -456,10 +459,9 @@ http-conduit >= 2.3 && < 2.4, http-types >= 0.12.1 && < 0.12.5, exceptions >= 0.6 && < 0.11, - terminal-size >= 0.3.4 && < 0.4, - strict-identity >= 0.1 && < 0.2 + terminal-size >= 0.3.4 && < 0.4 - if impl(ghc >= 9.6) + if impl(ghc >= 9.8) cpp-options: -DHAVE_CRYPTON_CONNECTION build-depends: crypton-connection >= 0.4 && < 0.5, data-default-class >= 0.1.2.0 && < 0.1.3, 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.3\nBen Franksen **20240526105046\n Ignore-this: d3e6c8390966c8137d2a7bdcc4a8200b0c83b2af75e66c92f992aec1d8dd34426a40b1d28d59ebc\n] \n" +Just "\nContext:\n\n\n[TAG 2.18.4\nBen Franksen **20241026093913\n Ignore-this: ad4cc2fd8d9a9ab11ff36ddfdb8b5de208bfe44568255edfc95bcb92dedbee11e37613fd59d88f95\n] \n" diff --git a/src/Darcs/Patch/ApplyMonad.hs b/src/Darcs/Patch/ApplyMonad.hs --- a/src/Darcs/Patch/ApplyMonad.hs +++ b/src/Darcs/Patch/ApplyMonad.hs @@ -37,12 +37,12 @@ import qualified Data.ByteString.Lazy as BL import qualified Darcs.Util.Tree.Monad as TM import Darcs.Patch.Object ( ObjectIdOf ) +import Darcs.Util.StrictIdentity (StrictIdentity(..) ) import Darcs.Util.Tree ( Tree ) import Data.Maybe ( fromMaybe ) import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix ) import Control.Monad.Catch ( MonadThrow(..) ) import Control.Monad.State.Strict -import Control.Monad.StrictIdentity (StrictIdentity(..) ) import GHC.Exts ( Constraint ) 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 @@ -59,6 +59,7 @@ , removeDirectoryRecursive , removeFile , renameDirectory + , copyPermissions ) import System.FilePath( () ) import System.IO ( openFile, IOMode(WriteMode), hClose ) @@ -526,6 +527,7 @@ debugMessage "Patch index created" return tmpdir removeDirectoryRecursive cdir `catch` \(_ :: IOError) -> return () + copyPermissions darcsdir tmpdir renameDirectory tmpdir cdir decodeFile :: Binary a => FilePath -> IO a diff --git a/src/Darcs/Util/StrictIdentity.hs b/src/Darcs/Util/StrictIdentity.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/StrictIdentity.hs @@ -0,0 +1,94 @@ +-- copied (and minimally adapted) from strict-identity-0.1.0.0 +-- which apparently has been abandoned +{- | +Module : Control.Monad.StrictIdentity +Copyright : (c) Carter Schonwald 2013 +License : BSD3, see license file + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : portable +-} +{-# LANGUAGE BangPatterns #-} + +module Darcs.Util.StrictIdentity ( + StrictIdentity(..), + runStrictIdentity) + where + +import Darcs.Prelude +import Control.Monad.Fix + + +{- | 'StrictIdentity' is a newtype wrapper for a given type 'a' that +satisfies the 'Functor', 'Applicative', and 'Monad' laws when restricted to +terminating strict computations. + +The typical use case is to provide a light weight strict nested +let notation for code that otherwise must use nested case expressions +as a proxy for a strict let. + +the general pattern is to write code of the form + +@ +foo f h g x y z = runStrictIdentity $! do + w <- return $! f x y + j <- return $! h w z + res <- return $! g w j + return res +@ + +An example usage of 'StrictIdentity' that compiles to assembly +comparable to C is the following: + +@ +(>>) = unsafeShiftR +(<<) = unsafeShiftL +outerShuffle64A :: Word -> Word +outerShuffle64A !x = + runStrictIdentity $! do + x <- return $! ((x .&. 0x00000000FFFF0000) << 16 ) + .|. ((x>>16) .&. 0x00000000FFFF0000) .|. (x .&. 0xFFFF00000000FFFF) + x <- return $! ((x .&. 0x0000FF000000FF00 ) << 8 ) + .|. (x >> 8) .&. 0x0000FF000000FF00 .|. (x .&. 0xFF0000FFFF0000FF) + x<- return $! (( x .&. 0x00F000F000F000F0 ) << 4 ) + .|. (x >> 4) .&. 0x00F000F000F000F0 .|. (x .&. 0xF00FF00FF00FF00F ) + x<- return $!((x .&. 0x0C0C0C0C0C0C0C0C )<< 2 ) + .|. (x >> 2) .&. 0x0C0C0C0C0C0C0C0C .|.( x .&. 0xC3C3C3C3C3C3C3C3) + x<- return $! ( (x .&. 0x2222222222222222) << 1 ) + .|. (x>> 1) .&. 0x2222222222222222 .|. (x .&. 0x9999999999999999) + return x +@ + + +-} + +newtype StrictIdentity a = StrictIdentity {runStrictIdentity_ :: a } + +-- | 'runStrictIdentity' unwraps a value of type @'StrictIdentity' ty@ into a value of type @ty@, strictly. +runStrictIdentity :: StrictIdentity a -> a +runStrictIdentity !ma = case runStrictIdentity_ $! ma of + !res -> res +{-# INLINE runStrictIdentity #-} + + +instance Applicative StrictIdentity where + {-# INLINE pure #-} + pure !a = StrictIdentity $! a + {-# INLINE (<*>) #-} + (<*>) a b = do f <- a ; v <- b ; return $! (f $! v) + -- ap a b = liftM2 id a b = do f <- a ; v<- b ; return ((id) ) + +instance Functor StrictIdentity where + {-# INLINE fmap #-} + fmap !f !m = StrictIdentity $! (f $! (runStrictIdentity m)) + +instance Monad StrictIdentity where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + (!m) >>= (!k) = k $! runStrictIdentity m + --StrictIdentity m >>= k = k $! m +instance MonadFix StrictIdentity where + {-# INLINE mfix #-} + mfix !f = StrictIdentity $! (fix (runStrictIdentity . f))