diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,9 @@ + * GHC 7.6 support + * Bump some dependencies: base, network, unix, containers, bytestring, tar + * Resolved issue2199: get --tag can include extra patches + * Remove the --xml-output option to annotate: it stopped having any effect some time ago + + Darcs 2.8.3, 4 November 2012 * Darcs API: #ifdef some FFI imports so ghci works with -f-curl diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -2,18 +2,23 @@ {-# LANGUAGE CPP #-} -- copyright (c) 2008 Duncan Coutts -- portions copyright (c) 2008 David Roundy +-- portions copyright (c) 2007-2009 Judah Jacobson import Prelude hiding ( catch ) import qualified Prelude +import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.ModuleName( toFilePath ) import Distribution.PackageDescription ( PackageDescription(executables), Executable(buildInfo, exeName) , BuildInfo(customFieldsBI), emptyBuildInfo - , updatePackageDescription, cppOptions, ccOptions - , library, libBuildInfo, otherModules ) + , FlagName(FlagName) + , updatePackageDescription + , cppOptions, ccOptions, ldOptions + , library, libBuildInfo, otherModules + , extraLibs, extraLibDirs, includeDirs ) import Distribution.Package ( packageVersion, packageName, PackageName(..) ) import Distribution.Version @@ -22,16 +27,19 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), absoluteInstallDirs, externalPackageDeps ) import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) +import Distribution.Simple.PackageIndex ( topologicalOrder ) +import Distribution.Simple.Program ( gccProgram, rawSystemProgramStdoutConf ) import Distribution.Simple.Setup (buildVerbosity, copyDest, copyVerbosity, fromFlag, - haddockVerbosity, installVerbosity, sDistVerbosity) + haddockVerbosity, installVerbosity, sDistVerbosity, + configVerbosity, ConfigFlags, configConfigurationsFlags) import Distribution.Simple.BuildPaths ( autogenModulesDir, exeExtension ) import Distribution.System ( OS(Windows), buildOS ) import Distribution.Simple.Utils (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout, - rewriteFile) + rewriteFile, withTempFile) import Distribution.Verbosity ( Verbosity ) import Distribution.Text @@ -39,13 +47,19 @@ import Distribution.Package (Package) import Control.Monad ( zipWithM_, when, unless, filterM ) -import Control.Exception ( bracket ) +import Control.Exception ( bracket, handle, IOException ) import System.Directory (copyFile, createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents, - removeDirectoryRecursive, removeFile, setCurrentDirectory) -import System.IO (openFile, IOMode (..)) + removeDirectoryRecursive, removeFile, setCurrentDirectory, + getTemporaryDirectory + ) +import System.Exit ( ExitCode(ExitSuccess) ) +import System.IO + ( openFile, IOMode (..), stdout + , hPutStr, hFlush, hClose + ) import System.Process (runProcess) import System.IO.Error ( isDoesNotExistError ) import Data.List( isPrefixOf, isSuffixOf, sort, partition ) @@ -121,6 +135,20 @@ sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] } sDistHook simpleUserHooks pkg' lbi hooks flags + , + confHook = + if buildOS == Windows + then confHook simpleUserHooks + else + \genericDescript flags -> do + lbi <- confHook simpleUserHooks genericDescript flags + let pkgDescr = localPkgDescr lbi + let Just lib = library pkgDescr + let bi = libBuildInfo lib + bi' <- maybeSetLibiconv flags bi lbi + return lbi {localPkgDescr = pkgDescr { + library = Just lib { + libBuildInfo = bi'}}} } -- | For @./Setup build@ and @./Setup haddock@, do some unusual @@ -200,7 +228,7 @@ versionPatches verbosity darcsVersion = do numPatchesDarcs <- do out <- rawSystemStdout verbosity "darcs" - ["changes", "--from-tag", display darcsVersion, "--count"] + ["changes", "-a", "--from-tag", display darcsVersion, "--count"] case reads (out) of ((n,_):_) -> return $ Just ((n :: Int) - 1) _ -> return Nothing @@ -238,7 +266,7 @@ contextDarcs <- do inrepo <- doesDirectoryExist "_darcs" unless inrepo $ fail "Not a repository." - out <- rawSystemStdout verbosity "darcs" ["changes", "--context"] + out <- rawSystemStdout verbosity "darcs" ["changes", "-a", "--context"] return $ Just out `catchAny` \_ -> return Nothing @@ -258,5 +286,76 @@ ((s,_):_) -> return s _ -> return Nothing else return Nothing + +-- Test whether compiling a c program that links against libiconv needs -liconv. +maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo +maybeSetLibiconv flags bi lbi = do + let biWithIconv = addIconv bi + let verb = fromFlag (configVerbosity flags) + if hasFlagSet flags (FlagName "libiconv") + then do + putStrLn "Using -liconv." + return biWithIconv + else do + putStr "checking whether to use -liconv... " + hFlush stdout + worksWithout <- tryCompile iconv_prog bi lbi verb + if worksWithout + then do + putStrLn "not needed." + return bi + else do + worksWith <- tryCompile iconv_prog biWithIconv lbi verb + if worksWith + then do + putStrLn "using -liconv." + return biWithIconv + else error "Unable to link against the iconv library." + +hasFlagSet :: ConfigFlags -> FlagName -> Bool +hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags) + +tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool +tryCompile program bi lbi verb = handle processExit $ handle processException $ do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \fname cH -> + withTempFile tempDir "" $ \execName oH -> do + hPutStr cH program + hClose cH + hClose oH + -- TODO take verbosity from the args. + rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) + (fname : "-o" : execName : args) + return True + where + processException :: IOException -> IO Bool + processException e = return False + processExit = return . (==ExitSuccess) + -- Mimicing Distribution.Simple.Configure + deps = topologicalOrder (installedPkgs lbi) + args = concat + [ ccOptions bi + , cppOptions bi + , ldOptions bi + -- --extra-include-dirs and --extra-lib-dirs are included + -- in the below fields. + -- Also sometimes a dependency like rts points to a nonstandard + -- include/lib directory where iconv can be found. + , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps) + , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps) + , map ("-l" ++) (extraLibs bi) + ] + +addIconv :: BuildInfo -> BuildInfo +addIconv bi = bi {extraLibs = "iconv" : extraLibs bi} + +iconv_prog :: String +iconv_prog = unlines $ + [ "#include " + , "int main(void) {" + , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");" + , " return 0;" + , "}" + ] \end{code} diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.8.3 +version: 2.8.4 License: GPL License-file: COPYING Author: David Roundy , @@ -129,6 +129,14 @@ the behaviour of filenames that requires API calls in base 4.5 to workaround. So base 4.4 is not supported at all. +-- Note that the Setup script checks whether -liconv is necessary. This flag +-- lets us override that decision. When it is True, we use -liconv. When it +-- is False, we run tests to decide. +flag libiconv + Description: Explicitly link against the libiconv library. + Default: False + + -- ---------------------------------------------------------------------- -- darcs library -- ---------------------------------------------------------------------- @@ -139,7 +147,7 @@ else buildable: True - build-tools: ghc >= 6.10 && < 7.6 + build-tools: ghc >= 6.10 && < 7.8 hs-source-dirs: src include-dirs: src @@ -312,6 +320,7 @@ Darcs.Witnesses.Unsafe Darcs.Witnesses.WZipper DateMatcher + Encoding English Exec ByteStringUtils @@ -342,22 +351,28 @@ hs-source-dirs: src/win32 include-dirs: src/win32 other-modules: CtrlC + Encoding.Win32 System.Posix System.Posix.Files System.Posix.IO cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2, + Win32 >= 2.0, regex-posix >= 0.95.1 + else + other-modules: Encoding.IConv + c-sources: src/h_iconv.c + build-depends: utf8-string >= 0.3.6 && < 0.4 if os(solaris) cc-options: -DHAVE_SIGINFO_H if os(windows) - build-depends: base >= 4 && < 4.6 + build-depends: base >= 4 && < 4.7 else if flag(force-char8-encoding) - build-depends: base >= 4.5 && < 4.6 + build-depends: base >= 4.5 && < 4.7 cpp-options: -DFORCE_CHAR8_ENCODING else build-depends: base >= 4 && < 4.4 @@ -368,20 +383,24 @@ parsec >= 2.0 && < 3.2, html == 1.0.*, filepath >= 1.1.0.0 && < 1.5.0.0, - haskeline >= 0.6.3 && < 0.7, + haskeline >= 0.6.3 && < 0.8, hashed-storage >= 0.5.6 && < 0.6, vector >= 0.7, - tar == 0.3.* + tar >= 0.3 && < 0.5 + if impl(ghc<7.0) + -- haskeline 0.6.4.7 doesn't build with ghc 6.12 + build-depends: haskeline <= 0.6.4.6 + if !os(windows) - build-depends: unix >= 1.0 && < 2.6 + build-depends: unix >= 1.0 && < 2.7 - build-depends: bytestring >= 0.9.0 && < 0.10, + build-depends: bytestring >= 0.9.0 && < 0.11, text >= 0.11.0.6 && < 0.12.0.0, old-time >= 1.0 && < 1.2, - directory >= 1.0.0.0 && < 1.2.0.0, + directory >= 1.0.0.0 && < 1.3.0.0, process >= 1.0.0.0 && < 1.2.0.0, - containers >= 0.1 && < 0.5, + containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, random == 1.0.* @@ -411,7 +430,7 @@ cc-options: -DHAVE_CURL if flag(http) - build-depends: network >= 2.2 && < 2.4, + build-depends: network >= 2.2 && < 2.5, HTTP >= 4000.0.8 && < 4000.3 cpp-options: -DHAVE_HTTP x-have-http: @@ -452,6 +471,12 @@ extensions: NoMonoLocalBinds + if impl(ghc>=7.6) + -- in ghc < 7.6 we need to import Prelude hiding (catch) + -- in ghc >= 7.6 catch isn't in Prelude + ghc-options: -fno-warn-dodgy-imports + + -- ---------------------------------------------------------------------- -- darcs itself -- ---------------------------------------------------------------------- @@ -461,7 +486,7 @@ buildable: False else buildable: True - build-tools: ghc >= 6.10 && < 7.6 + build-tools: ghc >= 6.10 && < 7.8 main-is: darcs.hs hs-source-dirs: src @@ -509,16 +534,23 @@ cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2, + Win32 >= 2.0, regex-posix >= 0.95.1 + else + c-sources: src/h_iconv.c + build-depends: utf8-string >= 0.3.6 && < 0.4 + -- need to list this explicitly to get cabal to run hsc2hs + other-modules: Encoding.IConv + if os(solaris) cc-options: -DHAVE_SIGINFO_H if os(windows) - build-depends: base >= 4 && < 4.6 + build-depends: base >= 4 && < 4.7 else if flag(force-char8-encoding) - build-depends: base >= 4.5 && < 4.6 + build-depends: base >= 4.5 && < 4.7 cpp-options: -DFORCE_CHAR8_ENCODING else build-depends: base >= 4 && < 4.4 @@ -529,20 +561,24 @@ parsec >= 2.0 && < 3.2, html == 1.0.*, filepath >= 1.1.0.0 && < 1.5.0.0, - haskeline >= 0.6.3 && < 0.7, + haskeline >= 0.6.3 && < 0.8, hashed-storage >= 0.5.6 && < 0.6, vector >= 0.7, - tar == 0.3.* + tar >= 0.3 && < 0.5 + if impl(ghc<7.0) + -- haskeline 0.6.4.7 doesn't build with ghc 6.12 + build-depends: haskeline <= 0.6.4.6 + if !os(windows) - build-depends: unix >= 1.0 && < 2.6 + build-depends: unix >= 1.0 && < 2.7 - build-depends: bytestring >= 0.9.0 && < 0.10, + build-depends: bytestring >= 0.9.0 && < 0.11, text >= 0.11.0.6 && < 0.12.0.0, old-time >= 1.0 && < 1.2, - directory >= 1.0.0.0 && < 1.2.0.0, + directory >= 1.0.0.0 && < 1.3.0.0, process >= 1.0.0.0 && < 1.2.0.0, - containers >= 0.1 && < 0.5, + containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, random == 1.0.* @@ -554,7 +590,7 @@ cc-options: -DHAVE_CURL if flag(http) - build-depends: network >= 2.2 && < 2.4, + build-depends: network >= 2.2 && < 2.5, HTTP >= 4000.0.8 && < 4000.3 cpp-options: -DHAVE_HTTP x-have-http: @@ -595,6 +631,11 @@ extensions: NoMonoLocalBinds + if impl(ghc>=7.6) + -- in ghc < 7.6 we need to import Prelude hiding (catch) + -- in ghc >= 7.6 catch isn't in Prelude + ghc-options: -fno-warn-dodgy-imports + -- ---------------------------------------------------------------------- -- unit test driver -- ---------------------------------------------------------------------- @@ -602,7 +643,7 @@ Executable darcs-test main-is: test.hs - build-tools: ghc >= 6.10 && < 7.6 + build-tools: ghc >= 6.10 && < 7.8 if !flag(test) @@ -616,6 +657,7 @@ parsec >= 2.0 && < 3.2, html == 1.0.*, filepath >= 1.1.0.0 && < 1.5.0.0, + FindBin >= 0.0 && < 0.1, QuickCheck >= 2.3, HUnit >= 1.0, cmdlib >= 0.2.1 && < 0.4, @@ -702,36 +744,46 @@ cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: unix-compat >= 0.1.2, + Win32 >= 2.0, regex-posix >= 0.95.1 + else + c-sources: src/h_iconv.c + build-depends: utf8-string >= 0.3.6 && < 0.4 + -- need to list this explicitly to get cabal to run hsc2hs + other-modules: Encoding.IConv if os(solaris) cc-options: -DHAVE_SIGINFO_H if os(windows) - build-depends: base >= 4 && < 4.6 + build-depends: base >= 4 && < 4.7 else if flag(force-char8-encoding) - build-depends: base >= 4.5 && < 4.6 + build-depends: base >= 4.5 && < 4.7 cpp-options: -DFORCE_CHAR8_ENCODING else build-depends: base >= 4 && < 4.4 if !os(windows) - build-depends: unix >= 1.0 && < 2.6 + build-depends: unix >= 1.0 && < 2.7 - build-depends: bytestring >= 0.9.0 && < 0.10, - haskeline >= 0.6.3 && < 0.7, + build-depends: bytestring >= 0.9.0 && < 0.11, + haskeline >= 0.6.3 && < 0.8, text >= 0.11.0.6 && < 0.12.0.0, old-time >= 1.0 && < 1.2, - directory >= 1.0.0.0 && < 1.2.0.0, + directory >= 1.0.0.0 && < 1.3.0.0, process >= 1.0.0.0 && < 1.2.0.0, - containers >= 0.1 && < 0.5, + containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, hashed-storage >= 0.5.6 && < 0.6, vector >= 0.7, - tar == 0.3.*, + tar >= 0.3 && < 0.5, random == 1.0.* + if impl(ghc<7.0) + -- haskeline 0.6.4.7 doesn't build with ghc 6.12 + build-depends: haskeline <= 0.6.4.6 + if flag(mmap) && !os(windows) build-depends: mmap >= 0.5 && < 0.6 cpp-options: -DHAVE_MMAP @@ -744,7 +796,7 @@ cpp-options: -DHAVE_TERMINFO if flag(http) - build-depends: network >= 2.2 && < 2.4, + build-depends: network >= 2.2 && < 2.5, HTTP >= 4000.0.8 && < 4000.3 if flag(color) @@ -768,3 +820,8 @@ if impl(ghc>=7.0) extensions: NoMonoLocalBinds + + if impl(ghc>=7.6) + -- in ghc < 7.6 we need to import Prelude hiding (catch) + -- in ghc >= 7.6 catch isn't in Prelude + ghc-options: -fno-warn-dodgy-imports 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.8.3\nGanesh Sittampalam **20121104174910\n Ignore-this: 3198f6deecf3d1b44df6e05a2657d9ca\n] \n" +Just "\nContext:\n\n[TAG 2.8.4\nGanesh Sittampalam **20130127231845\n Ignore-this: d032f69540341ecfd5858fce7aee1457\n] \n\n[Resolve issue2155: Expurgate the non-functional annotate --xml-output option\nDave Love **20130127231835\n Ignore-this: eb03207031e75687968091d56fb008f8\n backported from HEAD by Ganesh Sittampalam \n] \n\n[Resolve issue2155: Expurgate the non-functional annotate --xml-output option\nDave Love **20130120121739\n Ignore-this: 8a9ce6409a50b71cd0d2fdabbc181b1a\n backported from HEAD by Ganesh Sittampalam \n] \n\n[note dependency bumps in NEWS\nGanesh Sittampalam **20130120170310\n Ignore-this: 48cf181c89ec1b69fc6e9e701734ff19\n] \n\n[bump version to 2.8.4\nGanesh Sittampalam **20130120154856\n Ignore-this: 2f2542e9825b66cda3a0a17275b5e311\n] \n\n[resolve issue2199: getMatchingTag needs to commute for dirty tags\nGanesh Sittampalam **20121218191024\n Ignore-this: 947252cd8e084b793044aff564f0462d\n backported from HEAD\n] \n\n[accept issue2199: darcs get --tag gets too much\nGanesh Sittampalam **20120528164525\n Ignore-this: 8c138a80c294e6181a3ef9250593fa31\n] \n\n[constrain haskeline version on old GHC\nGanesh Sittampalam **20130119234432\n Ignore-this: 8af00cc3d3c1ad223a8b35712c06bae\n] \n\n[Add option -a to darcs changes in Setup.lhs\nBen Franksen **20120811195807\n Ignore-this: f23d2e558f7248fec8d07b0391d9a7e8\n \n Some (potential) contributors (like me) have 'changes interactive'\n in their ~/.darcs/defaults and then wonder why their build hangs.\n] \n\n[add copyright notices for the imported haskeline code\nGanesh Sittampalam **20130119163610\n Ignore-this: afcdc8048f8b3233fa17d3ab0c9c311f\n licence/copyright taken from haskeline 0.6.4.7:\n BSD3, copyright Judah Jacobson\n] \n\n[import encoding code from haskeline: switch over\nGanesh Sittampalam **20130118231907\n Ignore-this: b423a92ba93e74520d0578ac21aceab3\n] \n\n[import encoding code from haskeline: source files\nGanesh Sittampalam **20130118225947\n Ignore-this: c2d1e228fa4cce3e66e90a14fa2f3200\n] \n\n[import encoding code from haskeline: cabal file changes\nGanesh Sittampalam **20130118070642\n Ignore-this: d2ed13887d0c547cb7498bd5a2aef46f\n] \n\n[import encoding code from haskeline: Setup.lhs changes\nGanesh Sittampalam **20130115181040\n Ignore-this: 31ccdca76001bff769464fb7a8e574e9\n] \n\n[ROLLBACK: conditionally use bytestring-handle\nGanesh Sittampalam **20130111213829\n Ignore-this: d3c18b61f765bdfcb574b4977185197b\n It doesn't skip invalid byte sequences when decoding so breaks on \n repositories with non-UTF8 encoded metadata.\n] \n\n[bump network dependency\nGanesh Sittampalam **20130111184607\n Ignore-this: 54e55fa09793008d55572b6acad1a7b8\n] \n\n[add some comments about \"nearby\" darcs, and print out the one that was found\nGanesh Sittampalam **20130111211817\n Ignore-this: 57385f3248fc539435ed9de069a40bd5\n backported from HEAD\n] \n\n[make darcs-test look \"nearby\" for a darcs exe to use\nGanesh Sittampalam **20130111211445\n Ignore-this: d952cf330c0d9510c5c973dd41b191e0\n backported from HEAD\n] \n\n[need different path separator on Windows\nGanesh Sittampalam **20121219191221\n Ignore-this: 42c7ba1e46f5b6b600d23838e5a162cb\n] \n\n[test for issue2286: make sure we can read repos with non-UTF8 metadata\nGanesh Sittampalam **20130102222735\n Ignore-this: adc6165d5d5d991383ebf0e6547f7bf4\n] \n\n[We can use chcp to switch encodings on Windows\nGanesh Sittampalam **20130101122254\n Ignore-this: bc115467e31e144694a33e43dca3fb6c\n This means that the tests that require different encodings can run.\n] \n\n[Find latin9 locale on OS X too\nMichael Hendricks **20120420202408\n Ignore-this: c87db3b97312234ed2380d2ca11a8ca0\n \n Most Linux systems describe latin9 as \"iso885915\". OS X\n describes it with \"ISO8859-15\". The new regex catches both.\n] \n\n[windows test fix: replace shell script with a Haskell program\nGanesh Sittampalam **20121231224332\n Ignore-this: de01ab8647e7d62c18d8c266d514b054\n] \n\n[unsetting DARCS_TEST_PREFS_DIR in utf8 test doesn't seem to be necessary\nGanesh Sittampalam **20130101120246\n Ignore-this: ed74710d8b358b920d742e86a7f008d8\n \n It was causing problems on Windows because getAppUserDataDirectory\n still returns the normal user directory.\n \n It also means that the repository type choice isn't picked up.\n] \n\n[improve diagnostics when utf8 test fails\nGanesh Sittampalam **20121231224600\n Ignore-this: 63db587bc36f8826c66dc6913a4fdb2d\n] \n\n[need to do case-insensitive comparison on Windows\nGanesh Sittampalam **20121228214823\n Ignore-this: ef309d4aef22e87d5c3da3222926af0e\n] \n\n[update NEWS\nGanesh Sittampalam **20121216202654\n Ignore-this: aef3e47204a4157504f90554ffc3a327\n] \n\n[conditionally use bytestring-handle instead of haskeline for encoding\nGanesh Sittampalam **20121216201745\n Ignore-this: fd758796b689d090d01e003e660e405\n This is transitional because we need to support GHC 6.10: we can switch\n over to bytestring-handle unconditionally on HEAD.\n] \n\n[bump deps for GHC 7.6/latest hackage\nGanesh Sittampalam **20121216201543\n Ignore-this: 77829b074a4bff635a421879bdd04be0\n] \n\n[conditionally support tar 0.4\nGanesh Sittampalam **20121216201014\n Ignore-this: 8eff0330e6af196727bdd736ef31db25\n] \n\n[recent test-framework seems to require Typeable\nGanesh Sittampalam **20121216175601\n Ignore-this: a8cce6b69984bfc2335b5c19688950b3\n] \n\n[stop using Prelude.catch\nGanesh Sittampalam **20121216163240\n Ignore-this: b4bfc48775b3337f8f7ebe275be1a058\n \n backported from HEAD\n] \n\n[import constructors of C types to deal with a GHC change\nGanesh Sittampalam **20120401132500\n Ignore-this: ab7cf2fb5e9a2494c14fe7394200da9b\n] \n\n[TAG 2.8.3\nGanesh Sittampalam **20121104174910\n Ignore-this: 3198f6deecf3d1b44df6e05a2657d9ca\n] \n" diff --git a/release/distributed-version b/release/distributed-version --- a/release/distributed-version +++ b/release/distributed-version @@ -1,1 +1,1 @@ -Just 0 +Just 1 diff --git a/src/ByteStringUtils.hs b/src/ByteStringUtils.hs --- a/src/ByteStringUtils.hs +++ b/src/ByteStringUtils.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -70,12 +71,12 @@ #endif import System.IO import System.IO.Unsafe ( unsafePerformIO ) -import System.Console.Haskeline ( InputT, runInputTBehavior, defaultSettings, useFileHandle ) -import System.Console.Haskeline.Encoding ( decode, encode ) +import Encoding ( decode, encode ) + import Foreign.Storable ( peekElemOff, peek ) import Foreign.Marshal.Array ( advancePtr ) -import Foreign.C.Types ( CInt ) +import Foreign.C.Types ( CInt(..) ) import Data.Bits ( rotateL ) import Data.Char ( ord, isSpace ) @@ -517,11 +518,6 @@ end = the_s + l findit n the_s --- we use a custom Behavior because otherwise on Windows haskeline tries to --- do hGetEcho on stdin which fails if stdin is e.g. /dev/null -unsafeRunInput :: InputT IO a -> a -unsafeRunInput = unsafePerformIO . runInputTBehavior (useFileHandle stdin) defaultSettings - -- | Test if a ByteString is made of ascii characters isAscii :: B.ByteString -> Bool isAscii = B.all (\w -> w < 128) @@ -531,7 +527,7 @@ -- and above also supply locale conversion with functions with a pure type. -- Unrecognized byte sequences in the input are skipped. decodeLocale :: B.ByteString -> String -decodeLocale = unsafeRunInput . decode +decodeLocale = unsafePerformIO . decode -- | Encode a String to a ByteString with latin1 (i.e., the values of the -- characters become the values of the bytes; if a character value is greater @@ -541,7 +537,7 @@ -- | Encode a String to a ByteString according to the current locale encodeLocale :: String -> B.ByteString -encodeLocale = unsafeRunInput . encode +encodeLocale = unsafePerformIO . encode -- | Take a @String@ that represents byte values and re-decode it acording to -- the current locale. diff --git a/src/Darcs/ColorPrinter.hs b/src/Darcs/ColorPrinter.hs --- a/src/Darcs/ColorPrinter.hs +++ b/src/Darcs/ColorPrinter.hs @@ -1,6 +1,8 @@ {-# OPTIONS -fno-warn-orphans #-} module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where +import Prelude hiding ( catch ) +import Control.Exception ( catch, IOException ) import Debug.Trace ( trace ) import System.IO ( stderr ) import Darcs.External (getTermNColors) @@ -93,8 +95,8 @@ } where getEnvBool s = safeGetEnv s >>= return.(/= "0") - safeGetEnv s = getEnv s `catch` \_ -> return "0" - getEnvString s = getEnv s `catch` \_ -> return "" + safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0" + getEnvString s = getEnv s `catch` \(_ :: IOException) -> return "" -- printers diff --git a/src/Darcs/Commands/Add.hs b/src/Darcs/Commands/Add.hs --- a/src/Darcs/Commands/Add.hs +++ b/src/Darcs/Commands/Add.hs @@ -33,7 +33,9 @@ #include "gadts.h" #include "impossible.h" +import Prelude hiding ( catch ) +import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, liftM ) import Data.List ( (\\), nub ) import Data.Maybe ( isNothing, maybeToList ) @@ -269,7 +271,7 @@ "' ... couldn't add parent directory '" ++ parentdir ++ "' to repository" return (cur, Nothing, Nothing) - `catch` \e -> do + `catch` \(e :: IOException) -> do putWarning opts . text $ msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e return (cur, Nothing, Nothing) diff --git a/src/Darcs/Commands/Annotate.hs b/src/Darcs/Commands/Annotate.hs --- a/src/Darcs/Commands/Annotate.hs +++ b/src/Darcs/Commands/Annotate.hs @@ -24,7 +24,7 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, summary, unified, machineReadable, - xmloutput, creatorhash, + creatorhash, fixSubPaths, listRegisteredFiles, matchOne, @@ -34,7 +34,7 @@ import Darcs.Repository.State ( readRecorded ) import Darcs.Repository ( Repository, amInHashedRepository, withRepository, RepoJob(..), readRepo ) import Darcs.Patch.Set ( newset2RL ) -import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, xmlSummary, invertRL ) +import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL ) import Darcs.Patch.Apply( ApplyState ) import qualified Darcs.Patch ( summary ) import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate ) @@ -44,7 +44,7 @@ import Darcs.Patch.FileName( fp2fn ) import System.FilePath( () ) import Darcs.RepoPath( toFilePath ) -import Darcs.Patch.Info ( humanFriendly, toXml, showPatchInfo ) +import Darcs.Patch.Info ( humanFriendly, showPatchInfo ) import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch, getOnePatchset, getNonrangeMatchS ) import Darcs.Lock ( withTempDir ) import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal ) @@ -70,7 +70,7 @@ "The --summary option will result in a summarized patch annotation,\n" ++ "similar to `darcs whatsnew'. It has no effect on file annotations.\n" ++ "\n" ++ - "By default, output is in a human-readable format. The --xml-output\n" ++ + "By default, output is in a human-readable format. The --machine-readable\n" ++ "option can be used to generate output for machine postprocessing.\n" annotate :: DarcsCommand @@ -87,7 +87,6 @@ commandAdvancedOptions = [], commandBasicOptions = [summary,unified, machineReadable, - xmloutput, matchOne, creatorhash, workingRepoDir]} @@ -112,12 +111,9 @@ contextualPrintPatch c p else printPatch p where showpi | MachineReadable `elem` opts = showPatchInfo - | XMLOutput `elem` opts = toXml | otherwise = humanFriendly show_summary :: RepoPatch p => Named p C(x y) -> Doc - show_summary = if XMLOutput `elem` opts - then xmlSummary - else Darcs.Patch.summary + show_summary = Darcs.Patch.summary annotate' opts [""] repository = annotate' opts [] repository annotate' opts args@[_] repository = do diff --git a/src/Darcs/Commands/Changes.hs b/src/Darcs/Commands/Changes.hs --- a/src/Darcs/Commands/Changes.hs +++ b/src/Darcs/Commands/Changes.hs @@ -20,12 +20,13 @@ #include "gadts.h" module Darcs.Commands.Changes ( changes, log ) where -import Prelude hiding ( log ) +import Prelude hiding ( log, catch ) import Unsafe.Coerce (unsafeCoerce) import Data.List ( intersect, sort, nub, find ) import Data.Maybe ( fromMaybe, fromJust, isJust ) import Control.Arrow ( second ) +import Control.Exception ( catch, IOException ) import Control.Monad.State.Strict import Control.Applicative ((<$>)) @@ -126,7 +127,7 @@ Sealed unrec <- case files of Nothing -> return $ Sealed NilFL Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown) repository files - `catch` \_ -> return (Sealed NilFL) -- this is triggered when repository is remote + `catch` \(_ :: IOException) -> return (Sealed NilFL) -- this is triggered when repository is remote let normfp = fn2fp . normPath . fp2fn undoUnrecordedOnFPs = effectOnFilePaths (invert unrec) recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files diff --git a/src/Darcs/Commands/Check.hs b/src/Darcs/Commands/Check.hs --- a/src/Darcs/Commands/Check.hs +++ b/src/Darcs/Commands/Check.hs @@ -16,8 +16,12 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.Check ( check, repair ) where + +import Prelude hiding ( catch ) + import Control.Monad ( when, unless ) import Control.Applicative( (<$>) ) +import Control.Exception ( catch, IOException ) import System.Exit ( ExitCode(..), exitWith ) import System.Directory( renameFile ) @@ -105,7 +109,7 @@ where brokenPristine newpris = do putInfo opts $ text "Looks like we have a difference..." - mc' <- (fmap Just $ readRecorded repository) `catch` (\_ -> return Nothing) + mc' <- (fmap Just $ readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing) case mc' of Nothing -> do putInfo opts $ text "cannot compute that difference, try repair" putInfo opts $ text "" $$ text "Inconsistent repository" diff --git a/src/Darcs/Commands/Get.hs b/src/Darcs/Commands/Get.hs --- a/src/Darcs/Commands/Get.hs +++ b/src/Darcs/Commands/Get.hs @@ -19,9 +19,12 @@ module Darcs.Commands.Get ( get, clone ) where +import Prelude hiding ( catch ) + import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist, createDirectory ) import Workaround ( getCurrentDirectory ) +import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo ) @@ -259,7 +262,7 @@ do _ <- tentativelyRemovePatches repository (compression opts) us' tentativelyAddToPending repository opts $ invert $ effect us' finalizeRepositoryChanges repository - apply (invert $ effect ps) `catch` \e -> + apply (invert $ effect ps) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) makeScriptsExecutable opts (invert $ effect ps) diff --git a/src/Darcs/Commands/MarkConflicts.hs b/src/Darcs/Commands/MarkConflicts.hs --- a/src/Darcs/Commands/MarkConflicts.hs +++ b/src/Darcs/Commands/MarkConflicts.hs @@ -18,9 +18,13 @@ {-# LANGUAGE CPP #-} module Darcs.Commands.MarkConflicts ( markconflicts ) where + +import Prelude hiding ( catch ) + import System.Exit ( ExitCode(..), exitWith ) import Darcs.SignalHandler ( withSignalsBlocked ) import Control.Monad ( unless ) +import Control.Exception ( catch, IOException ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag, ignoretimes, workingRepoDir, umaskOption ) @@ -96,12 +100,12 @@ " in the working directory.") confirmed <- promptYorn "Are you sure? " unless confirmed $ exitWith ExitSuccess - applyToWorking repository opts (invert pend') `catch` \e -> + applyToWorking repository opts (invert pend') `catch` \(e :: IOException) -> bug ("Can't undo pending changes!" ++ show e) repository' <- undoUnrec pend withSignalsBlocked $ do addToPending repository' res - _ <- applyToWorking repository' opts res `catch` \e -> + _ <- applyToWorking repository' opts res `catch` \(e :: IOException) -> bug ("Problem marking conflicts in mark-conflicts!" ++ show e) return () putStrLn "Finished marking conflicts." diff --git a/src/Darcs/Commands/Record.hs b/src/Darcs/Commands/Record.hs --- a/src/Darcs/Commands/Record.hs +++ b/src/Darcs/Commands/Record.hs @@ -20,9 +20,12 @@ module Darcs.Commands.Record ( record, commit, getDate, getLog, askAboutDepends ) where + +import Prelude hiding ( catch ) + import qualified Ratified( hGetContents ) import Control.Applicative ( (<$>) ) -import Control.Exception.Extensible ( handleJust ) +import Control.Exception.Extensible ( handleJust, catch, IOException ) import Control.Monad ( when, unless ) import System.IO ( stdin ) import Data.List ( sort, isPrefixOf, union ) @@ -289,7 +292,7 @@ return (p, thelog, Nothing) gl (LogFile f:fs) = do -- round 1 (patchname) - mlp <- lines `fmap` readLocaleFile f `catch` (\_ -> return []) + mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return []) firstname <- case (patchname_specified, mlp) of (FlagPatchName p, []) -> return p (_, p:_) -> return p -- logfile trumps prior! diff --git a/src/Darcs/Commands/Replace.hs b/src/Darcs/Commands/Replace.hs --- a/src/Darcs/Commands/Replace.hs +++ b/src/Darcs/Commands/Replace.hs @@ -19,9 +19,12 @@ module Darcs.Commands.Replace ( replace, defaultToks ) where +import Prelude hiding ( catch ) + import Data.Maybe ( isJust ) import Control.Monad ( unless, filterM ) import Control.Applicative( (<$>) ) +import Control.Exception ( catch, IOException ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) @@ -141,7 +144,7 @@ files <- filterM (exists work) fs Sealed pswork <- mapSeal concatFL . toFL <$> mapM (repl toks cur work) files addToPending repository pswork - _ <- applyToWorking repository opts pswork `catch` \e -> + _ <- applyToWorking repository opts pswork `catch` \(e :: IOException) -> fail $ "Can't do replace on working!\n" ++ "Perhaps one of the files already contains '"++ new++"'?\n" ++ show e @@ -190,7 +193,7 @@ maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p C(x y) -> Tree IO -> IO (Maybe (Tree IO)) maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree) - (\_ -> return Nothing) + (\(_ :: IOException) -> return Nothing) defaultToks :: String defaultToks = "A-Za-z_0-9" diff --git a/src/Darcs/Commands/Revert.hs b/src/Darcs/Commands/Revert.hs --- a/src/Darcs/Commands/Revert.hs +++ b/src/Darcs/Commands/Revert.hs @@ -16,8 +16,12 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.Revert ( revert ) where + +import Prelude hiding ( catch ) + import System.Exit ( ExitCode(..), exitWith ) import Control.Applicative ( (<$>) ) +import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import Data.List ( sort ) @@ -112,7 +116,7 @@ Just (p':>_) -> writeUnrevert repository p' rec NilFL Nothing -> writeUnrevert repository (norevert+>+p) rec NilFL when (Debug `elem` opts) $ putStrLn "About to apply to the working directory." - _ <- applyToWorking repository opts (invert p) `catch` \e -> + _ <- applyToWorking repository opts (invert p) `catch` \(e :: IOException) -> fail ("Unable to apply inverse patch!" ++ show e) return ()) :: IO () putStrLn "Finished reverting." diff --git a/src/Darcs/Commands/Rollback.hs b/src/Darcs/Commands/Rollback.hs --- a/src/Darcs/Commands/Rollback.hs +++ b/src/Darcs/Commands/Rollback.hs @@ -19,7 +19,10 @@ module Darcs.Commands.Rollback ( rollback ) where +import Prelude hiding ( catch ) + import Control.Applicative ( (<$>) ) +import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode(..) ) import Data.List ( sort ) @@ -183,7 +186,7 @@ tentativelyAddToPending repo opts pw withGutsOf repo $ do finalizeRepositoryChanges repo - _ <- applyToWorking repo opts pw `catch` \e -> + _ <- applyToWorking repo opts pw `catch` \(e :: IOException) -> fail ("error applying rolled back patch to working directory\n" ++ show e) debugMessage "Finished applying unrecorded rollback patch" diff --git a/src/Darcs/Commands/Send.hs b/src/Darcs/Commands/Send.hs --- a/src/Darcs/Commands/Send.hs +++ b/src/Darcs/Commands/Send.hs @@ -18,12 +18,16 @@ {-# LANGUAGE CPP, TypeOperators #-} module Darcs.Commands.Send ( send ) where + +import Prelude hiding ( catch ) + import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) #ifndef HAVE_MAPI import System.Exit ( ExitCode( ExitFailure ) ) #endif import System.IO.Error ( ioeGetErrorString ) import System.IO ( hClose ) +import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, forM_ ) import Storage.Hashed.Tree ( Tree ) import Data.List ( intercalate, isPrefixOf, stripPrefix ) @@ -282,7 +286,7 @@ (\url -> do putInfo opts . text $ "Posting patch to " ++ url postUrl url (BC.unpack nbody) "message/rfc822") - `catch` const sendmail + `catch` (\(_ :: IOException) -> sendmail) cleanup opts mailfile generateEmailToString :: [WhatToDo] -> String diff --git a/src/Darcs/Commands/ShowAuthors.hs b/src/Darcs/Commands/ShowAuthors.hs --- a/src/Darcs/Commands/ShowAuthors.hs +++ b/src/Darcs/Commands/ShowAuthors.hs @@ -17,8 +17,11 @@ module Darcs.Commands.ShowAuthors ( showAuthors ) where +import Prelude hiding ( catch ) + import qualified Ratified( readFile ) import Control.Arrow ((&&&), (***)) +import Control.Exception ( catch, IOException ) import Data.List ( isInfixOf, sortBy, groupBy, group, sort) import Data.Ord (comparing) import Data.Char ( toLower, isSpace ) @@ -141,7 +144,7 @@ compiledAuthorSpellings opts = do let as_file = ".authorspellings" contents <- (Ratified.readFile -- never unlinked from within darcs - as_file `catch` (\_ -> return "")) + as_file `catch` (\(_ :: IOException) -> return "")) let parse_results = map (parse sentence as_file) $ lines contents clean 1 parse_results where diff --git a/src/Darcs/Commands/Test.hs b/src/Darcs/Commands/Test.hs --- a/src/Darcs/Commands/Test.hs +++ b/src/Darcs/Commands/Test.hs @@ -16,6 +16,9 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.Test ( test ) where + +import Prelude hiding ( catch ) + import System.Exit ( exitWith ) import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo ) diff --git a/src/Darcs/Commands/TrackDown.hs b/src/Darcs/Commands/TrackDown.hs --- a/src/Darcs/Commands/TrackDown.hs +++ b/src/Darcs/Commands/TrackDown.hs @@ -16,10 +16,11 @@ -- Boston, MA 02110-1301, USA. module Darcs.Commands.TrackDown ( trackdown ) where -import Prelude hiding ( init ) +import Prelude hiding ( init, catch ) import System.Exit ( ExitCode(..) ) import System.Cmd ( system ) import System.IO ( hFlush, stdout ) +import Control.Exception ( catch, IOException ) import Control.Monad( when ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) @@ -107,7 +108,7 @@ test_result <- test if test_result == ExitSuccess then putStrLn "Success!" - else do apply (invert p) `catch` \e -> fail ("Bad patch:\n" ++ show e) + else do apply (invert p) `catch` \(e :: IOException) -> fail ("Bad patch:\n" ++ show e) makeScriptsExecutable opts (invert p) putStrLn "Trying without the patch:" putDocLn $ description $ invert p @@ -189,5 +190,5 @@ unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches) safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => p C(x y) -> IO () -safeApply p = apply p `catch` (\msg -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg)) +safeApply p = apply p `catch` (\(msg :: IOException) -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg)) diff --git a/src/Darcs/Commands/Unrecord.hs b/src/Darcs/Commands/Unrecord.hs --- a/src/Darcs/Commands/Unrecord.hs +++ b/src/Darcs/Commands/Unrecord.hs @@ -18,6 +18,10 @@ {-# LANGUAGE CPP #-} module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where + +import Prelude hiding ( catch ) + +import Control.Exception ( catch, IOException ) import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) import Data.Maybe( isJust ) @@ -218,7 +222,7 @@ tentativelyAddToPending repository opts $ invert $ effect removed finalizeRepositoryChanges repository debugMessage "Applying patches to working directory..." - _ <- applyToWorking repository opts (invert p_after_pending) `catch` \e -> + _ <- applyToWorking repository opts (invert p_after_pending) `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e) return () putStrLn $ "Finished " ++ presentParticiple cmdname ++ "." diff --git a/src/Darcs/Commands/Unrevert.hs b/src/Darcs/Commands/Unrevert.hs --- a/src/Darcs/Commands/Unrevert.hs +++ b/src/Darcs/Commands/Unrevert.hs @@ -20,6 +20,10 @@ #include "gadts.h" module Darcs.Commands.Unrevert ( unrevert, writeUnrevert ) where + +import Prelude hiding ( catch ) + +import Control.Exception ( catch, IOException ) import System.Exit ( ExitCode(..), exitWith ) import Storage.Hashed.Tree( Tree ) @@ -98,7 +102,7 @@ tentativelyAddToPending repository opts p withSignalsBlocked $ do finalizeRepositoryChanges repository - _ <- applyToWorking repository opts p `catch` \e -> + _ <- applyToWorking repository opts p `catch` \(e :: IOException) -> fail ("Error applying unrevert to working directory...\n" ++ show e) debugMessage "I'm about to writeUnrevert." diff --git a/src/Darcs/Compat.hs b/src/Darcs/Compat.hs --- a/src/Darcs/Compat.hs +++ b/src/Darcs/Compat.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module Darcs.Compat (stdoutIsAPipe, mkStdoutTemp, canonFilename, @@ -15,7 +16,7 @@ #endif import Control.Monad ( unless ) -import Foreign.C.Types ( CInt ) +import Foreign.C.Types ( CInt(..) ) import Foreign.C.String ( CString, withCString ) import Foreign.C.Error ( throwErrno, eEXIST, getErrno ) import System.Directory ( getCurrentDirectory ) diff --git a/src/Darcs/External.hs b/src/Darcs/External.hs --- a/src/Darcs/External.hs +++ b/src/Darcs/External.hs @@ -17,6 +17,8 @@ sendmailPath, diffProgram, darcsProgram ) where +import Prelude hiding ( catch ) + import qualified Ratified import Data.Maybe ( isJust, isNothing, maybeToList ) import Control.Monad ( when, zipWithM_, filterM, liftM2 ) @@ -34,7 +36,8 @@ findExecutable ) import System.Process ( runProcess, runInteractiveProcess, waitForProcess ) import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar ) -import Control.Exception.Extensible ( bracket, try, finally, SomeException ) +import Control.Exception.Extensible + ( bracket, try, finally, catch, IOException, SomeException ) import Data.Char ( toUpper ) #if defined (HAVE_MAPI) import Foreign.C ( CString, withCString ) @@ -102,7 +105,7 @@ -- |Get the name of the darcs executable (as supplied by @getProgName@) darcsProgram :: IO String darcsProgram = getProgName --- Another option: getEnv "DARCS" `catch` \_ -> getProgName +-- Another option: getEnv "DARCS" `catch` \(_ :: IOException) -> getProgName backupByRenaming :: FilePath -> IO () backupByRenaming = backupBy rename @@ -200,7 +203,7 @@ mk_dest fp = dest fp zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') else fail ("cloneTreeExcept: Bad source " ++ source) - `catch` fail ("cloneTreeExcept: Bad source " ++ source) + `catch` (\(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source)) cloneSubTree :: FilePath -> FilePath -> IO () cloneSubTree source dest = @@ -226,7 +229,7 @@ maybeURLCmd what url = do let prot = map toUpper $ takeWhile (/= ':') url fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot)) - `catch` \_ -> return Nothing + `catch` \(_ :: IOException) -> return Nothing speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable #if defined(HAVE_CURL) || defined(HAVE_HTTP) @@ -318,7 +321,7 @@ newline = B.singleton 10 haveSendmail :: IO Bool -haveSendmail = (sendmailPath >> return True) `catch` (\_ -> return False) +haveSendmail = (sendmailPath >> return True) `catch` (\(_ :: IOException) -> return False) -- | Send an email, optionally containing a patch bundle -- (more precisely, its description and the bundle itself) diff --git a/src/Darcs/Match.hs b/src/Darcs/Match.hs --- a/src/Darcs/Match.hs +++ b/src/Darcs/Match.hs @@ -69,8 +69,8 @@ import Darcs.Patch.Set ( Origin ) #endif import Darcs.Repository.ApplyPatches ( applyPatches ) -import Darcs.Patch.Depends ( getPatchesBeyondTag ) -import Darcs.Witnesses.Ordered ( RL(..), consRLSealed ) +import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag ) +import Darcs.Witnesses.Ordered ( RL(..), consRLSealed, (:>)(..) ) import ByteStringUtils ( mmapFilePS ) @@ -388,7 +388,10 @@ getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m getMatchingTag m (PatchSet NilRL (Tagged t _ ps :<: ts)) = getMatchingTag m (PatchSet (t:<:ps) ts) getMatchingTag m (PatchSet (p:<:ps) ts) - | applyMatcher m p = seal $ PatchSet (p:<:ps) ts + | applyMatcher m p = + -- found a non-clean tag, need to commute out the things that it doesn't depend on + case splitOnTag (info p) (PatchSet (p:<:ps) ts) of + patchSet :> _ -> seal patchSet | otherwise = getMatchingTag m (PatchSet ps ts) -- | @matchExists m ps@ tells whether there is a patch matching diff --git a/src/Darcs/MonadProgress.hs b/src/Darcs/MonadProgress.hs --- a/src/Darcs/MonadProgress.hs +++ b/src/Darcs/MonadProgress.hs @@ -25,9 +25,11 @@ , silentlyRunProgressActions ) where +import Prelude hiding ( catch ) import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO ) import Printer ( hPutDocLn, Doc ) import Darcs.ColorPrinter () -- for instance Show Doc +import Control.Exception ( catch ) import System.IO ( stderr ) import qualified Storage.Hashed.Monad as HSM diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -45,7 +45,14 @@ , readIndex, invalidateIndex ) where +import Prelude hiding ( catch ) + import System.Exit ( ExitCode(..), exitWith ) +#if MIN_VERSION_tar(0,4,0) +import Control.Exception ( Exception, throwIO, catch ) +#else +import Control.Exception ( catch ) +#endif import Data.List ( isPrefixOf) import Data.Maybe( catMaybes, isJust, listToMaybe ) @@ -302,19 +309,35 @@ removeMetaFiles = mapM_ (removeFile . (darcsdir )) . filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir +#if MIN_VERSION_tar(0,4,0) +unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO () +#else unpackBasic :: Cache -> Tar.Entries -> IO () +#endif unpackBasic c x = do withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x removeMetaFiles +#if MIN_VERSION_tar(0,4,0) +unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO () +#else unpackPatches :: Cache -> [String] -> Tar.Entries -> IO () +#endif unpackPatches c ps x = do withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x removeMetaFiles +#if MIN_VERSION_tar(0,4,0) +unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO () +#else unpackTar :: Cache -> IO () -> Tar.Entries -> IO () +#endif unpackTar _ _ Tar.Done = return () +#if MIN_VERSION_tar(0,4,0) +unpackTar _ _ (Tar.Fail e)= throwIO e +#else unpackTar _ _ (Tar.Fail e)= fail e +#endif unpackTar c mh (Tar.Next x xs) = case Tar.entryContent x of Tar.NormalFile x' _ -> do let p = Tar.entryPath x diff --git a/src/Darcs/Repository/HashedRepo.hs b/src/Darcs/Repository/HashedRepo.hs --- a/src/Darcs/Repository/HashedRepo.hs +++ b/src/Darcs/Repository/HashedRepo.hs @@ -31,6 +31,8 @@ readRepoFromInventoryList, readPatchIds ) where +import Prelude hiding ( catch ) + import System.Directory ( createDirectoryIfMissing ) import System.FilePath.Posix( () ) import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -38,6 +40,7 @@ import Data.List ( delete ) import Control.Monad ( unless ) import Control.Applicative ( (<$>) ) +import Control.Exception ( catch, IOException ) import Workaround ( renameFile ) import Darcs.Flags ( Compression, RemoteDarcs ) @@ -99,7 +102,7 @@ return $ BC.unpack . encodeBase16 $ treeHash t applyHashed :: (ApplyState q ~ Tree, Patchy q) => String -> q C(x y) -> IO String -applyHashed h p = applyHashed' hash p `catch` \_ -> do +applyHashed h p = applyHashed' hash p `catch` \(_ :: IOException) -> do hPutStrLn stderr warn inv <- gzReadFilePS invpath let oldroot = BC.pack $ inv2pris inv @@ -142,7 +145,7 @@ readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String) readHashedPristineRoot (Repo d _ _ _) = withCurrentDirectory d $ do - i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing) + i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\(_ :: IOException) -> return Nothing) return $ inv2pris `fmap` i cleanPristine :: Repository p C(r u t) -> IO () diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs --- a/src/Darcs/Repository/Internal.hs +++ b/src/Darcs/Repository/Internal.hs @@ -49,6 +49,8 @@ makeNewPending, seekRepo ) where +import Prelude hiding ( catch ) + import Printer ( putDocLn, (<+>), text, ($$), redText, putDocLnWith, (<>), ($$)) import Darcs.ColorPrinter (fancyPrinters) @@ -71,6 +73,8 @@ createDirectoryIfMissing, doesFileExist ) import Control.Monad ( when, unless, filterM ) import Control.Applicative ( (<$>) ) +import Control.Exception ( catch, IOException ) + import Workaround ( getCurrentDirectory, renameFile, setExecutable ) import qualified Data.ByteString as B ( readFile, isPrefixOf ) @@ -350,7 +354,7 @@ cur <- readRecorded repo Sealed p <- readNewPendingLL repo -- :: IO (Sealed (FL (PrimOf p) C(t))) -- Warning: A do-notation statement discarded a result of type Tree.Tree IO. - _ <- catch (applyToTree p cur) $ \err -> do + _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do let buggyname = pendingName tp ++ "_buggy" renameFile newname buggyname bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err) diff --git a/src/Darcs/Repository/Old.hs b/src/Darcs/Repository/Old.hs --- a/src/Darcs/Repository/Old.hs +++ b/src/Darcs/Repository/Old.hs @@ -22,6 +22,8 @@ module Darcs.Repository.Old ( readOldRepo, revertTentativeChanges, oldRepoFailMsg ) where +import Prelude hiding ( catch ) + import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO ) import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr ) @@ -48,6 +50,8 @@ import Darcs.Global ( darcsdir ) import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal ) +import Control.Exception ( catch, IOException ) + #include "impossible.h" readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p C(Origin)) @@ -93,7 +97,8 @@ Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ read_ts parse mt Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) Sealed tag00 <- parse tag0 `catch` - \e -> return $ seal $ + \(e :: IOException) -> + return $ seal $ patchInfoAndPatch tag0 $ unavailable $ show e return $ seal $ Tagged tag00 Nothing ps :<: ts parse2 :: RepoPatch p => PatchInfo -> FilePath @@ -112,7 +117,7 @@ read_patches parse (i:is) = lift2Sealed (:<:) (read_patches parse is) - (parse i `catch` \e -> + (parse i `catch` \(e :: IOException) -> return $ seal $ patchInfoAndPatch i $ unavailable $ show e) lift2Sealed :: (FORALL(y z) q C(y z) -> pp C(y) -> r C(z)) -> IO (Sealed pp) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed r) 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 @@ -34,7 +34,11 @@ globalPrefsDirDoc, ) where + +import Prelude hiding ( catch ) + import System.IO.Error ( isDoesNotExistError ) +import Control.Exception ( catch ) import Control.Monad ( unless, when ) import Text.Regex ( Regex, mkRegex, matchRegex, ) import Data.Char ( toUpper ) diff --git a/src/Darcs/Repository/Repair.hs b/src/Darcs/Repository/Repair.hs --- a/src/Darcs/Repository/Repair.hs +++ b/src/Darcs/Repository/Repair.hs @@ -5,10 +5,12 @@ RepositoryConsistency(..) ) where +import Prelude hiding ( catch ) + import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO ) import Control.Applicative( (<$>) ) -import Control.Exception ( finally ) +import Control.Exception ( catch, finally, IOException ) import Data.Maybe ( catMaybes ) import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing, getCurrentDirectory, @@ -134,7 +136,7 @@ checkUniqueness putVerbose putInfo repo createDirectoryIfMissing False whereToReplay putVerbose $ text "Reading recorded state..." - pris <- readRecorded repo `catch` \_ -> return emptyTree + pris <- readRecorded repo `catch` \(_ :: IOException) -> return emptyTree putVerbose $ text "Applying patches..." patches <- readRepo repo debugMessage "Fixing any broken patches..." 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 @@ -32,9 +32,10 @@ -- * Index. , readIndex, invalidateIndex, UseIndex(..), ScanKnown(..) ) where -import Prelude hiding ( filter ) +import Prelude hiding ( filter, catch ) import Control.Monad( when ) import Control.Applicative( (<$>) ) +import Control.Exception ( catch, IOException ) import Data.Maybe( isJust ) import Data.List( union ) import Text.Regex( matchRegex ) @@ -257,7 +258,7 @@ readPending repo = do Sealed pending <- readPendingLL repo pristine <- readRecorded repo - catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do + catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ (err :: IOException) -> do putStrLn $ "Yikes, pending has conflicts! " ++ show err putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy" renameFile "_darcs/patches/pending" diff --git a/src/Darcs/Utils.hs b/src/Darcs/Utils.hs --- a/src/Darcs/Utils.hs +++ b/src/Darcs/Utils.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} -- | @@ -76,7 +77,7 @@ import Foreign.C.String ( CString, withCString, peekCString ) import Foreign.C.Error ( throwErrno ) -import Foreign.C.Types ( CInt ) +import Foreign.C.Types ( CInt(..) ) #ifdef FORCE_CHAR8_ENCODING import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 ) diff --git a/src/Encoding.hs b/src/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Encoding.hs @@ -0,0 +1,46 @@ +-- Copyright 2007-2009, Judah Jacobson. +-- All Rights Reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: + +-- - Redistribution of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. + +-- - Redistribution in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. + +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +{-# LANGUAGE CPP #-} +module Encoding + ( encode,decode + ) where + +import Data.ByteString ( ByteString ) + +#ifdef WIN32 +import qualified Encoding.Win32 as Backend ( encode, decode ) +#else +import qualified Encoding.IConv as Backend ( encode, decode ) +#endif + +-- functions redefined to add haddock (there might well be a better way!) + +-- | Encode a Unicode 'String' into a 'ByteString' suitable for the current +-- console. +encode :: String -> IO ByteString +encode = Backend.encode + +-- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'. +decode :: ByteString -> IO String +decode = Backend.decode diff --git a/src/Encoding/IConv.hsc b/src/Encoding/IConv.hsc new file mode 100644 --- /dev/null +++ b/src/Encoding/IConv.hsc @@ -0,0 +1,184 @@ +-- Copyright 2007-2009, Judah Jacobson. +-- All Rights Reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: + +-- - Redistribution of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. + +-- - Redistribution in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. + +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +{-# LANGUAGE ForeignFunctionInterface #-} +module Encoding.IConv + ( encode, decode + ) where + +import Foreign.C + ( CString, CSize(..), CInt(..) + , peekCAString, withCAString + , Errno(..), getErrno, throwErrno, eINVAL, e2BIG + ) +import Foreign + ( Ptr, castPtr, nullPtr, plusPtr + , peek, maybePeek + , with, maybeWith + , ForeignPtr, withForeignPtr, newForeignPtr + , FunPtr + , Int32, Word8 + ) +import Control.Exception ( bracket ) +import Data.ByteString ( ByteString, useAsCStringLen, append ) +import Data.ByteString.Internal ( createAndTrim' ) +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as UTF8 +import Data.Maybe ( fromMaybe ) + +#include +#include +#include "h_iconv.h" + +getLocaleCodeset :: IO String +getLocaleCodeset = bracket (setLocale (Just "")) setLocale (const getCodeset) + +encode :: String -> IO ByteString +encode str = getLocaleCodeset >>= \codeset -> openEncoder codeset >>= ($ str) + +decode :: ByteString -> IO String +decode str = getLocaleCodeset >>= \codeset -> openDecoder codeset >>= ($ str) + +openEncoder :: String -> IO (String -> IO ByteString) +openEncoder codeset = do + encodeT <- iconvOpen codeset "UTF-8" + return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString + +openDecoder :: String -> IO (ByteString -> IO String) +openDecoder codeset = do + decodeT <- iconvOpen "UTF-8" codeset + return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT + +dropUTF8Char :: ByteString -> ByteString +dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons + +replacement :: Word8 +replacement = toEnum (fromEnum '?') + +-- handle errors by dropping unuseable chars. +simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString +simpleIConv dropper t bs = do + (cs,result) <- iconv t bs + case result of + Invalid rest -> continueOnError cs rest + Incomplete rest -> continueOnError cs rest + _ -> return cs + where + continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`)) + $ simpleIConv dropper t (dropper rest) + +--------------------- +-- Setting the locale + +foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString + +setLocale :: Maybe String -> IO (Maybe String) +setLocale oldLocale = (maybeWith withCAString) oldLocale $ \loc_p -> do + c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString + +----------------- +-- Getting the encoding + +type NLItem = #type nl_item + +foreign import ccall nl_langinfo :: NLItem -> IO CString + +getCodeset :: IO String +getCodeset = do + str <- nl_langinfo (#const CODESET) >>= peekCAString + -- check for codesets which may be returned by Solaris, but not understood + -- by GNU iconv. + if str `elem` ["","646"] + then return "ISO-8859-1" + else return str + +---------------- +-- Iconv + +-- TODO: This may not work on platforms where iconv_t is not a pointer. +type IConvT = ForeignPtr () +type IConvTPtr = Ptr () + +foreign import ccall "haskeline_iconv_open" iconv_open + :: CString -> CString -> IO IConvTPtr + +iconvOpen :: String -> String -> IO IConvT +iconvOpen destName srcName = withCAString destName $ \dest -> + withCAString srcName $ \src -> do + res <- iconv_open dest src + if res == nullPtr `plusPtr` (-1) + then throwErrno $ "iconvOpen " + ++ show (srcName,destName) + -- list the two it couldn't convert between? + else newForeignPtr iconv_close res + +-- really this returns a CInt, but it's easiest to just ignore that, I think. +foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ()) + +foreign import ccall "haskeline_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize + -> Ptr CString -> Ptr CSize -> IO CSize + +data Result = Successful + | Invalid ByteString + | Incomplete ByteString + deriving Show + +iconv :: IConvT -> ByteString -> IO (ByteString,Result) +iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) -> + with inPtr $ \inBuff -> + with (toEnum inBuffLen) $ \inBytesLeft -> do + out <- loop inBuffLen (castPtr inBuff) inBytesLeft + return out + where + -- TODO: maybe a better algorithm for increasing the buffer size? + -- and also maybe a different starting buffer size? + biggerBuffer = (+1) + loop outSize inBuff inBytesLeft = do + (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft + inLeft <- fmap fromEnum $ peek inBytesLeft + let rest = B.drop (B.length inStr - inLeft) inStr + case errno of + Nothing -> return (bs,Successful) + Just err + | err == e2BIG -> do -- output buffer too small + (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft + -- TODO: is this efficient enough? + return (bs `append` bs', result) + | err == eINVAL -> return (bs,Incomplete rest) + | otherwise -> return (bs, Invalid rest) + +partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno) +partialIconv cd outSize inBuff inBytesLeft = + withForeignPtr cd $ \cd_p -> + createAndTrim' outSize $ \outPtr -> + with outPtr $ \outBuff -> + with (toEnum outSize) $ \outBytesLeft -> do + -- ignore the return value; checking the errno is more reliable. + _ <- c_iconv cd_p inBuff inBytesLeft (castPtr outBuff) outBytesLeft + outLeft <- fmap fromEnum $ peek outBytesLeft + inLeft <- peek inBytesLeft + errno <- if inLeft > 0 + then fmap Just getErrno + else return Nothing + return (0,outSize - outLeft,errno) + diff --git a/src/Encoding/Win32.hs b/src/Encoding/Win32.hs new file mode 100644 --- /dev/null +++ b/src/Encoding/Win32.hs @@ -0,0 +1,80 @@ +-- Copyright 2007-2009, Judah Jacobson. +-- All Rights Reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: + +-- - Redistribution of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. + +-- - Redistribution in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. + +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +{-# LANGUAGE ForeignFunctionInterface #-} +module Encoding.Win32 + ( encode, decode + ) where + +import Data.ByteString.Internal ( createAndTrim ) +import qualified Data.ByteString as B + ( ByteString, useAsCStringLen ) +import Foreign ( castPtr, allocaArray0 ) +import Foreign.C + ( CInt(..), peekCWStringLen, withCWStringLen ) +import System.Win32 + ( CodePage, nullPtr, getConsoleCP, getACP + , LPCSTR, LPWSTR, LPCWSTR, LPBOOL, DWORD ) + +encode :: String -> IO B.ByteString +encode str = getCodePage >>= flip unicodeToCodePage str + +decode :: B.ByteString -> IO String +decode str = getCodePage >>= flip codePageToUnicode str + +------------------------ +-- Multi-byte conversion + +foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte + :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt + -> LPCSTR -> LPBOOL -> IO CInt + +unicodeToCodePage :: CodePage -> String -> IO B.ByteString +unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do + -- first, ask for the length without filling the buffer. + outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) + nullPtr 0 nullPtr nullPtr + -- then, actually perform the encoding. + createAndTrim (fromEnum outSize) $ \outBuff -> + fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) + (castPtr outBuff) outSize nullPtr nullPtr + +foreign import stdcall "MultiByteToWideChar" multiByteToWideChar + :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt + +codePageToUnicode :: CodePage -> B.ByteString -> IO String +codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do + -- first ask for the size without filling the buffer. + outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0 + -- then, actually perform the decoding. + allocaArray0 (fromEnum outSize) $ \outBuff -> do + outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize + peekCWStringLen (outBuff, fromEnum outSize') + +getCodePage :: IO CodePage +getCodePage = do + conCP <- getConsoleCP + if conCP > 0 + then return conCP + else getACP + diff --git a/src/URL/Curl.hs b/src/URL/Curl.hs --- a/src/URL/Curl.hs +++ b/src/URL/Curl.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module URL.Curl where @@ -6,7 +7,7 @@ import Control.Exception.Extensible ( bracket ) import Control.Monad ( when ) -import Foreign.C.Types ( CLong, CInt ) +import Foreign.C.Types ( CLong(..), CInt(..) ) import Progress ( debugMessage ) diff --git a/src/URL/HTTP.hs b/src/URL/HTTP.hs --- a/src/URL/HTTP.hs +++ b/src/URL/HTTP.hs @@ -2,12 +2,15 @@ module URL.HTTP( fetchUrl, postUrl, requestUrl, waitNextUrl ) where +import Prelude hiding ( catch ) + import Darcs.Global ( debugFail ) import Version ( version ) import URL.Request ( ConnectionError(..) ) #ifdef HAVE_HTTP +import Control.Exception ( catch, IOException ) import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) import Network.HTTP import Network.Browser ( browse, request, setCheckForProxy, setErrHandler, setOutHandler ) @@ -45,7 +48,7 @@ rqMethod = GET, rqHeaders = headers, rqBody = "" }) - (\err -> debugFail $ show err) + (\(err :: IOException) -> debugFail $ show err) case resp of (_, res@Response { rspCode = (2,0,0) }) -> return (rspBody res) (_, Response { rspCode = (x,y,z) }) -> @@ -65,7 +68,7 @@ Header HdrContentLength (show $ length body) ], rqBody = body }) - (\err -> debugFail $ show err) + (\(err :: IOException) -> debugFail $ show err) case resp of (_, res@Response { rspCode = (2,y,z) }) -> do putStrLn $ "Success 2" ++ show y ++ show z diff --git a/src/Workaround.hs b/src/Workaround.hs --- a/src/Workaround.hs +++ b/src/Workaround.hs @@ -25,11 +25,14 @@ , sigPIPE ) where +import Prelude hiding ( catch ) + #ifdef WIN32 import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile ) +import Control.Exception ( catch, IOException ) import qualified Control.Exception ( block ) -import qualified System.IO.Error ( isDoesNotExistError, ioError, catch ) +import qualified System.IO.Error ( isDoesNotExistError, ioError ) #else @@ -95,9 +98,9 @@ -> IO () renameFile old new = Control.Exception.block $ System.Directory.renameFile old new - `System.IO.Error.catch` \_ -> + `catch` \(_ :: IOException) -> do System.Directory.removeFile new - `System.IO.Error.catch` + `catch` (\e -> if System.IO.Error.isDoesNotExistError e then return () else System.IO.Error.ioError e) diff --git a/src/h_iconv.c b/src/h_iconv.c new file mode 100644 --- /dev/null +++ b/src/h_iconv.c @@ -0,0 +1,18 @@ +#include "h_iconv.h" + +// Wrapper functions, since iconv_open et al are macros in libiconv. +iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode) { + return iconv_open(tocode, fromcode); +} + +void haskeline_iconv_close(iconv_t cd) { + iconv_close(cd); +} + +size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft) { + // Cast inbuf to (void*) so that it works both on Solaris, which expects + // a (const char**), and on other platforms (e.g. Linux), which expect + // a (char **). + return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft); +} diff --git a/src/h_iconv.h b/src/h_iconv.h new file mode 100644 --- /dev/null +++ b/src/h_iconv.h @@ -0,0 +1,9 @@ +#include + +iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode); + +void haskeline_iconv_close(iconv_t cd); + +size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft); + diff --git a/src/test.hs b/src/test.hs --- a/src/test.hs +++ b/src/test.hs @@ -5,10 +5,12 @@ import qualified Darcs.Test.Patch import qualified Darcs.Test.Email -import Control.Monad (when) +import Control.Monad (when, filterM) import Data.List ( isPrefixOf, isSuffixOf, sort ) import qualified Data.ByteString.Char8 as B import System.Console.CmdLib +import System.Directory ( doesFileExist ) +import System.Environment.FindBin ( getProgPath ) import System.FilePath( takeDirectory, takeBaseName, isAbsolute ) import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr ) import Test.Framework.Providers.API @@ -49,6 +51,7 @@ , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly , _darcspath :: FilePath } + deriving Typeable runtest' :: ShellTest -> FilePath -> ShIO Result runtest' (ShellTest fmt _ _ dp) srcdir = @@ -60,7 +63,7 @@ setenv "EMAIL" "tester" setenv "DARCS_DONT_COLOR" "1" setenv "DARCS_DONT_ESCAPE_ANYTHING" "1" - getenv "PATH" >>= setenv "PATH" . ((takeDirectory dp ++ ":") ++) + getenv "PATH" >>= setenv "PATH" . ((takeDirectory dp ++ pathVarSeparator) ++) setenv "DARCS" dp mkdir ".darcs" writefile ".darcs/defaults" defaults @@ -74,6 +77,11 @@ fmtstr = case fmt of Darcs2 -> "darcs-2" Hashed -> "hashed" +#ifdef WIN32 + pathVarSeparator = ";" +#else + pathVarSeparator = ":" +#endif runtest :: ShellTest -> ShIO Result runtest t = @@ -152,15 +160,33 @@ Nothing -> return () Just d -> do e <- shellish (test_e d) when e $ fail ("Directory " ++ d ++ " already exists. Cowardly exiting") + darcsBin <- + case darcs conf of + "" -> do + path <- getProgPath + let candidates = + -- if darcs-test lives in foo/something, look for foo/darcs[.exe] + -- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal + -- installation folder + [path "darcs" ++ exeSuffix] ++ + -- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe] + -- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find + -- the darcs in dist/build/darcs/darcs + [takeDirectory path "darcs" "darcs" ++ exeSuffix | takeBaseName path == "darcs-test" ] + availableCandidates <- filterM doesFileExist candidates + case availableCandidates of + (darcsBin:_) -> do + putStrLn $ "Using darcs executable in " ++ darcsBin + return darcsBin + [] -> fail ("No darcs specified or found nearby. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?") + v -> return v when (shell conf || network conf || failing conf) $ do - when (null $ darcs conf) $ - fail ("No darcs specified. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?") - when (not (isAbsolute (darcs conf))) $ + when (not (isAbsolute $ darcsBin)) $ fail ("Argument to --darcs should be an absolute path") - when (not (exeSuffix `isSuffixOf` darcs conf)) $ + when (not (exeSuffix `isSuffixOf` darcsBin)) $ putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)" - ftests <- shellish $ if failing conf then findShell (darcs conf) (testDir conf) True else return [] - stests <- shellish $ if shell conf then findShell (darcs conf) (testDir conf) False else return [] + ftests <- shellish $ if failing conf then findShell darcsBin (testDir conf) True else return [] + stests <- shellish $ if shell conf then findShell darcsBin (testDir conf) False else return [] utests <- if unit conf then doUnit else return [] ntests <- shellish $ if network conf then findNetwork (darcs conf) (testDir conf) else return [] defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests) args diff --git a/src/win32/System/Posix.hs b/src/win32/System/Posix.hs --- a/src/win32/System/Posix.hs +++ b/src/win32/System/Posix.hs @@ -1,8 +1,9 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix ( sleep ) where -import Foreign.C.Types ( CInt, CUInt, CULong ) +import Foreign.C.Types ( CInt(..), CUInt(..), CULong(..) ) foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt diff --git a/src/win32/System/Posix/Files.hsc b/src/win32/System/Posix/Files.hsc --- a/src/win32/System/Posix/Files.hsc +++ b/src/win32/System/Posix/Files.hsc @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2 {-# LANGUAGE CPP, ForeignFunctionInterface #-} module System.Posix.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink , getFdStatus, getFileStatus, getSymbolicLinkStatus @@ -14,7 +15,7 @@ import Foreign.C.String( CWString, withCWString ) import Foreign.C.Error( throwErrnoPathIf_ ) import Foreign.Ptr( Ptr, nullPtr ) -import Foreign.C( CInt ) +import Foreign.C( CInt(..) ) linkCount :: FileStatus -> Int linkCount _ = 1 diff --git a/tests/data/metadata-encoding.tgz b/tests/data/metadata-encoding.tgz new file mode 100644 Binary files /dev/null and b/tests/data/metadata-encoding.tgz differ diff --git a/tests/harness.sh b/tests/harness.sh --- a/tests/harness.sh +++ b/tests/harness.sh @@ -16,11 +16,11 @@ if echo $OS | grep -i windows; then if echo $OSTYPE | grep -i cygwin ; then - real=$(cygpath -w $(command -v darcs.exe) | sed -e 's,\\,/,g') + real=$(cygpath -w $(command -v darcs.exe) | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') else - real=$(cmd //c echo $(command -v darcs.exe) | sed -e 's,\\,/,g') + real=$(cmd //c echo $(command -v darcs.exe) | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') fi - wanted=$(echo "$DARCS" | sed -e 's,\\,/,g') + wanted=$(echo "$DARCS" | sed -e 's,\\,/,g' | tr -s '[:upper:]' '[:lower:]') test "$real" = "$wanted" else command -v darcs | fgrep "$DARCS" diff --git a/tests/issue2199-get-dirty-tag.sh b/tests/issue2199-get-dirty-tag.sh new file mode 100644 --- /dev/null +++ b/tests/issue2199-get-dirty-tag.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## Test for issue2199 - "darcs get --tag" gets too much if the tag is dirty. +## +## Copyright (C) 2012 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +darcs init --repo R + +cd R +echo 'wibble' > file +darcs rec -lam 'wibble' +echo 'wobble' > file +darcs rec -lam 'wobble' +cd .. + +darcs get R R-temp + +cd R-temp +darcs unpull --patch 'wobble' -a +darcs tag 'wibble' +cd .. + +cd R +darcs pull ../R-temp -a +cd .. + +darcs get --tag wibble R R-tag +cd R-tag +darcs changes | not grep wobble diff --git a/tests/issue2286-metadata-encoding.sh b/tests/issue2286-metadata-encoding.sh new file mode 100644 --- /dev/null +++ b/tests/issue2286-metadata-encoding.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash +## Test for issue2286 - darcs cha fails when reading non-UTF8 encoded +## metadata +## +## Copyright (C) 2012 Ganesh Sittampalam +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +switch_to_utf8_locale + +gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf - + +cd metadata-encoding +darcs changes diff --git a/tests/lib b/tests/lib --- a/tests/lib +++ b/tests/lib @@ -24,34 +24,42 @@ } switch_to_latin9_locale () { - if ! which locale ; then - echo "no locale command, skipping test" - exit 200 - fi + if echo $OS | grep -i windows; then + chcp.com 28605 + else + if ! which locale ; then + echo "no locale command, skipping test" + exit 200 + fi - # look for a ISO 8859-15 locale. locale -a shows iso885915, on ubuntu at least - latin9_locale=`locale -a | grep -i iso885915 | head -n 1` || (no_latin9_locale_warning; exit 200) - test -n "$latin9_locale" || (no_latin9_locale_warning; exit 200) + # look for a ISO 8859-15 locale. locale -a shows iso885915, on ubuntu at least + latin9_locale=`locale -a | egrep -i iso8859-?15 | head -n 1` || (no_latin9_locale_warning; exit 200) + test -n "$latin9_locale" || (no_latin9_locale_warning; exit 200) - echo "Using locale $latin9_locale" - export LC_ALL=$latin9_locale - echo "character encoding is now `locale charmap`" + echo "Using locale $latin9_locale" + export LC_ALL=$latin9_locale + echo "character encoding is now `locale charmap`" + fi } # switch locale to utf8 if supported if there's a locale command, skip test # otherwise switch_to_utf8_locale () { - if ! which locale ; then - echo "no locale command" - exit 200 # skip test - fi + if echo $OS | grep -i windows; then + chcp.com 65001 + else + if ! which locale ; then + echo "no locale command" + exit 200 # skip test + fi - utf8_locale=`locale -a | grep .utf8 | head -n 1` || exit 200 - test -n "$utf8_locale" || exit 200 + utf8_locale=`locale -a | grep .utf8 | head -n 1` || exit 200 + test -n "$utf8_locale" || exit 200 - echo "Using locale $utf8_locale" - export LC_ALL=$utf8_locale - echo "character encoding is now `locale charmap`" + echo "Using locale $utf8_locale" + export LC_ALL=$utf8_locale + echo "character encoding is now `locale charmap`" + fi } serve_http() { diff --git a/tests/utf8.sh b/tests/utf8.sh --- a/tests/utf8.sh +++ b/tests/utf8.sh @@ -41,6 +41,7 @@ if grep "$1" changes.xml ; then echo "$2 OK" else + cat changes.xml echo "$2 not UTF-8-encoded!" exit 1 fi @@ -70,7 +71,6 @@ echo n >> interaction_script.txt unset DARCSEMAIL -unset DARCS_TESTING_PREFS_DIR unset EMAIL set darcs record -i < interaction_script.txt @@ -117,9 +117,13 @@ echo y | darcs amend-record -p 'Patch by ' -A '´ed is even deader' -a grep_changes 'Žed is even deader' 'author name from amend-record command line flag' -echo '#!/usr/bin/env bash' > editor -echo 'echo All my ¤s are gone > $1' >> editor # create an 'editor' that writes latin9 -chmod +x editor +cat < editor.hs # create an 'editor' that writes latin9 +import System.Environment +import qualified Data.ByteString as B +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 export EDITOR="`pwd`/editor" printf "y\ny\n" | darcs amend --edit -p 'Patch by ' grep_changes 'All my €s are gone' 'description edited from amend-record'