diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +Darcs 2.14.3, 24 April 2020 + + * Support for GHC 8.8 and GHC 8.10 + * Loosen upper bounds for a few dependencies + * mitigate issue 2643 (corrupt patch index) with a better error message + * remove our own optimisation settings in darcs.cabal + * Setup.hs: allow use of darcs as a cabal subproject + Darcs 2.14.2, 26 January 2019 * Support GHC 8.6 (Ganesh Sittampalam) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,7 +10,33 @@ Compiling --------- -Build instructions are available at . +Build instructions are available at but they may +not be up-to-date. + +Here is a quick run down. The easiest way to build darcs is by using +cabal-install version 3.2 or later. A plain + +> cabal build + +should work out of the box with any ghc-8.x version. You may see some cabal +warnings. Ignore them. If you want to run the tests, you need + +> cabal build --enable-tests + +This can be made permanent by using + +> cabal configure --enable-tests + +before building, which is useful mainly for development. Or you can combine +building and testing: + +> cabal test --test-show-details=streaming + +You can also run + +> cabal install + +to install the library and the executable. Using ----- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,7 +1,8 @@ -- copyright (c) 2008 Duncan Coutts -- portions copyright (c) 2008 David Roundy -- portions copyright (c) 2007-2009 Judah Jacobson - +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# LANGUAGE CPP #-} import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.ModuleName( toFilePath ) @@ -21,17 +22,26 @@ import Distribution.Simple.Setup (buildVerbosity, copyDest, copyVerbosity, fromFlag, haddockVerbosity, installVerbosity, sDistVerbosity, replVerbosity ) +#if MIN_VERSION_Cabal(3,0,0) +import Distribution.Simple.BuildPaths ( autogenPackageModulesDir ) +#else import Distribution.Simple.BuildPaths ( autogenModulesDir ) +#endif import Distribution.System ( OS(Windows), buildOS ) import Distribution.Simple.Utils (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout, - rewriteFile ) +#if MIN_VERSION_Cabal(3,0,0) + rewriteFileEx +#else + rewriteFile +#endif + ) import Distribution.Verbosity - ( Verbosity ) + ( Verbosity, silent ) import Distribution.Text ( display ) -import Control.Monad ( unless, void ) +import Control.Monad ( unless, void, when ) import System.Directory ( doesDirectoryExist, doesFileExist ) @@ -48,6 +58,11 @@ import qualified Control.Exception as Exception +#if MIN_VERSION_Cabal(3,0,0) +autogenModulesDir = autogenPackageModulesDir +rewriteFile = rewriteFileEx silent +#endif + catchAny :: IO a -> (Exception.SomeException -> IO a) -> IO a catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException)) @@ -70,6 +85,7 @@ postInst = \ _ flags pkg lbi -> installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest, +#if !MIN_VERSION_Cabal(3,0,0) sDistHook = \ pkg lbi hooks flags -> do let pkgVer = packageVersion pkg verb = fromFlag $ sDistVerbosity flags @@ -85,6 +101,7 @@ sDistHook simpleUserHooks pkg' lbi hooks flags , +#endif postConf = \_ _ _ _ -> return () --- Usually this checked for external C --- dependencies, but we already have performed such --- check in the confHook @@ -137,13 +154,18 @@ buildManpage lbi = do let darcs = buildDir lbi "darcs/darcs" manpage = buildDir lbi "darcs/darcs.1" - manpageHandle <- openFile manpage WriteMode - void $ runProcess darcs ["help","manpage"] + darcsExists <- doesFileExist darcs + when darcsExists $ do + manpageHandle <- openFile manpage WriteMode + void $ runProcess darcs ["help","manpage"] Nothing Nothing Nothing (Just manpageHandle) Nothing installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () -installManpage pkg lbi verbosity copy = +installManpage pkg lbi verbosity copy = do + let manpage = buildDir lbi "darcs/darcs.1" + manpageExists <- doesFileExist manpage + when manpageExists $ do copyFiles verbosity (mandir (absoluteInstallDirs pkg lbi copy) "man1") [(buildDir lbi "darcs", "darcs.1")] diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,6 @@ +cabal-version: 1.24 Name: darcs -version: 2.14.2 +version: 2.14.3 License: GPL-2 License-file: COPYING Author: David Roundy , @@ -33,29 +34,37 @@ Homepage: http://darcs.net/ Build-Type: Custom -Cabal-Version: >= 1.24 extra-source-files: - -- C headers + -- C files + src/*.c src/*.h - src/win32/send_email.h src/win32/sys/mman.h + src/win32/send_email.c + src/win32/send_email.h + src/win32/sys/mman.h - -- The contrib directory would make a sensible 'darcs-contrib' package - contrib/_darcs.zsh, contrib/darcs_completion, - contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi, - contrib/darcs-errors.hlint, - contrib/runHLint.sh, + contrib/cygwin-wrapper.bash + contrib/darcs_completion + contrib/darcs-errors.hlint + contrib/_darcs.zsh + contrib/runHLint.sh + contrib/update_roundup.pl + contrib/upload.cgi - README.md, CHANGELOG + README.md + CHANGELOG -- release data - release/distributed-version, release/distributed-context + release/distributed-version + release/distributed-context -- testsuite - tests/data/*.tgz tests/data/README + tests/data/*.tgz + tests/data/README tests/data/*.dpatch tests/data/example_binary.png - tests/data/convert/darcs1/*.dpatch tests/data/convert/darcs2/*.dpatch + tests/data/convert/darcs1/*.dpatch + tests/data/convert/darcs2/*.dpatch tests/*.sh tests/README.test_maintainers.txt tests/bin/*.hs @@ -93,15 +102,11 @@ flag executable description: Build darcs executable default: True + manual: True flag rts default: False --- We need optimizations by default, regardless of what Hackage says -flag optimize - default: True - description: Build with optimizations (-O2) - flag warn-as-error default: False manual: True @@ -112,7 +117,7 @@ -- ---------------------------------------------------------------------- custom-setup - setup-depends: base >= 4.9 && < 4.13, + setup-depends: base >= 4.9 && < 4.15, Cabal >= 1.24, process >= 1.2.3.0 && < 1.7, filepath >= 1.4.1 && < 1.5.0.0, @@ -352,6 +357,7 @@ Darcs.Util.URL Darcs.Util.Workaround + autogen-modules: Version other-modules: Version Darcs.Util.Download.Curl @@ -380,7 +386,7 @@ else build-depends: unix >= 2.7.1.0 && < 2.8 - build-depends: base >= 4.9 && < 4.13, + build-depends: base >= 4.9 && < 4.15, stm >= 2.1 && < 2.6, binary >= 0.5 && < 0.10, containers >= 0.5.6.2 && < 0.7, @@ -393,7 +399,7 @@ graphviz >= 2999.18.1 && < 2999.20.1, html >= 1.0.1.2 && < 1.1, filepath >= 1.4.1 && < 1.5.0.0, - haskeline >= 0.7.2 && < 0.8, + haskeline >= 0.7.2 && < 0.9, cryptohash >= 0.11 && < 0.12, base16-bytestring >= 0.1 && < 0.2, utf8-string >= 1 && < 1.1, @@ -403,7 +409,7 @@ attoparsec >= 0.13.0.1 && < 0.14, zip-archive >= 0.3 && < 0.5, async >= 2.0.2 && < 2.3, - sandi >= 0.4 && < 0.5, + sandi >= 0.4 && < 0.6, unix-compat >= 0.4.2 && < 0.6, bytestring >= 0.10.6 && < 0.11, old-time >= 1.1.0.3 && < 1.2, @@ -413,18 +419,13 @@ process >= 1.2.3.0 && < 1.7, array >= 0.5.1.0 && < 0.6, random >= 1.1 && < 1.2, - hashable >= 1.2.3.3 && < 1.3, + hashable >= 1.2.3.3 && < 1.4, mmap >= 0.5.9 && < 0.6, zlib >= 0.6.1.2 && < 0.7.0.0, network-uri == 2.6.*, - network >= 2.6 && < 2.9, + network >= 2.6 && < 3.2, HTTP >= 4000.2.20 && < 4000.4 - if flag(optimize) - ghc-options: -O2 - else - ghc-options: -O0 - if flag(warn-as-error) ghc-options: -Werror @@ -476,14 +477,12 @@ main-is: darcs.hs hs-source-dirs: darcs - if flag(optimize) - ghc-options: -O2 - else - ghc-options: -O0 - if flag(warn-as-error) ghc-options: -Werror + if impl(ghc >= 8.2) + ghc-options: -Wno-missing-home-modules + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs if flag(threaded) @@ -498,8 +497,7 @@ -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT - build-depends: darcs, - base >= 4.9 && < 4.13 + build-depends: darcs, base -- ---------------------------------------------------------------------- -- unit test driver @@ -517,26 +515,31 @@ build-depends: Win32 >= 2.3.1 && < 2.4 build-depends: darcs, - base >= 4.9 && < 4.13, - array >= 0.5.1.0 && < 0.6, - bytestring >= 0.10.6 && < 0.11, + base, + array, + bytestring, cmdargs >= 0.10.10 && < 0.11, - containers >= 0.5.6.2 && < 0.7, - filepath >= 1.4.1 && < 1.5.0.0, - mtl >= 2.2.1 && < 2.3, - shelly >= 1.6.8 && < 1.9, + containers, + filepath, + mtl, + transformers, + shelly >= 1.6.8 && < 1.10, split >= 0.2.2 && < 0.3, - text >= 1.2.1.3 && < 1.3, - directory >= 1.2.6.2 && < 1.4, + text, + directory, FindBin >= 0.0.5 && < 0.1, - QuickCheck >= 2.8.2 && < 2.13, + QuickCheck >= 2.8.2 && < 2.14, 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.5 + zip-archive - -- https://github.com/yesodweb/Shelly.hs/issues/177 + -- note for windows we can't allow 1.9 or above until + -- https://github.com/gregwebs/Shelly.hs/issues/176 + -- and possibly + -- https://github.com/gregwebs/Shelly.hs/issues/177 + -- are dealt with if os(windows) build-depends: shelly < 1.7.2 @@ -575,13 +578,11 @@ Darcs.Test.Util.TestResult Darcs.Test.Util.QuickCheck - if flag(optimize) - ghc-options: -O2 - else - ghc-options: -O0 - if flag(warn-as-error) ghc-options: -Werror + + if impl(ghc >= 8.2) + ghc-options: -Wno-missing-home-modules ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -fno-warn-orphans diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs @@ -27,9 +27,8 @@ import Darcs.Patch.Prim -import Control.Applicative ( (<$>) ) import qualified Data.ByteString as B -import Data.Maybe ( isJust ) +import Data.Maybe ( fromJust, isJust ) import qualified Data.Map as M import Darcs.Util.Hash( Hash(..) ) 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 @@ -36,7 +36,7 @@ import Darcs.Patch.Apply ( ApplyState ) import qualified Data.ByteString.Char8 as BC -import Data.Maybe ( isJust ) +import Data.Maybe ( fromJust, isJust ) type Prim1 = V1.Prim type Prim2 = V2.Prim 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,26 +15,24 @@ -- 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, +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +module Darcs.Test.Patch.Check ( PatchCheck, doCheck, fileExists, dirExists, removeFile, removeDir, createFile, createDir, - insertLine, deleteLine, isValid, doVerboseCheck, + insertLine, deleteLine, isValid, fileEmpty, - checkMove, modifyFile, FileContents(..) + checkMove, modifyFile, FileContents(..), + inconsistent, handleInconsistent ) where import Prelude () import Darcs.Prelude -import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString as B (ByteString) import Data.List ( isPrefixOf, inits ) -import Control.Monad.State ( State, evalState, runState ) +import Control.Monad.State ( State, evalState ) +import Control.Monad.Trans.Maybe ( MaybeT(..) ) 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 ) +import qualified Data.IntMap as M ( IntMap, mapKeys, delete, insert, empty, lookup, null ) import System.FilePath ( joinPath, splitDirectories ) -- | File contents are represented by a map from line numbers to line contents. @@ -43,39 +41,47 @@ -- We must also store the greatest line number that is known to exist in a -- file, to be able to exclude the possibility of it being empty without -- knowing its contents. -data FileContents = FC { fcLines :: Map Int B.ByteString +data FileContents = FC { fcLines :: M.IntMap B.ByteString , fcMaxline :: Int } deriving (Eq, Show) data Prop = FileEx String | DirEx String | NotEx String | FileLines String FileContents deriving (Eq) --- | A @KnownState@ is a simulated repository state. The repository is either --- inconsistent, or it has two lists of properties: one list with properties --- that hold for this repo, and one with properties that do not hold for this --- repo. These two lists may not have any common elements: if they had, the --- repository would be inconsistent. -data KnownState = P [Prop] [Prop] - | Inconsistent - deriving (Show) + instance Show Prop where show (FileEx f) = "FileEx "++f show (DirEx d) = "DirEx "++d show (NotEx f) = "NotEx"++f show (FileLines f l) = "FileLines "++f++": "++show l --- TODO the way that the standard way to use PatchCheck is --- by returning PatchCheck Bool but then often ignoring the --- result and instead checking again for state consistency --- is weird. It should be possible to replace it by a more normal --- error handling mechanism. +-- | A simulated repository state. The repository is assumed to be +-- consistent, and it has two lists of properties: one list with properties +-- that hold for this repo, and one with properties that do not hold for this +-- repo. These two lists may not have any common elements: if they had, the +-- repository would be inconsistent. +data ValidState = P [Prop] [Prop] deriving Show -- | PatchCheck is a state monad with a simulated repository state -newtype PatchCheck a = PatchCheck { runPatchCheck :: State KnownState a } - deriving (Functor, Applicative, Monad, MonadState KnownState) +newtype PatchCheck a = PatchCheck { runPatchCheck :: MaybeT (State ValidState) a } + deriving (Functor, Applicative, Monad, MonadState ValidState) -instance MonadFail PatchCheck where - fail = error +-- The existing instance definitions in Control.Monad.Except make it +-- impossible to provide an 'instance MonadError () (MaybeT m)'. +throwPC :: PatchCheck a +throwPC = PatchCheck $ MaybeT $ return Nothing + +catchPC :: PatchCheck a -> PatchCheck a -> PatchCheck a +PatchCheck m `catchPC` h = + PatchCheck $ MaybeT $ do + a <- runMaybeT m + case a of + Nothing -> runMaybeT (runPatchCheck h) + Just r -> return (Just r) + +inconsistent :: PatchCheck () +inconsistent = throwPC + -- | The @FileContents@ structure for an empty file emptyFilecontents :: FileContents emptyFilecontents = FC M.empty 0 @@ -85,41 +91,30 @@ handleInconsistent :: a -- ^ The value to return if the state is inconsistent -> PatchCheck a -- ^ The action to perform otherwise -> PatchCheck a -handleInconsistent v a = do state <- get - case state of - Inconsistent -> return v - _ -> a - -doCheck :: PatchCheck a -> a -doCheck p = evalState (runPatchCheck p) (P [] []) +handleInconsistent v a = a `catchPC` return v --- | Run a check, and print the final repository state -doVerboseCheck :: PatchCheck a -> a -doVerboseCheck p = - case runState (runPatchCheck p) (P [] []) of - (b, pc) -> unsafePerformIO $ do print pc - return b +doCheck :: PatchCheck a -> Bool +doCheck p = + evalState (maybe False (const True) <$> runMaybeT (runPatchCheck p)) (P [] []) --- | Returns true if the current repository state is not inconsistent -isValid :: PatchCheck Bool -isValid = handleInconsistent False (return True) +isValid :: PatchCheck () +isValid = return () has :: Prop -> [Prop] -> Bool has _ [] = False has k (k':ks) = k == k' || has k ks modifyFile :: String - -> (Maybe FileContents -> Maybe FileContents) - -> PatchCheck Bool + -> (Maybe FileContents -> Maybe FileContents) + -> PatchCheck () modifyFile f change = do - _ <- fileExists f + fileExists f c <- fileContents f case change c of Nothing -> assertNot $ FileEx f -- shorthand for "FAIL" - Just c' -> do setContents f c' - isValid + Just c' -> setContents f c' -insertLine :: String -> Int -> B.ByteString -> PatchCheck Bool +insertLine :: String -> Int -> B.ByteString -> PatchCheck () insertLine f n l = do c <- fileContents f case c of @@ -129,11 +124,10 @@ lines'' = M.insert n l lines' maxline' = max n (fcMaxline c') setContents f (FC lines'' maxline') - return True -- deletes a line from a hunk patch (third argument) in the given file (first -- argument) at the given line number (second argument) -deleteLine :: String -> Int -> B.ByteString -> PatchCheck Bool +deleteLine :: String -> Int -> B.ByteString -> PatchCheck () deleteLine f n l = do c <- fileContents f case c of @@ -145,9 +139,7 @@ maxlinenum' | n <= fcMaxline c' = fcMaxline c' - 1 | otherwise = n - 1 c'' = FC flines' maxlinenum' - do_delete = do - setContents f c'' - isValid + do_delete = setContents f c'' in case M.lookup n flines of Nothing -> do_delete Just l' -> if l == l' @@ -155,7 +147,7 @@ else assertNot $ FileEx f setContents :: String -> FileContents -> PatchCheck () -setContents f c = handleInconsistent () $ do +setContents f c = do P ks nots <- get let ks' = FileLines f c : filter (not . is_file_lines_for f) ks put (P ks' nots) @@ -166,7 +158,7 @@ -- | Get (as much as we know about) the contents of a file in the current state. -- Returns Nothing if the state is inconsistent. fileContents :: String -> PatchCheck (Maybe FileContents) -fileContents f = handleInconsistent Nothing $ do +fileContents f = do P ks _ <- get return (fic ks) where fic (FileLines f' c:_) | f == f' = Just c @@ -174,19 +166,16 @@ fic [] = Just emptyFilecontents -- | Checks if a file is empty -fileEmpty :: String -- ^ Name of the file to check - -> PatchCheck Bool +fileEmpty :: String -> PatchCheck () fileEmpty f = do c <- fileContents f let empty = case c of Just c' -> fcMaxline c' == 0 && M.null (fcLines c') Nothing -> True - _ <- if empty - then do setContents f emptyFilecontents - isValid + if empty + then setContents f emptyFilecontents -- Crude way to make it inconsistent and return false: else assertNot $ FileEx f - return empty movedirfilename :: String -> String -> String -> String movedirfilename d d' f @@ -196,10 +185,8 @@ -- | Replaces a filename by another in all paths. Returns True if the repository -- is consistent, False if it is not. -doSwap :: String -> String -> PatchCheck Bool -doSwap f f' = handleInconsistent False $ do - modify map_sw - return True +doSwap :: String -> String -> PatchCheck () +doSwap f f' = modify map_sw where sw (FileEx a) | f `is_soe` a = FileEx $ movedirfilename f f' a | f' `is_soe` a = FileEx $ movedirfilename f' f a sw (DirEx a) | f `is_soe` a = DirEx $ movedirfilename f f' a @@ -212,124 +199,108 @@ is_soe d1 d2 = -- is_superdir_or_equal d1 == d2 || (d1 ++ "/") `isPrefixOf` d2 map_sw (P ks nots) = P (map sw ks) (map sw nots) - map_sw _ = impossible -- | Assert a property about the repository. If the property is already present -- in the repo state, nothing changes, and the function returns True. If it is -- not present yet, it is added to the repo state, and the function is True. If -- the property is already in the list of properties that do not hold for the -- repo, the state becomes inconsistent, and the function returns false. -assert :: Prop -> PatchCheck Bool -assert p = handleInconsistent False $ do +assert :: Prop -> PatchCheck () +assert p = do P ks nots <- get if has p nots - then do - put Inconsistent - return False + then inconsistent else if has p ks - then return True - else do - put (P (p:ks) nots) - return True + then isValid + else put (P (p:ks) nots) -- | Like @assert@, but negatively: state that some property must not hold for -- the current repo. -assertNot :: Prop -> PatchCheck Bool -assertNot p = handleInconsistent False $ do +assertNot :: Prop -> PatchCheck () +assertNot p = do P ks nots <- get if has p ks - then do - put Inconsistent - return False + then inconsistent else if has p nots - then return True - else do - put (P ks (p:nots)) - return True + then isValid + else put (P ks (p:nots)) -- | Remove a property from the list of properties that do not hold for this -- repo (if it's there), and add it to the list of properties that hold. -- Returns False if the repo is inconsistent, True otherwise. -changeToTrue :: Prop -> PatchCheck Bool -changeToTrue p = handleInconsistent False $ do - modify filter_nots - return True - where filter_nots (P ks nots) = P (p:ks) (filter (p /=) nots) - filter_nots _ = impossible +changeToTrue :: Prop -> PatchCheck () +changeToTrue p = modify filter_nots + where filter_nots (P ks nots) = P (p:ks) (filter (p /=) nots) -- | Remove a property from the list of properties that hold for this repo (if -- it's in there), and add it to the list of properties that do not hold. -- Returns False if the repo is inconsistent, True otherwise. -changeToFalse :: Prop -> PatchCheck Bool -changeToFalse p = handleInconsistent False $ do +changeToFalse :: Prop -> PatchCheck () +changeToFalse p = do modify filter_ks - return True where filter_ks (P ks nots) = P (filter (p /=) ks) (p:nots) - filter_ks _ = impossible -assertFileExists :: String -> PatchCheck Bool -assertFileExists f = do _ <- assertNot $ NotEx f - _ <- assertNot $ DirEx f +assertFileExists :: String -> PatchCheck () +assertFileExists f = do assertNot $ NotEx f + assertNot $ DirEx f assert $ FileEx f -assertDirExists :: String -> PatchCheck Bool -assertDirExists d = do _ <- assertNot $ NotEx d - _ <- assertNot $ FileEx d +assertDirExists :: String -> PatchCheck () +assertDirExists d = do assertNot $ NotEx d + assertNot $ FileEx d assert $ DirEx d -assertExists :: String -> PatchCheck Bool +assertExists :: String -> PatchCheck () assertExists f = assertNot $ NotEx f -assertNoSuch :: String -> PatchCheck Bool -assertNoSuch f = do _ <- assertNot $ FileEx f - _ <- assertNot $ DirEx f +assertNoSuch :: String -> PatchCheck () +assertNoSuch f = do assertNot $ FileEx f + assertNot $ DirEx f assert $ NotEx f -createFile :: String -> PatchCheck Bool +createFile :: String -> PatchCheck () createFile fn = do - _ <- superdirsExist fn - _ <- assertNoSuch fn - _ <- changeToTrue (FileEx fn) + superdirsExist fn + assertNoSuch fn + changeToTrue (FileEx fn) changeToFalse (NotEx fn) -createDir :: String -> PatchCheck Bool +createDir :: String -> PatchCheck () createDir fn = do - _ <- substuffDontExist fn - _ <- superdirsExist fn - _ <- assertNoSuch fn - _ <- changeToTrue (DirEx fn) + substuffDontExist fn + superdirsExist fn + assertNoSuch fn + changeToTrue (DirEx fn) changeToFalse (NotEx fn) -removeFile :: String -> PatchCheck Bool +removeFile :: String -> PatchCheck () removeFile fn = do - _ <- superdirsExist fn - _ <- assertFileExists fn - _ <- fileEmpty fn - _ <- changeToFalse (FileEx fn) + superdirsExist fn + assertFileExists fn + fileEmpty fn + changeToFalse (FileEx fn) changeToTrue (NotEx fn) -removeDir :: String -> PatchCheck Bool +removeDir :: String -> PatchCheck () removeDir fn = do - _ <- substuffDontExist fn - _ <- superdirsExist fn - _ <- assertDirExists fn - _ <- changeToFalse (DirEx fn) + substuffDontExist fn + superdirsExist fn + assertDirExists fn + changeToFalse (DirEx fn) changeToTrue (NotEx fn) -checkMove :: String -> String -> PatchCheck Bool +checkMove :: String -> String -> PatchCheck () checkMove f f' = do - _ <- superdirsExist f - _ <- superdirsExist f' - _ <- assertExists f - _ <- assertNoSuch f' + superdirsExist f + superdirsExist f' + assertExists f + assertNoSuch f' doSwap f f' -substuffDontExist :: String -> PatchCheck Bool -substuffDontExist d = handleInconsistent False $ do +substuffDontExist :: String -> PatchCheck () +substuffDontExist d = do P ks _ <- get if all noss ks - then return True - else do - put Inconsistent - return False + then isValid + else inconsistent where noss (FileEx f) = not (is_within_dir f) noss (DirEx f) = not (is_within_dir f) noss _ = True @@ -338,17 +309,17 @@ -- the init and tail calls dump the final init (which is just the path itself -- again), the first init (which is empty), and the initial "." from -- splitDirectories -superdirsExist :: String -> PatchCheck Bool -superdirsExist fn = and `fmap` mapM assertDirExists superdirs +superdirsExist :: String -> PatchCheck () +superdirsExist fn = mapM_ assertDirExists superdirs where superdirs = map (("./"++) . joinPath) (init (tail (inits (tail (splitDirectories fn))))) -fileExists :: String -> PatchCheck Bool +fileExists :: String -> PatchCheck () fileExists fn = do - _ <- superdirsExist fn + superdirsExist fn assertFileExists fn -dirExists :: String -> PatchCheck Bool +dirExists :: String -> PatchCheck () dirExists fn = do - _ <- superdirsExist fn + superdirsExist fn assertDirExists fn diff --git a/harness/Darcs/Test/Patch/Examples/Set1.hs b/harness/Darcs/Test/Patch/Examples/Set1.hs --- a/harness/Darcs/Test/Patch/Examples/Set1.hs +++ b/harness/Darcs/Test/Patch/Examples/Set1.hs @@ -24,6 +24,7 @@ import Prelude () import Darcs.Prelude +import Data.Maybe ( fromJust ) import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.ByteString.Char8 as BC ( pack ) import qualified Data.ByteString as B ( empty ) diff --git a/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs b/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs --- a/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs +++ b/harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs @@ -25,7 +25,6 @@ import Data.Maybe ( catMaybes ) import qualified Data.ByteString.Char8 as BC ( pack ) import Darcs.Patch.Witnesses.Sealed -import Darcs.Patch ( invert, hunk ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Prim ( PrimPatch, fromPrim ) import Darcs.Patch.V2 ( RepoPatchV2 ) 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 @@ -33,10 +33,10 @@ import Darcs.Util.Path ( Name, unsafeMakeName ) import Darcs.Util.Hash( Hash(..) ) -import Control.Applicative ( (<$>) ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.Map as M +import Data.Maybe ( fromJust ) import Test.QuickCheck ( Arbitrary(..) , Gen, choose, vectorOf, frequency, oneof ) diff --git a/harness/Darcs/Test/Patch/Properties/Check.hs b/harness/Darcs/Test/Patch/Properties/Check.hs --- a/harness/Darcs/Test/Patch/Properties/Check.hs +++ b/harness/Darcs/Test/Patch/Properties/Check.hs @@ -4,20 +4,19 @@ import Prelude () import Darcs.Prelude import Control.Monad ( liftM ) -import Data.Maybe ( isNothing ) import Darcs.Test.Patch.Check ( PatchCheck, checkMove, removeDir, createDir, isValid, insertLine, fileEmpty, fileExists, deleteLine, modifyFile, createFile, removeFile, - doCheck, FileContents(..) + doCheck, inconsistent, FileContents(..) ) import Darcs.Patch.RegChars ( regChars ) import Darcs.Util.ByteString ( linesPS ) import qualified Data.ByteString as B ( ByteString, null, concat ) import qualified Data.ByteString.Char8 as BC ( break, pack ) import Darcs.Util.Path ( fn2fp ) -import qualified Data.Map as M ( mapMaybe ) +import qualified Data.IntMap as M ( mapMaybe ) import Darcs.Patch ( invert, effect, PrimPatch ) import Darcs.Patch.Invert ( Invert ) @@ -35,7 +34,7 @@ type Prim2 = V2.Prim class Check p where - checkPatch :: p wX wY -> PatchCheck Bool + checkPatch :: p wX wY -> PatchCheck () instance Check p => Check (FL p) where checkPatch NilFL = isValid @@ -45,11 +44,11 @@ checkPatch (p1 :> p2) = checkPatch p1 >> checkPatch p2 checkAPatch :: (Invert p, Check p) => p wX wY -> Bool -checkAPatch p = doCheck $ do _ <- checkPatch p +checkAPatch p = doCheck $ do checkPatch p checkPatch $ invert p instance PrimPatch prim => Check (RepoPatchV2 prim) where - checkPatch p = return $ isNothing $ isConsistent p + checkPatch p = maybe isValid (const inconsistent) $ isConsistent p instance Check (RepoPatchV1 Prim1) where checkPatch p | isMerger p = checkPatch $ effect p @@ -61,14 +60,14 @@ deriving instance Check Prim2 instance Check FileUUID.Prim where - checkPatch _ = return True -- XXX + checkPatch _ = isValid -- XXX instance Check Prim where checkPatch (FP f RmFile) = removeFile $ fn2fp f checkPatch (FP f AddFile) = createFile $ fn2fp f checkPatch (FP f (Hunk line old new)) = do - _ <- fileExists $ fn2fp f + fileExists $ fn2fp f mapM_ (deleteLine (fn2fp f) line) old mapM_ (insertLine (fn2fp f) line) (reverse new) isValid @@ -77,9 +76,9 @@ -- note that the above isn't really a sure check, as it leaves PSomethings -- and PNothings which may have contained new... checkPatch (FP f (Binary o n)) = do - _ <- fileExists $ fn2fp f + fileExists $ fn2fp f mapM_ (deleteLine (fn2fp f) 1) (linesPS o) - _ <- fileEmpty $ fn2fp f + fileEmpty $ fn2fp f mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n) isValid @@ -87,7 +86,7 @@ checkPatch (DP d RmDir) = removeDir $ fn2fp d checkPatch (Move f f') = checkMove (fn2fp f) (fn2fp f') - checkPatch (ChangePref _ _ _) = return True + checkPatch (ChangePref _ _ _) = isValid tryTokPossibly :: String -> String -> String -> (Maybe FileContents) -> (Maybe FileContents) diff --git a/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs b/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs --- a/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs +++ b/harness/Darcs/Test/Patch/Properties/RepoPatchV2.hs @@ -3,6 +3,7 @@ import Prelude () import Darcs.Prelude +import Data.Maybe ( fromJust ) import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree ) import Darcs.Test.Patch.WithState 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 @@ -2,7 +2,6 @@ import Darcs.Patch.Apply ( Apply, ApplyState ) import Darcs.Patch.Witnesses.Ordered ( FL ) -import Control.Monad.Fail ( MonadFail(fail) ) import Test.QuickCheck ( Gen ) data Fail a = Failed String | OK a @@ -22,9 +21,6 @@ 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 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.2\nGanesh Sittampalam **20190126112346\n Ignore-this: 5c94e042fbcfdf311008d6e980d9cf1d\n] \n" +Just "\nContext:\n\n\n[TAG 2.14.3\nBen Franksen **20200426190656\n Ignore-this: 21d97b8ff1af6e5d823789e49c08f75057f0a85eef34de7b605eae60501b2c1ce45e5e8dd84264da\n] \n" diff --git a/src/Darcs/Patch/Bundle.hs b/src/Darcs/Patch/Bundle.hs --- a/src/Darcs/Patch/Bundle.hs +++ b/src/Darcs/Patch/Bundle.hs @@ -64,7 +64,7 @@ ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS, decodeLocale ) import Darcs.Util.Hash ( sha1PS ) import Darcs.Util.Printer ( Doc, renderPS, newline, text, ($$), - (<>), vcat, vsep, renderString ) + vcat, vsep, renderString ) -- |hashBundle creates a SHA1 string of a given a FL of named patches. This -- allows us to ensure that the patches in a received patchBundle have not been diff --git a/src/Darcs/Patch/Depends.hs b/src/Darcs/Patch/Depends.hs --- a/src/Darcs/Patch/Depends.hs +++ b/src/Darcs/Patch/Depends.hs @@ -251,7 +251,7 @@ unwrapOneTagged :: (Monad m) => PatchSet rt p wX wY -> m (PatchSet rt p wX wY) unwrapOneTagged (PatchSet (ts :<: Tagged t _ tps) ps) = return $ PatchSet ts (tps :<: t +<+ ps) -unwrapOneTagged _ = fail "called unwrapOneTagged with no Tagged's in the set" +unwrapOneTagged _ = error "called unwrapOneTagged with no Tagged's in the set" -- | @getUncovered ps@ returns the 'PatchInfo' for all the patches in -- @ps@ that are not depended on by anything else *through explicit 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 @@ -78,7 +78,7 @@ import Data.List( isPrefixOf ) import Darcs.Util.Printer ( Doc, packedString, - empty, ($$), (<>), (<+>), vcat, text, cyanText, blueText, prefix ) + empty, ($$), (<+>), vcat, text, cyanText, blueText, prefix ) import Darcs.Util.IsoDate ( readUTCDate ) import System.Time ( CalendarTime, calendarTimeToString, toClockTime, toCalendarTime ) diff --git a/src/Darcs/Patch/Match.hs b/src/Darcs/Patch/Match.hs --- a/src/Darcs/Patch/Match.hs +++ b/src/Darcs/Patch/Match.hs @@ -421,7 +421,7 @@ Just m -> if nonrangeMatcherIsTag fs then getTagS m repo else getMatcherS Exclusive m repo - Nothing -> fail "Pattern not specified in getNonrangeMatch." + Nothing -> error "Pattern not specified in getNonrangeMatch." -- | @firstMatch fs@ tells whether @fs@ implies a "first match", that -- is if we match against patches from a point in the past on, rather @@ -441,7 +441,7 @@ Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a Nothing -> case firstMatcher fs of - Nothing -> fail "Pattern not specified in getFirstMatchS." + Nothing -> error "Pattern not specified in getFirstMatchS." Just m -> if firstMatcherIsTag fs then getTagS m repo else getMatcherS Inclusive m repo @@ -462,7 +462,7 @@ checkMatchSyntax opts = case getMatchPattern opts of Nothing -> return () - Just p -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch)) + Just p -> either error (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch)) getMatchPattern :: [MatchFlag] -> Maybe String getMatchPattern [] = Nothing @@ -718,7 +718,7 @@ getMatcherS ioe m repo = if matchExists m repo then applyInvToMatcher ioe m repo - else fail $ "Couldn't match pattern "++ show m + else error $ "Couldn't match pattern "++ show m getTagS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p) => Matcher rt p -> PatchSet rt p Origin wX -> m () diff --git a/src/Darcs/Patch/Named.hs b/src/Darcs/Patch/Named.hs --- a/src/Darcs/Patch/Named.hs +++ b/src/Darcs/Patch/Named.hs @@ -62,7 +62,7 @@ import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) ) import Darcs.Util.Printer - ( Doc, ($$), (<+>), (<>), prefix, text, vcat, cyanText, blueText ) + ( Doc, ($$), (<+>), prefix, text, vcat, cyanText, blueText ) -- | The @Named@ type adds a patch info about a patch, that is a name. data Named p wX wY where diff --git a/src/Darcs/Patch/Named/Wrapped.hs b/src/Darcs/Patch/Named/Wrapped.hs --- a/src/Darcs/Patch/Named/Wrapped.hs +++ b/src/Darcs/Patch/Named/Wrapped.hs @@ -56,7 +56,7 @@ import Darcs.Util.IsoDate ( getIsoDateTime ) import Darcs.Util.Text ( formatParas ) -import Darcs.Util.Printer ( ($$), (<>), vcat, prefix ) +import Darcs.Util.Printer ( ($$), vcat, prefix ) import Control.Applicative ( (<|>) ) diff --git a/src/Darcs/Patch/PatchInfoAnd.hs b/src/Darcs/Patch/PatchInfoAnd.hs --- a/src/Darcs/Patch/PatchInfoAnd.hs +++ b/src/Darcs/Patch/PatchInfoAnd.hs @@ -15,6 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE CPP #-} module Darcs.Patch.PatchInfoAnd ( Hopefully(..), SimpleHopefully(..), PatchInfoAnd(..), WPatchInfo, unWPatchInfo, compareWPatchInfo, piap, n2pia, patchInfoAndPatch, @@ -167,7 +168,13 @@ -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring. -hopefullyM :: Monad m => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB) +hopefullyM :: +#if MIN_VERSION_base(4,13,0) + MonadFail m +#else + Monad m +#endif + => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB) hopefullyM (PIAP pinf hp) = case hopefully2either hp of Right p -> return p Left e -> fail $ renderString diff --git a/src/Darcs/Patch/Prim/Class.hs b/src/Darcs/Patch/Prim/Class.hs --- a/src/Darcs/Patch/Prim/Class.hs +++ b/src/Darcs/Patch/Prim/Class.hs @@ -13,7 +13,6 @@ import Darcs.Prelude import Darcs.Patch.ApplyMonad ( ApplyMonad ) -import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk ) import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( FileNameFormat, PatchListFormat ) diff --git a/src/Darcs/Patch/Prim/FileUUID/Read.hs b/src/Darcs/Patch/Prim/FileUUID/Read.hs --- a/src/Darcs/Patch/Prim/FileUUID/Read.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Read.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns, OverloadedStrings #-} +{-# LANGUAGE CPP, ViewPatterns, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.FileUUID.Read () where @@ -8,7 +8,7 @@ import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.ReadMonads import Darcs.Patch.Prim.Class( PrimRead(..) ) -import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..), Location(..) ) +import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..) ) import Darcs.Patch.Prim.FileUUID.ObjectMap import Darcs.Patch.Witnesses.Sealed( seal ) import Darcs.Util.Path ( unsafeMakeName ) @@ -58,5 +58,6 @@ _ -> error "malformed filename" decodeWhite (BC.uncons -> Just (c, cs)) = c `BC.cons` decodeWhite cs decodeWhite (BC.uncons -> Nothing) = BC.empty +#if !MIN_VERSION_base(4,14,0) decodeWhite _ = impossible - +#endif diff --git a/src/Darcs/Patch/Prim/FileUUID/Show.hs b/src/Darcs/Patch/Prim/FileUUID/Show.hs --- a/src/Darcs/Patch/Prim/FileUUID/Show.hs +++ b/src/Darcs/Patch/Prim/FileUUID/Show.hs @@ -22,7 +22,7 @@ import Darcs.Util.Path ( Name, encodeWhiteName ) import Darcs.Util.Printer ( text, packedString, blueText, prefix - , (<+>), (<>), ($$), Doc, vcat + , (<+>), ($$), Doc, vcat ) -- TODO this instance shouldn't really be necessary, as Prims aren't used generically diff --git a/src/Darcs/Patch/Prim/V1/Apply.hs b/src/Darcs/Patch/Prim/V1/Apply.hs --- a/src/Darcs/Patch/Prim/V1/Apply.hs +++ b/src/Darcs/Patch/Prim/V1/Apply.hs @@ -28,7 +28,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BI -import qualified Data.ByteString as B ( ByteString, empty, null, concat ) import qualified Data.ByteString.Char8 as BC (pack, unpack, unlines) type FileContents = B.ByteString @@ -41,13 +40,13 @@ apply (FP f (TokReplace t o n)) = mModifyFilePS f doreplace where doreplace fc = case tryTokReplace t (BC.pack o) (BC.pack n) fc of - Nothing -> fail $ "replace patch to " ++ fn2fp f + Nothing -> error $ "replace patch to " ++ fn2fp f ++ " couldn't apply." Just fc' -> return fc' apply (FP f (Binary o n)) = mModifyFilePS f doapply where doapply oldf = if o == oldf then return n - else fail $ "binary patch to " ++ fn2fp f + else error $ "binary patch to " ++ fn2fp f ++ " couldn't apply." apply (DP d AddDir) = mCreateDirectory d apply (DP d RmDir) = mRemoveDirectory d @@ -115,7 +114,7 @@ case applyHunkLines h fc of Right fc' -> return fc' Left msg -> - fail $ + error $ "### Error applying:\n" ++ renderHunk h ++ "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack fc ++ "### Reason: " ++ msg diff --git a/src/Darcs/Patch/Prim/V1/Commute.hs b/src/Darcs/Patch/Prim/V1/Commute.hs --- a/src/Darcs/Patch/Prim/V1/Commute.hs +++ b/src/Darcs/Patch/Prim/V1/Commute.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Commute ( Perhaps(..) @@ -58,6 +59,9 @@ Failed >>= _ = Failed Unknown >>= _ = Unknown return = Succeeded +#if MIN_VERSION_base(4,13,0) +instance MonadFail Perhaps where +#endif fail _ = Unknown instance Alternative Perhaps where diff --git a/src/Darcs/Patch/Prim/V1/Show.hs b/src/Darcs/Patch/Prim/V1/Show.hs --- a/src/Darcs/Patch/Prim/V1/Show.hs +++ b/src/Darcs/Patch/Prim/V1/Show.hs @@ -26,7 +26,7 @@ import Darcs.Util.Path ( FileName ) import Darcs.Util.Printer ( Doc, vcat, text, userchunk, invisibleText, invisiblePS, blueText, - ($$), (<+>), (<>), + ($$), (<+>) ) import Darcs.Util.Show ( appPrec, BSWrapper(..) ) import Darcs.Util.Tree ( Tree ) diff --git a/src/Darcs/Patch/ReadMonads.hs b/src/Darcs/Patch/ReadMonads.hs --- a/src/Darcs/Patch/ReadMonads.hs +++ b/src/Darcs/Patch/ReadMonads.hs @@ -1,6 +1,7 @@ -- | This module defines our parsing monad. In the past there have been lazy -- and strict parsers in this module. Currently we have only the strict -- variant and it is used for parsing patch files. + module Darcs.Patch.ReadMonads (ParserM, Darcs.Patch.ReadMonads.take, parse, parseStrictly, char, int, option, choice, skipSpace, skipWhile, string, @@ -237,7 +238,6 @@ instance Monad SM where (>>=) = bindSM return = returnSM - fail = failSM instance ParserM SM where work = SM diff --git a/src/Darcs/Patch/Summary.hs b/src/Darcs/Patch/Summary.hs --- a/src/Darcs/Patch/Summary.hs +++ b/src/Darcs/Patch/Summary.hs @@ -16,7 +16,7 @@ import Darcs.Util.Printer ( Doc, empty, vcat, text, - minus, plus, ($$), (<+>), (<>), + minus, plus, ($$), (<+>) ) 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 @@ -15,6 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Commute @@ -93,6 +94,9 @@ Failed >>= _ = Failed Unknown >>= _ = Unknown return = Succeeded +#if MIN_VERSION_base(4,13,0) +instance MonadFail Perhaps where +#endif fail _ = Unknown instance Alternative Perhaps where diff --git a/src/Darcs/Prelude.hs b/src/Darcs/Prelude.hs --- a/src/Darcs/Prelude.hs +++ b/src/Darcs/Prelude.hs @@ -20,13 +20,13 @@ it to the Prelude import. -} +{-# LANGUAGE CPP #-} module Darcs.Prelude ( module Prelude , module Control.Applicative , module Data.Monoid - , module Data.Semigroup + , Semigroup(..) , module Data.Traversable - , module Data.Maybe , impossible, bug ) where @@ -42,9 +42,11 @@ -- because it's in the new Prelude but only in Data.Monoid in older GHCs Monoid(..) , +#if MIN_VERSION_base(4,11,0) -- because it's in the new Prelude but only in Data.Semigroup in older GHCs Semigroup(..) , +#endif -- because it's in the new Prelude but only in Data.Traversable in older GHCs traverse , @@ -62,7 +64,6 @@ import Data.Monoid ( Monoid(..) ) import Data.Semigroup ( Semigroup(..) ) import Data.Traversable ( traverse ) -import Data.Maybe ( fromJust ) impossible :: a impossible = error "Impossible case" diff --git a/src/Darcs/Repository/Diff.hs b/src/Darcs/Repository/Diff.hs --- a/src/Darcs/Repository/Diff.hs +++ b/src/Darcs/Repository/Diff.hs @@ -138,7 +138,7 @@ do rmDirP <- diff p (Removed subtree) addFileP <- diff p (Changed (File emptyBlob) b') return $ joinGap (+>+) rmDirP addFileP - diff p _ = fail $ "Missing case at path " ++ show p + diff p _ = error $ "Missing case at path " ++ show p text_diff p a b | BL.null a && BL.null b = emptyGap NilFL diff --git a/src/Darcs/Repository/Inventory.hs b/src/Darcs/Repository/Inventory.hs --- a/src/Darcs/Repository/Inventory.hs +++ b/src/Darcs/Repository/Inventory.hs @@ -38,7 +38,7 @@ import Darcs.Repository.Cache ( okayHash ) import Darcs.Util.Hash ( sha256sum ) import Darcs.Util.Printer - ( Doc, (<>), (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS ) + ( Doc, (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS ) -- * Hash validation diff --git a/src/Darcs/Repository/Match.hs b/src/Darcs/Repository/Match.hs --- a/src/Darcs/Repository/Match.hs +++ b/src/Darcs/Repository/Match.hs @@ -60,7 +60,7 @@ getNonrangeMatch r = withRecordedMatch r . getMatch where getMatch fs = case hasIndexRange fs of Just (n, m) | n == m -> applyNInv (n-1) - | otherwise -> fail "Index range is not allowed for this command." + | otherwise -> error "Index range is not allowed for this command." _ -> getNonrangeMatchS fs getOnePatchset :: (IsRepoType rt, RepoPatch p) 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 @@ -37,11 +37,11 @@ import Prelude () import Darcs.Prelude -import Data.Binary ( encodeFile, decodeFile ) +import Data.Binary ( Binary, encodeFile, decodeFileOrFail ) import Data.Word ( Word32 ) import Data.Int ( Int8 ) import Data.List ( group, mapAccumL, sort, isPrefixOf, nub, (\\) ) -import Data.Maybe ( fromMaybe, isJust ) +import Data.Maybe ( fromJust, fromMaybe, isJust ) import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as M @@ -49,7 +49,6 @@ import Control.Exception ( catch ) import Control.Monad ( forM_, unless, when ) import Control.Monad.State.Strict ( evalState, execState, State, gets, modify ) -import Control.Applicative ( (<$>) ) import System.Directory ( createDirectory, renameDirectory, doesFileExist, doesDirectoryExist ) import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) ) import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat ) @@ -511,6 +510,16 @@ return tmpdir rmRecursive cdir `catch` \(_ :: IOError) -> return () renameDirectory tmpdir cdir + +decodeFile :: Binary a => FilePath -> IO a +decodeFile path = do + result <- decodeFileOrFail path + case result of + Left (offset, msg) -> + fail $ + "Patch index is corrupt (file "++path++" at offset "++show offset++"): "++msg++ + "\nPlease remove the corrupt file and then try again." + Right r -> return r storeRepoState :: FilePath -> String -> IO () storeRepoState fp inv_hash = encodeFile fp (version,inv_hash) diff --git a/src/Darcs/Repository/Pending.hs b/src/Darcs/Repository/Pending.hs --- a/src/Darcs/Repository/Pending.hs +++ b/src/Darcs/Repository/Pending.hs @@ -36,7 +36,7 @@ import qualified Data.ByteString as B ( empty ) import Control.Exception ( catch, IOException ) -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( fromJust, fromMaybe ) import Darcs.Util.Printer ( errorDoc ) import Darcs.Util.Global ( darcsdir ) @@ -82,7 +82,7 @@ , lengthFL, allFL, filterOutFLFL , reverseFL, mapFL ) import Darcs.Util.ByteString ( gzReadFilePS ) -import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat, (<+>) ) +import Darcs.Util.Printer ( Doc, ($$), text, vcat, (<+>) ) import Darcs.Util.Progress ( debugMessage ) pendingName :: String diff --git a/src/Darcs/Repository/State.hs b/src/Darcs/Repository/State.hs --- a/src/Darcs/Repository/State.hs +++ b/src/Darcs/Repository/State.hs @@ -44,13 +44,18 @@ import Control.Monad ( when, foldM, forM ) import Control.Monad.State ( StateT, runStateT, get, put, liftIO ) import Control.Exception ( catch, IOException ) -import Data.Maybe ( isJust ) +import Data.Maybe ( fromJust, isJust ) import Data.Ord ( comparing ) import Data.List ( sortBy, union, delete ) import Text.Regex( matchRegex ) import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile ) -import System.FilePath ( (), (<.>) ) +import System.FilePath + ( () +#if mingw32_HOST_OS + , (<.>) +#endif + ) import qualified Data.ByteString as B ( ByteString, readFile, drop, writeFile, empty, concat ) import qualified Data.ByteString.Char8 as BC 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 @@ -39,7 +39,7 @@ import Control.Applicative ( (<|>) ) import System.Time ( toClockTime ) -import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Maybe ( catMaybes, fromJust, fromMaybe ) import qualified Data.IntMap as M import qualified Data.ByteString as B diff --git a/src/Darcs/UI/Commands/Diff.hs b/src/Darcs/UI/Commands/Diff.hs --- a/src/Darcs/UI/Commands/Diff.hs +++ b/src/Darcs/UI/Commands/Diff.hs @@ -20,7 +20,9 @@ import Prelude () import Darcs.Prelude hiding ( all ) +import Data.Maybe ( fromJust ) import System.FilePath.Posix ( takeFileName, () ) + import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( askEnter ) diff --git a/src/Darcs/UI/Commands/Log.hs b/src/Darcs/UI/Commands/Log.hs --- a/src/Darcs/UI/Commands/Log.hs +++ b/src/Darcs/UI/Commands/Log.hs @@ -84,7 +84,7 @@ ) import Darcs.Patch.Matchable ( Matchable ) import Darcs.Util.Printer ( Doc, simplePrinters, (<+>), prefix, text, vcat, - vsep, (<>), ($$), errorDoc, insertBeforeLastline, empty ) + vsep, ($$), errorDoc, insertBeforeLastline, empty ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( setProgressMode, debugMessage ) import Darcs.Util.URL ( isValidLocalPath ) diff --git a/src/Darcs/UI/Commands/MarkConflicts.hs b/src/Darcs/UI/Commands/MarkConflicts.hs --- a/src/Darcs/UI/Commands/MarkConflicts.hs +++ b/src/Darcs/UI/Commands/MarkConflicts.hs @@ -24,6 +24,7 @@ import System.Exit ( exitSuccess ) import Data.List.Ordered ( nubSort, isect ) +import Data.Maybe ( fromJust ) import Control.Monad ( when, unless ) import Control.Exception ( catch, IOException ) @@ -31,7 +32,7 @@ import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, simpleSubPath ) import Darcs.Util.Printer - ( Doc, putDocLnWith, text, redText, debugDocLn, vsep, (<>), (<+>), ($$) ) + ( Doc, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Text ( pathlist ) diff --git a/src/Darcs/UI/Commands/Optimize.hs b/src/Darcs/UI/Commands/Optimize.hs --- a/src/Darcs/UI/Commands/Optimize.hs +++ b/src/Darcs/UI/Commands/Optimize.hs @@ -24,7 +24,7 @@ import Control.Monad ( when, unless, forM_ ) import Data.List ( nub ) -import Data.Maybe ( isJust, fromJust ) +import Data.Maybe ( fromJust, isJust ) import System.Directory ( getDirectoryContents , doesDirectoryExist 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 @@ -27,7 +27,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B import Data.Char ( isSpace ) -import Data.Maybe ( isJust ) +import Data.Maybe ( fromJust, isJust ) import Control.Exception ( catch, IOException ) import Control.Monad ( unless, filterM, void ) import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree 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 @@ -128,7 +128,7 @@ import Darcs.UI.Email ( makeEmail ) import Darcs.UI.Completion ( prefArgs ) import Darcs.Util.Printer - ( Doc, vsep, text, ($$), (<+>), (<>), putDoc, putDocLn + ( Doc, vsep, text, ($$), (<+>), putDoc, putDocLn , renderPS, vcat ) import Darcs.Util.English ( englishNum, Noun(..) ) diff --git a/src/Darcs/UI/Commands/Unrecord.hs b/src/Darcs/UI/Commands/Unrecord.hs --- a/src/Darcs/UI/Commands/Unrecord.hs +++ b/src/Darcs/UI/Commands/Unrecord.hs @@ -74,7 +74,7 @@ selectionContext, runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Util.English ( presentParticiple ) -import Darcs.Util.Printer ( text, putDoc, vcat, (<>), (<+>), ($$) ) +import Darcs.Util.Printer ( text, putDoc, vcat, (<+>), ($$) ) import Darcs.Util.Progress ( debugMessage ) unrecordDescription :: String diff --git a/src/Darcs/UI/Commands/Util.hs b/src/Darcs/UI/Commands/Util.hs --- a/src/Darcs/UI/Commands/Util.hs +++ b/src/Darcs/UI/Commands/Util.hs @@ -30,7 +30,7 @@ ) where import Control.Monad ( when, unless ) -import Data.Maybe ( catMaybes ) +import Data.Maybe ( catMaybes, fromJust ) import Prelude () import Darcs.Prelude @@ -68,7 +68,7 @@ , simpleSubPath, toPath, anchorPath ) import Darcs.Util.Printer - ( text, (<>), (<+>), hsep, ($$), vcat, vsep + ( text, (<+>), hsep, ($$), vcat, vsep , putDocLn, insertBeforeLastline, prefix ) import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn ) diff --git a/src/Darcs/UI/Email.hs b/src/Darcs/UI/Email.hs --- a/src/Darcs/UI/Email.hs +++ b/src/Darcs/UI/Email.hs @@ -12,7 +12,7 @@ import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) import Data.List ( isInfixOf ) import Darcs.Util.Printer - ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS ) + ( Doc, ($$), (<+>), text, empty, packedString, renderPS ) import Darcs.Util.ByteString ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS ) import qualified Data.ByteString as B (ByteString, length, null, tail 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 @@ -22,6 +22,7 @@ import Darcs.Prelude import Data.List ( sort ) +import Data.Maybe ( fromJust ) import Data.Array.Unboxed import Data.Array.ST import Control.Monad.ST 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 @@ -54,7 +54,7 @@ import Darcs.Prelude import Data.List ( inits ) -import Data.Maybe ( isJust, listToMaybe ) +import Data.Maybe ( fromJust, isJust, listToMaybe ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( withFile, withBinaryFile, openBinaryTempFile diff --git a/src/Darcs/Util/Printer/Color.hs b/src/Darcs/Util/Printer/Color.hs --- a/src/Darcs/Util/Printer/Color.hs +++ b/src/Darcs/Util/Printer/Color.hs @@ -9,7 +9,7 @@ import Darcs.Util.Printer ( Printer, Printers, Printers'(..), Printable(..), Color(..) - , invisiblePrinter, (<>), (), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat + , invisiblePrinter, (), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat , unsafeText, unsafePackedString , renderStringWith, prefix ) diff --git a/src/Darcs/Util/Text.hs b/src/Darcs/Util/Text.hs --- a/src/Darcs/Util/Text.hs +++ b/src/Darcs/Util/Text.hs @@ -22,7 +22,7 @@ import Control.Arrow ( first ) import Data.List ( intercalate ) -import Darcs.Util.Printer ( Doc, (<>), renderString, quoted, hsep ) +import Darcs.Util.Printer ( Doc, renderString, quoted, hsep ) sentence :: Doc -> Doc sentence = (<> ".") 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 @@ -46,7 +46,6 @@ import Data.Either( lefts, rights ) import Data.List( union, sort ) import Control.Monad( filterM ) -import Control.Applicative( (<$>) ) -------------------------------- -- Tree, Blob and friends diff --git a/src/Darcs/Util/Tree/Monad.hs b/src/Darcs/Util/Tree/Monad.hs --- a/src/Darcs/Util/Tree/Monad.hs +++ b/src/Darcs/Util/Tree/Monad.hs @@ -216,7 +216,7 @@ t <- gets tree let f = findFile t p' case f of - Nothing -> fail $ "No such file " ++ show p' + Nothing -> error $ "No such file " ++ show p' Just x -> lift (readBlob x) currentDirectory = ask @@ -251,7 +251,7 @@ let item = find tr from' found_to = find tr to' unless (isNothing found_to) $ - fail $ "Error renaming: destination " ++ show to ++ " exists." + error $ "Error renaming: destination " ++ show to ++ " exists." unless (isNothing item) $ do modifyItem from Nothing modifyItem to item